github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-26 18:33:26 +00:00
Code Issues Projects Releases Wiki Activity

pull more newer library lispusers internal(/library) files from envos (#813)

Browse Source
This commit is contained in:
Larry Masinter
2022-07-03 21:24:36 -07:00
committed by GitHub
parent d7ca40ebeb
commit 25e791de4f
47 changed files with 10448 additions and 1724 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
internal/COPRFIX Normal file
View File

@@ -0,0 +1,57 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "12-Jun-90 18:10:37" |{DSK}<usr>local>lde>lispcore>internal>COPRFIX.;1| 1909
|changes| |to:| (FNS FIX-FILE)
|previous| |date:| "11-Jun-90 13:13:14" |{DSK}<users>sybalsky>COPRFIX.;3|)
; Copyright (c) 1990 by John Sybalsky. All rights reserved.
(PRETTYCOMPRINT COPRFIXCOMS)
(RPAQQ COPRFIXCOMS ((FNS FIX-COPYRIGHT FIX-FILE-COPYRIGHT FIX-FILE QUALIFY-FIELDS)))
(DEFINEQ
(FIX-COPYRIGHT
(LAMBDA (FILENAME)
(LET ((CR (GETPROP FILENAME 'COPYRIGHT)))
(COND
(CR (RPLACA CR "Venue & Xerox Corporation"))
(T (PUTPROP FILENAME 'COPYRIGHT (LIST "Venue" 1990)))))))
(FIX-FILE-COPYRIGHT
(LAMBDA (FILE)
(LOADFROM FILE NIL 'PROP)
(FIX-COPYRIGHT FILE)
(MARKASCHANGED FILE 'FILES)
(APPLY* 'CLEANUP FILE)))
(FIX-FILE
(LAMBDA (FILE RECORD-NAMES) (* \; "Edited 11-Jun-90 17:49 by mitani")
(* |;;| "Perform cleanup tasks on FILE.")
(LOAD FILE 'PROP)
(LOADCOMP FILE 'PROP)
(FIX-COPYRIGHT FILE)
(AND (FILEFNSLST FILE)
(|for| RECNAME |in| RECORD-NAMES |do| (QUALIFY-FIELDS RECNAME FILE)))
(MARKASCHANGED FILE 'FILES)
(APPLY* 'CLEANUP FILE)))
(QUALIFY-FIELDS
(LAMBDA (RECNAME FILE) (* \; "Edited 28-Sep-87 14:41 by bvm:")
(APPLY* 'EDITFNS FILE `(LPQ F ((*ANY* FETCH |fetch| REPLACE |replace| FFETCH |ffetch| FREPLACE
|freplace| /REPLACE |/replace|)
(*ANY* ,@(APPEND (RECORDFIELDNAMES RECNAME)))
--)
2
(MBD ,RECNAME)
0 P))))
)
(PUTPROPS COPRFIX COPYRIGHT ("John Sybalsky" 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (460 1834 (FIX-COPYRIGHT 470 . 697) (FIX-FILE-COPYRIGHT 699 . 859) (FIX-FILE 861 . 1291)
(QUALIFY-FIELDS 1293 . 1832)))))
STOP

59
internal/envos/AR-11348-PATCH Normal file
View File

@@ -0,0 +1,59 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Mar-91 18:37:25" {DSK}<home>crea>mitani>medley>ar>fuji>AR-11348-PATCH.;3 12223
changes to%: (FNS \UFSDirectoryNameP \UFSGetPrintFileType \UFS.NEXTFILEFN \UFS.FULLNAME \UFSParseNameString)
(VARS AR-11348-PATCHCOMS))
(* ; "
Copyright (c) 1991 by Fuji Xerox Co., Ltd. All rights reserved.
")
(PRETTYCOMPRINT AR-11348-PATCHCOMS)
(RPAQQ AR-11348-PATCHCOMS ((FNS \UFS.REMOVE.HOST.FIELD \UFSDirectoryNameP \UFSGenerateFiles \UFSGetFileInfo \UFSSetFileInfo \UFSGetPrintFileType \UFS.NEXTFILEFN \UFS.FULLNAME \UFSParseNameString)))
(DEFINEQ
(\UFS.REMOVE.HOST.FIELD
(LAMBDA (FILE DEV) (* ; "Edited 20-Mar-91 16:52 by nm") (* ;; "Accepts a full file representation, and returns the file representaion as a string in which HOST field is removed.") (LET* ((PARSE-LIST (\UFSParseNameString FILE)) (RELATIVEDIRECTORY (MEMB (QUOTE RELATIVEDIRECTORY) PARSE-LIST)) (DIRECTORY (LISTGET PARSE-LIST (QUOTE DIRECTORY))) PACKED-NAME VERSION) (if (DSKP DEV) then (* ;; " Check if FILE contains the valid version field or not so that C code can assume that all file names are valid.") (AND (SETQ VERSION (LISTGET PARSE-LIST (QUOTE VERSION))) (if (STREQUAL VERSION "") then (* ;; "Newest version is specifed. Just removes it.") (LISTPUT PARSE-LIST (QUOTE VERSION) NIL) else (OR (FIXP (MKATOM VERSION)) (CL:ERROR (QUOTE XCL:INVALID-PATHNAME) :PATHNAME FILE))))) (if RELATIVEDIRECTORY then (RPLACA (CDR RELATIVEDIRECTORY) (\UFS.HANDLE.RELATIVEDIRECTORY (CADR RELATIVEDIRECTORY) DEV)) elseif (NOT DIRECTORY) then (LISTPUT PARSE-LIST (QUOTE DIRECTORY) (\UFS.DEFAULT.DIR DEV))) (LISTPUT PARSE-LIST (QUOTE HOST) NIL) (SETQ PACKED-NAME (PACKFILENAME.STRING PARSE-LIST)) (if (STREQUAL (LISTGET PARSE-LIST (QUOTE DIRECTORY)) "<") then (if (LISTGET PARSE-LIST (QUOTE NAME)) then (SUBSTRING PACKED-NAME 2) else "<") else (if (EQ (NTHCHARCODE PACKED-NAME 1) (CHARCODE <)) then (SUBSTRING PACKED-NAME 2) else PACKED-NAME))))
)
(\UFSDirectoryNameP
(LAMBDA (DIRSPEC DEV) (* ; "Edited 22-Mar-91 18:22 by nm") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") (LET* ((PARSED-LIST (\UFSParseNameString DIRSPEC (QUOTE RETURN))) (DIRECTORY (OR (LISTGET PARSED-LIST (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED-LIST (QUOTE RELATIVEDIRECTORY)) DEV) (\UFS.DEFAULT.DIR DEV))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))))
)
(\UFSGenerateFiles
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 20-Mar-91 17:08 by nm") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (\UFSParseNameString PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (if (STREQUAL DIRECTORY "/") then (SETQ DIRECTORY "<")) (SETQ FILTER (if (STREQUAL DIRECTORY "<") then (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))) else (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA FDEV)) (if (NOT (FIXP LEN)) then (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (if (< TOTALNUM 0) then (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR))) else (if (ZEROP TOTALNUM) then (RETURN (\NULLFILEGENERATOR)) else (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN))))))))))))
)
(\UFSGetFileInfo
(LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 20-Mar-91 20:17 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.ADD.HOST.FIELD (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL)))))
)
(\UFSSetFileInfo
(LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 20-Mar-91 20:17 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.ADD.HOST.FIELD (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL)))))
)
(\UFSGetPrintFileType
(LAMBDA (FILENAME) (* ; "Edited 22-Mar-91 18:30 by nm") (COND ((OR (NOT (STREAMP FILENAME)) (SETQ FILENAME (fetch (STREAM FULLFILENAME) of FILENAME))) (LET ((TYPE (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)))) (SETQ TYPE (COND ((AND (EQ (NCHARS TYPE) 0) (CDR (CL:ASSOC NIL DEFAULTFILETYPELIST)))) ((CDR (CL:ASSOC TYPE DEFAULTFILETYPELIST :TEST (QUOTE STRING-EQUAL)))) (T (\UFSGetFileTypeConfirm FILENAME)))) (SELECTQ TYPE ((TEXT BINARY) TYPE) (CL:ERROR "Invalid File Type ~A for ~A" TYPE FILENAME))))))
)
(\UFS.NEXTFILEFN
(LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 22-Mar-91 18:29 by nm") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (if (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) then (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE) NIL (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE)))) (if (= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) then (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T) else (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID)) (if NAMEONLY then NEWNAME else FILENAME)) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))))
)
(\UFS.FULLNAME
(LAMBDA (NAME DEV ATOMP DIRECTORY) (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) (* ; "Edited 22-Mar-91 18:35 by nm") (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") (if NAME then (* ; "Pass NIL thru transparently") (if (DSKP DEV) then (SETQ NAME (CL:CONCATENATE (QUOTE STRING) *DSK-HOST-NAME* DIRECTORY NAME)) (if *DSK-UPPER-CASE-FILE-NAMES* then (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") (if ATOMP then (MKATOM (U-CASE NAME)) else (U-CASE NAME)) else (if ATOMP then (MKATOM NAME) else NAME)) else (SETQ NAME (CL:CONCATENATE (QUOTE STRING) *UFS-HOST-NAME* DIRECTORY NAME)) (if ATOMP then (MKATOM NAME) else NAME))))
)
(\UFSParseNameString
(LAMBDA (FILE DIRFLG) (* ; "Edited 22-Mar-91 18:19 by nm") (* ;; "\UFS.ADJUST.HOST is a hook for NFS module") (\UFS.ADJUST.HOST (UNPACKFILENAME.STRING FILE NIL DIRFLG)))
)
)
(PUTPROPS AR-11348-PATCH COPYRIGHT ("Fuji Xerox Co., Ltd" 1991))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (625 12135 (\UFS.REMOVE.HOST.FIELD 635 . 1996) (\UFSDirectoryNameP 1998 . 2970) (
\UFSGenerateFiles 2972 . 5532) (\UFSGetFileInfo 5534 . 7818) (\UFSSetFileInfo 7820 . 9051) (
\UFSGetPrintFileType 9053 . 9589) (\UFS.NEXTFILEFN 9591 . 10649) (\UFS.FULLNAME 10651 . 11935) (
\UFSParseNameString 11937 . 12133)))))
STOP

119
internal/envos/AR-PIECETREE-PATCH Normal file
View File

@@ -0,0 +1,119 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 10:42:39" 
{DSK}<usr>local>lde>lispcore>internal>library>AR-PIECETREE-PATCH.;2 6122
changes to%: (VARS AR-PIECETREE-PATCHCOMS)
(FNS TEDIT.FAST.RAW.INCLUDE AR.PIECE.CHANGED)
previous date%: "20-Apr-90 12:21:43"
{DSK}<usr>local>lde>lispcore>internal>library>AR-PIECETREE-PATCH.;1)
(* ; "
Copyright (c) 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT AR-PIECETREE-PATCHCOMS)
(RPAQQ AR-PIECETREE-PATCHCOMS ((COMS
(* ;;
 "PATCH for AREDIT for TEDIT modification. (Replace piece table info balanced tree.)")
(* ;;
 "following functions depend on piece table structure.")
(FILES TEDITDECLS)
(FNS TEDIT.FAST.RAW.INCLUDE AR.PIECE.CHANGED))))
(* ;; "PATCH for AREDIT for TEDIT modification. (Replace piece table info balanced tree.)")
(* ;; "following functions depend on piece table structure.")
(FILESLOAD TEDITDECLS)
(DEFINEQ
(TEDIT.FAST.RAW.INCLUDE
[LAMBDA (TEXTSTREAM INSTREAM START END INSERTCH#) (* ; "Edited 15-Jun-90 10:42 by jds")
(* ;; "takes a text stream and an OPEN stream to include at character INSERTCH#. Note: Start and End are inclusive ptrs, unlike in copybytes and friends. No interpretation (alternate file type e.g. Bravo) takes place. INSTREAM is not copied, so you'd better not be changing it.")
(LET* [(TEXTOBJ (TEXTOBJ TEXTSTREAM))
(PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
(INSPC# (OR (\CHTOPCNO INSERTCH# PCTB)
(INDEX (fetch CHNUM of (\LASTNODE PCTB))
PCTB)))
(INSPC (fetch PCE of (FINDNODE-INDEX PCTB INSPC#)))
(LEN (- (OR END (GETEOFPTR INSTREAM))
(OR START (SETQ START 0] (* ;
 "INSPC is the piece to make the insertion in")
(COND
([AND (NEQ INSPC 'LASTPIECE)
(> INSERTCH# (fetch CHNUM of (FINDNODE-INDEX PCTB INSPC#]
(* ; "Must split the piece.")
(SETQ INSPC (\SPLITPIECE INSPC INSERTCH# TEXTOBJ INSPC#))
(add INSPC# 1)))
(\TEDIT.INSERT.PIECES TEXTOBJ INSERTCH#
(create PIECE
PFILE _ INSTREAM
PFPOS _ START
PLEN _ LEN
PREVPIECE _ NIL
NEXTPIECE _ NIL
PLOOKS _ (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
PPARALAST _ NIL
PPARALOOKS _ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))
LEN INSPC INSPC#)
(add (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
LEN])
(AR.PIECE.CHANGED
[LAMBDA (TEXTOBJ TEXTSTREAM CH# REFSTREAM START LEN) (* ; "Edited 15-Jun-90 10:42 by jds")
(* ;; "Compares TEXTOBJ/TEXTSTREAM at position CH# with the contents of REFSTREAM from filepointer START for the next LEN bytes. If they're different, returns T.")
(* ;; "Do this by comparing pieces. This is fast in the average case (the piece is unchanged), and takes into account the fact that the textstream may be backed by REFSTREAM, so file pointers would step on each other.")
(LET* ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
(PIECE# (\CHTOPCNO CH# PCTB))
PIECE)
(if (NULL PIECE#)
then (* ; "Shouldn't happen")
T
else (SETQ PIECE (fetch PCE of (FINDNODE-INDEX PCTB PIECE#)))
(do (if (ATOM PIECE)
then (* ; "Shouldn't happen")
(RETURN NIL))
(if [NOT (if (EQ (fetch (PIECE PFILE) of PIECE)
REFSTREAM)
then (* ;
 "Same as reference stream--they're same if starts match, assume different otherwise")
(= (fetch (PIECE PFPOS) of PIECE)
START)
else (* ;
 "Somewhere else, so compare byte by byte")
(SETFILEPTR TEXTSTREAM (SUB1 CH#))
(SETFILEPTR REFSTREAM START)
(to (fetch (PIECE PLEN) of PIECE)
always (EQ (BIN TEXTSTREAM)
(BIN REFSTREAM]
then (RETURN T))
(if (> (SETQ LEN (- LEN (fetch (PIECE PLEN) of PIECE)))
0)
then (add START (fetch (PIECE PLEN) of PIECE))
(add CH# (fetch (PIECE PLEN) of PIECE))
(SETQ PIECE (fetch (PIECE NEXTPIECE) of PIECE))
else (* ;
 "That's all the way to the end, so we succeeded")
(RETURN NIL])
)
(PUTPROPS AR-PIECETREE-PATCH COPYRIGHT ("Venue & Xerox Corporation" 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1274 6024 (TEDIT.FAST.RAW.INCLUDE 1284 . 3221) (AR.PIECE.CHANGED 3223 . 6022)))))
STOP

727
internal/envos/ARADMIN Normal file
View File

@@ -0,0 +1,727 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "27-Nov-90 10:25:47" |{PALLAS:MV:ENVOS}<LISPARS>ADMIN>ARADMIN.;32| 42686
|changes| |to:| (VARS ARADMINCOMS)
(FNS |Smart-Trickle|)
(FUNCTIONS START-EMULATOR-TRICKLES START-NOTECARDS-TRICKLES START-LISPCORE-TRICKLES RESTART-TRICKLES)
|previous| |date:| "26-Nov-90 12:25:05" |{PALLAS:MV:ENVOS}<LISPARS>ADMIN>ARADMIN.;31|)
; Copyright (c) 1990 by Venue. All rights reserved.
(PRETTYCOMPRINT ARADMINCOMS)
(RPAQQ ARADMINCOMS (
(* |;;| "Functions for helping do the routine chores of AR Administration. Set up to run things automatically.")
(VARS (IDLE.PROFILE '(TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL DISPLAYFN (LAMBDA (W)
(IDLE.BOUNCING.BOX W "Auto AR Cleanup Machine"))))
(IDLE.TIMEOUT NIL)
(IDLE.DEFAULTMODE 'UNLOCKED))
(ADDVARS (INITIALSLST (SYBALSKY |John| |jds|)))
(VARS (LOGINHOST/DIR '|{AR:MV:ENVOS}<LISPARS>ADMIN>|)
(SYSOUTGAG T)
(PROMPT#FLG T)
(DEFAULTREGISTRY '|envos|)
(CH.DEFAULT.DOMAIN 'MV)
(CH.DEFAULT.ORGANIZATION 'ENVOS)
(DIRECTORIES '("{DSK}/USR/LOCAL/LDE/LISPCORE/SOURCES/" "{DSK}/USR/LOCAL/LDE/LISPCORE/LIBRARY/" "{DSK}/USR/LOCAL/LDE/LISPCORE/INTERNAL/LIBRARY/" "{DSK}/USR/LOCAL/LDE/LISPUSERS/" "{DSK}<usr>local>lde>rooms>sources>" "{DSK}<usr>local>lde>rooms>users-src>" {DSK}))
(DISPLAYFONTDIRECTORIES '("{DSK}/usr/local/lde/fonts/display/publishing/" "{DSK}/usr/local/lde/fonts/display/presentation/" "{DSK}/usr/local/lde/lispcore/XeroxPrivate/Fonts" "{DSK}/usr/local/lde/fonts/display/chinese/" "{DSK}/usr/local/lde/fonts/display/JIS1/" "{DSK}/usr/local/lde/fonts/display/JIS2/" "{DSK}/usr/local/lde/fonts/display/miscellaneous/" "{DSK}/usr/local/lde/fonts/display/printwheel/"))
(DISPLAYFONTEXTENSIONS '(AC DISPLAYFONT STRIKE))
(INTERPRESSFONTDIRECTORIES '("{DSK}/usr/local/lde/fonts/interpress/publishing/" "{DSK}/usr/local/lde/fonts/interpress/presentation/" "{DSK}/usr/local/lde/lispcore/XeroxPrivate/Fonts" "{DSK}/usr/local/lde/fonts/interpress/chinese/" "{DSK}/usr/local/lde/fonts/interpress/JIS1/" "{DSK}/usr/local/lde/fonts/interpress/JIS2/" "{DSK}/usr/local/lde/fonts/interpress/miscellaneous/" "{DSK}/usr/local/lde/fonts/interpress/printwheel/"))
(DEFAULTPRINTINGHOST '("Twister:" "Tremor:")))
(* |;;| "")
(* |;;| "Tools to load")
(* |;;| "")
(DECLARE\: DONTEVAL@LOAD DOCOPY (FILES PROMPTREMINDERS CROCK WHO-LINE FILEWATCH)
(P (LAFITEMODE 'NS)
(LOGOW "AR & Trickle")
(CROCK (CREATEREGION 900 800 100 100))))
(* |;;| "")
(* |;;| " The AR stuff")
(* |;;| "")
(* |;;| "Every other day AR.CLEANUP to create new summaries &c")
(* |;;| "")
(FNS PERIODIC-AR-CLEANUP DO-PERIODIC-AR-CLEANUP)
(* |;;| "Weekly creation of the list of ARs to review.")
(FNS PERIODIC-AR-REVIEW DO-WEEKLY-AR-REVIEW)
(FNS MY-FLOOR)
(DECLARE\: DONTEVAL@LOAD DOCOPY (FILES ARCLEANUP ARHACK)
(VARS (STARTING-MONDAY (IDATE "5-DEC-88 07:00:00"))
(ONE-WEEK 604800)
(ONE-DAY 86400))
(P (PERIODIC-AR-CLEANUP 24)
(PERIODIC-AR-REVIEW)))
(* |;;| "")
(* |;;| "The trickle stuff")
(* |;;| "")
(FUNCTIONS RESTART-TRICKLES START-EMULATOR-TRICKLES START-NOTECARDS-TRICKLES START-LISPCORE-TRICKLES FILE-SERVER-UPP)
(FNS |Smart-Identifier| |Smart-Trickle| |TrickleProcessLogfile|)
(DECLARE\: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
PROMPTREMINDERS COPYFILES)
(INITVARS (*FUJI-TRICKLE-MAIL-ADDRESS* "AR-MANAGERS:MV:envos, Shunko Inoue:KSPA:Fuji Xerox"))
(* |;;| "Start the Trickle Stuff")
(P (START-EMULATOR-TRICKLES)
(START-LISPCORE-TRICKLES)
(START-NOTECARDS-TRICKLES)))))
(* |;;| "Functions for helping do the routine chores of AR Administration. Set up to run things automatically.")
(RPAQQ IDLE.PROFILE (TIMEOUT NIL FORGET NIL ALLOWED.LOGINS NIL DISPLAYFN (LAMBDA (W)
(IDLE.BOUNCING.BOX W "Auto AR Cleanup Machine"))))
(RPAQQ IDLE.TIMEOUT NIL)
(RPAQQ IDLE.DEFAULTMODE UNLOCKED)
(ADDTOVAR INITIALSLST (SYBALSKY |John| |jds|))
(RPAQQ LOGINHOST/DIR |{AR:MV:ENVOS}<LISPARS>ADMIN>|)
(RPAQQ SYSOUTGAG T)
(RPAQQ PROMPT#FLG T)
(RPAQQ DEFAULTREGISTRY |envos|)
(RPAQQ CH.DEFAULT.DOMAIN MV)
(RPAQQ CH.DEFAULT.ORGANIZATION ENVOS)
(RPAQQ DIRECTORIES ("{DSK}/USR/LOCAL/LDE/LISPCORE/SOURCES/" "{DSK}/USR/LOCAL/LDE/LISPCORE/LIBRARY/" "{DSK}/USR/LOCAL/LDE/LISPCORE/INTERNAL/LIBRARY/" "{DSK}/USR/LOCAL/LDE/LISPUSERS/" "{DSK}<usr>local>lde>rooms>sources>" "{DSK}<usr>local>lde>rooms>users-src>" {DSK}))
(RPAQQ DISPLAYFONTDIRECTORIES ("{DSK}/usr/local/lde/fonts/display/publishing/" "{DSK}/usr/local/lde/fonts/display/presentation/" "{DSK}/usr/local/lde/lispcore/XeroxPrivate/Fonts" "{DSK}/usr/local/lde/fonts/display/chinese/" "{DSK}/usr/local/lde/fonts/display/JIS1/" "{DSK}/usr/local/lde/fonts/display/JIS2/" "{DSK}/usr/local/lde/fonts/display/miscellaneous/" "{DSK}/usr/local/lde/fonts/display/printwheel/"))
(RPAQQ DISPLAYFONTEXTENSIONS (AC DISPLAYFONT STRIKE))
(RPAQQ INTERPRESSFONTDIRECTORIES ("{DSK}/usr/local/lde/fonts/interpress/publishing/" "{DSK}/usr/local/lde/fonts/interpress/presentation/" "{DSK}/usr/local/lde/lispcore/XeroxPrivate/Fonts" "{DSK}/usr/local/lde/fonts/interpress/chinese/" "{DSK}/usr/local/lde/fonts/interpress/JIS1/" "{DSK}/usr/local/lde/fonts/interpress/JIS2/" "{DSK}/usr/local/lde/fonts/interpress/miscellaneous/" "{DSK}/usr/local/lde/fonts/interpress/printwheel/"))
(RPAQQ DEFAULTPRINTINGHOST ("Twister:" "Tremor:"))
(* |;;| "")
(* |;;| "Tools to load")
(* |;;| "")
(DECLARE\: DONTEVAL@LOAD DOCOPY
(FILESLOAD PROMPTREMINDERS CROCK WHO-LINE FILEWATCH)
(LAFITEMODE 'NS)
(LOGOW "AR & Trickle")
(CROCK (CREATEREGION 900 800 100 100))
)
(* |;;| "")
(* |;;| " The AR stuff")
(* |;;| "")
(* |;;| "Every other day AR.CLEANUP to create new summaries &c")
(* |;;| "")
(DEFINEQ
(PERIODIC-AR-CLEANUP
(LAMBDA (HRS-BETWEEN-CLEANUPS START-TIME) (* \; "Edited 7-Dec-88 04:49 by kk")
(* |;;|
 "Schedule regular AR Cleanups to happen at 04:00 daily (or at whatever start time is specified)")
(LET* ((1AM-TODAY (IDATE (CONCAT (SUBSTRING (DATE)
1 10)
"00:01:00")))
(NEXT-START (COND
((>= (IDATE)
1AM-TODAY)
(+ 1AM-TODAY 86400))
(T 1AM-TODAY))))
(SETREMINDER '|AR-Cleanup| (TIMES HRS-BETWEEN-CLEANUPS 3600)
'(ADD.PROCESS '(DO-PERIODIC-AR-CLEANUP))
(OR START-TIME (GDATE NEXT-START))
(+ (IDATE)
(CL:* 365 86400))))))
(DO-PERIODIC-AR-CLEANUP
(LAMBDA NIL (* \; "Edited 27-Sep-90 15:30 by gadener")
(* |;;| "Do the actual work for periodic AR cleanups: Do the cleanup, then delete the excess files on the summary subdirectory.")
(DRIBBLE "{LPT}")
(PRINTOUT T ";;;" T)
(PAGEHEIGHT 0)
(WINDOWPROP (PROCESS.WINDOW (THIS.PROCESS))
'PAGEFULLFN
'NILL)
(PRINTOUT T ";;; * * * * * * * * * * * * * * * * * * * * * * * * *" T
";;; * * * * * * * * * * * * * * * * * * * * * * * * *" T ";;;" T
";;; A R C L E A N U P" T ";;;" T ";;; Started at " (DATE)
T)
(PRINTOUT T ";;; Deleting {DSK}AR.INDEX ... ")
(AND (> (LENGTH (DIRECTORY '|{dsk}AR.INDEX|))
1)
(DELFILE '|{dsk}AR.INDEX|))
(PRINTOUT T "done." T ";;; Starting AR.CLEANUP" T)
(AR.CLEANUP T '{DSK} T '{DSK})
(PRINTOUT T T T ";;; AR.CLEANUP finished at " (DATE)
T ";;; Deleting .TXT & .IP files ..." T)
(DIRECTORY "{AR:MV:ENVOS}<LISPARS>SUMMARIES>*.TXT;L" '(DELETE))
(DIRECTORY "{AR:MV:ENVOS}<LISPARS>SUMMARIES>*.IP;L" '(DELETE))
(AND (> (LENGTH (DIRECTORY "{AR:MV:ENVOS}<LISPARS>AR.INDEX"))
2)
(PRINTOUT T ";;; Deleting AR.INDEX ... " (DELFILE "{AR:MV:ENVOS}<LISPARS>AR.INDEX")
T))
(PRINTOUT T ";;; Setting cleanup to run again at " (GDATE (+ ONE-DAY
(IDATE (CONCAT (SUBSTRING (DATE)
1 10)
"00:01:00"))))
"." T)
(REMINDER.NEXTREMINDDATE '|AR-Cleanup| (GDATE (+ ONE-DAY (IDATE (CONCAT (SUBSTRING (DATE)
1 10)
"00:01:00")))))
(DRIBBLE)))
)
(* |;;| "Weekly creation of the list of ARs to review.")
(DEFINEQ
(PERIODIC-AR-REVIEW
(LAMBDA (INITIAL-DELAY) (* \; "Edited 27-Sep-90 15:46 by gadener")
(* |;;| "Schedule regular AR Reviews to happen at 07:00 every Monday")
(LET* ((7AM-TODAY (IDATE (CONCAT (SUBSTRING (DATE)
1 10)
"00:07:00")))
(NEXT-START (COND
((>= (IDATE)
7AM-TODAY)
(+ 7AM-TODAY 86400))
(T 7AM-TODAY))))
(SETREMINDER '|AR-Review| ONE-WEEK '(ADD.PROCESS '(DO-WEEKLY-AR-REVIEW))
(COND
(INITIAL-DELAY INITIAL-DELAY)
(T (GDATE NEXT-START)))
(+ (IDATE)
(CL:* 365 86400))))))
(DO-WEEKLY-AR-REVIEW
(LAMBDA NIL (* \; "Edited 28-Sep-90 13:49 by gadener")
(LET ((LAST-REVIEWED-AR (CAR (READFILE "{AR:MV:ENVOS}<LispARs>ADMIN>LAST-REVIEWED-AR")))
LAST-FOUND-AR MESSAGE)
(PRINTOUT T ";;;" T)
(DRIBBLE "{LPT}")
(PAGEHEIGHT 0)
(WINDOWPROP (PROCESS.WINDOW (THIS.PROCESS))
'PAGEFULLFN
'NILL)
(PRINTOUT T T ";;; * * * * * * * * * * * * * * * * * * * * * * * * *" T
";;; * * * * * * * * * * * * * * * * * * * * * * * * *" T
";;; A R R E V I E W" T ";;;" T ";;; Starting at " (DATE)
T)
(SETQ LAST-FOUND-AR LAST-REVIEWED-AR)
(|for| TRIAL-AR |from| LAST-REVIEWED-AR |while| (<= TRIAL-AR (+ LAST-FOUND-AR 50
))
|when| (INFILEP (PACKFILENAME.STRING 'NAME TRIAL-AR 'BODY
"{AR:MV:ENVOS}<LISPARS>FOO.AR")) |do| (SETQ LAST-FOUND-AR
TRIAL-AR))
(LAFITEMODE 'NS)
(SETQ MESSAGE (CONCAT "Subject: ARs to Review
" "To: AR-Managers:MV:envos
" (CL:FORMAT NIL "Printing for review ARs ~d-~d. " (ADD1 LAST-REVIEWED-AR)
LAST-FOUND-AR)
"John will be around with them...." "
--The AR Daemon
"))
(LAFITE.SENDMESSAGE (OPENTEXTSTREAM MESSAGE))
(AR.HARDCOPY (|for| I |from| (ADD1 LAST-REVIEWED-AR) |to| LAST-FOUND-AR
|collect| I))
(CL:WITH-OPEN-FILE (NEW-AR "{AR:MV:ENVOS}<LispARs>ADMIN>LAST-REVIEWED-AR" :DIRECTION :OUTPUT
:IF-EXISTS :NEW-VERSION)
(PRINT LAST-FOUND-AR NEW-AR))
(PRINTOUT T ";;; AR Review copies printed at" (DATE)
"." T)
(* |;;| "Set up to run next week at the same time:")
(REMINDER.NEXTREMINDDATE '|AR-Review| (GDATE (+ STARTING-MONDAY (CL:* ONE-WEEK
(CL:CEILING
(- (IDATE)
STARTING-MONDAY)
ONE-WEEK))))))))
)
(DEFINEQ
(MY-FLOOR
(LAMBDA (NUMBER DIVISOR)
(CL:* DIVISOR (CL:FLOOR NUMBER DIVISOR))))
)
(DECLARE\: DONTEVAL@LOAD DOCOPY
(FILESLOAD ARCLEANUP ARHACK)
(RPAQ STARTING-MONDAY (IDATE "5-DEC-88 07:00:00"))
(RPAQQ ONE-WEEK 604800)
(RPAQQ ONE-DAY 86400)
(PERIODIC-AR-CLEANUP 24)
(PERIODIC-AR-REVIEW)
)
(* |;;| "")
(* |;;| "The trickle stuff")
(* |;;| "")
(CL:DEFUN RESTART-TRICKLES ()
(FOR REMINDER IN (ACTIVEREMINDERNAMES) DO (COND
((NOT (OR (EQL REMINDER '|AR-Cleanup|)
(EQL REMINDER '|AR-Review|)))
(DELDEF REMINDER 'REMINDERS))))
(* |;;| "Got rid of the old reminder, now ready to restart everything again")
(START-EMULATOR-TRICKLES)
(START-LISPCORE-TRICKLES)
(START-NOTECARDS-TRICKLES)
T)
(CL:DEFUN START-EMULATOR-TRICKLES ()
(DECLARE (GLOBAL *FUJI-TRICKLE-MAIL-ADDRESS*))
(SETREMINDER NIL NIL `(|Smart-Trickle| "{DSK}<users>maiko>working>src>*" "{Fuusen:KSPA:Fuji Xerox}<Venue>Emul>working>src>*" "{DSK}<python>medley-trickles/emulator/src-" ,*FUJI-TRICKLE-MAIL-ADDRESS* "06:00" NIL NIL)
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL `(|Smart-Trickle| "{DSK}<users>maiko>working>inc>*" "{Fuusen:KSPA:Fuji Xerox}<Venue>Emul>working>inc>*" "{DSK}<python>medley-trickles/emulator/inc-" ,*FUJI-TRICKLE-MAIL-ADDRESS* "07:00" NIL NIL)
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL `(|Smart-Trickle| "{DSK}<users>maiko>working>bin>*" "{Fuusen:KSPA:Fuji Xerox}<Venue>Emul>working>bin>*" "{DSK}<python>medley-trickles/emulator/bin-" ,*FUJI-TRICKLE-MAIL-ADDRESS* "08:00" NIL NIL)
(TIMES 60 (RAND 10 60))))
(CL:DEFUN START-NOTECARDS-TRICKLES ()
(* |;;;| "")
(* |;;;| "Setup all the NoteCards Core Trickles ")
(* |;;;| "")
(SETREMINDER NIL NIL '(|Smart-Trickle| "{Pika:MV:ENVOS}<NoteCards>system>*" "{DSK}/usr/local/lde/lispcore/notecards/system/*" "{DSK}/python/medley-trickles/notecards/system-" "SA" "20:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{Pika:MV:ENVOS}<NoteCards>library>*" "{DSK}/usr/local/lde/lispcore/notecards/library/*" "{DSK}/python/medley-trickles/notecards/library-" "SA" "23:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{Pika:MV:ENVOS}<NoteCards>lispusers>*" "{DSK}/usr/local/lde/lispcore/notecards/lispusers/*" "{DSK}/python/medley-trickles/notecards/lispusers-" "SA" "23:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{Pika:MV:ENVOS}<NoteCards>internal>*" "{DSK}/usr/local/lde/lispcore/notecards/internal/*" "{DSK}/python/medley-trickles/notecards/internal-" "SA" "23:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{Pika:MV:ENVOS}<NoteCards>tools>*" "{DSK}/usr/local/lde/lispcore/notecards/tools/*" "{DSK}/python/medley-trickles/notecards/tools-" "SA" "23:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{Pika:MV:ENVOS}<NoteCards>patches>*" "{DSK}/usr/local/lde/lispcore/notecards/patches/*" "{DSK}/python/medley-trickles/notecards/patches-" "SA" "23:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60))))
(CL:DEFUN START-LISPCORE-TRICKLES ()
(* |;;;| "")
(* |;;;| "Set up all the Lispcore trickles")
(* |;;;| "")
(SETREMINDER NIL NIL '(|Smart-Trickle| "{PELE:MV:ENVOS}<LISPCORE>SOURCES>*" "{dsk}/usr/local/lde/lispcore/sources/*" "{DSK}/python/medley-trickles/lispcore/sources-" "SA" "00:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{PELE:MV:ENVOS}<LISPCORE>LIBRARY>*" "{dsk}/usr/local/lde/lispcore/library/*" "{DSK}/python/medley-trickles/lispcore/library-" "SA" "04:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>*" "{dsk}/usr/local/lde/lispcore/internal/library/*" "{DSK}/python/medley-trickles/lispcore/internal-library-" "SA" "06:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60)))
(SETREMINDER NIL NIL '(|Smart-Trickle| "{PELE:MV:ENVOS}<LISPCORE>INTERNAL>DOC>*" "{DSK}/usr/local/lde/lispcore/internal/doc/*" "{DSK}/python/medley-trickles/lispore/internal-doc-" "SA" "07:00" T '(STATUS DATABASE))
(TIMES 60 (RAND 10 60))))
(CL:DEFUN FILE-SERVER-UPP (SERVER &KEY (MESSAGE NIL MESSAGEP)
(TIMEOUT 30))
(* |;;| "Checks for a certain period of time if server is up. It will try to find a directory specific for the type of server. ")
(CL:BLOCK FILE-SERVER-UP-P
(CL:UNLESS (NULL SERVER)
(LET* ((DIRECTORYNAME (COND
((CL:SEARCH ":" SERVER) (* \; "This is an NS-server")
"DESKTOPS")
((CL:SEARCH "/N" SERVER) (* \; "This is an NFS-server")
"/")
((AND (EQL (MACHINETYPE)
'MAIKO)
(OR (STRING-EQUAL SERVER "DSK")
(STRING-EQUAL SERVER "UNIX"))) (* \; " This should be local disk ")
"/")
(T (* \; "Assume it is an IFS-server ")
"SYSTEM")))
(PROCESS-RESULT (CONS))
(PROCESS-HANDLE (ADD.PROCESS `(COND
((DIRECTORYNAMEP ,DIRECTORYNAME ,SERVER)
(RPLACA ',PROCESS-RESULT T)))
'NAME "file-server-upp")))
(DISMISS 500)
(|forDuration| TIMEOUT |timerUnits| 'SECONDS |until| (CAR PROCESS-RESULT) |do| (DISMISS 500) |finally| (DEL.PROCESS PROCESS-HANDLE))
(CL:IF (CAR PROCESS-RESULT)
T
(CL:WHEN MESSAGEP
(CL:FORMAT T ">>~%>> ~A but server ~A is down ~%>>~%" MESSAGE SERVER)
(MENU (CREATE MENU
TITLE _ (CL:CONCATENATE 'STRING " Server " (STRING SERVER)
" is down ")
ITEMS _ '((WAIT T "Wait until server is up")
(CONDITIONS:CONTINUE NIL "Continue to load the rest"))
CENTERFLG _ T))))))))
(DEFINEQ
(|Smart-Identifier|
(LAMBDA (|Source| |Destination|) (* \; "Edited 22-Oct-90 17:27 by gadener")
(* |;;| "Will return a string composed of <Common-Directories>-<Source-Host>-to-(Destination-Host> if there is a common denominator between the two, otherwise the Common-Directories will consist of the Source-Directory")
(LET* ((|Src-Host| (FILENAMEFIELD |Source| 'HOST))
(|Dst-Host| (FILENAMEFIELD |Destination| 'HOST))
(|Src-Dir| (STRING (U-CASE (FILENAMEFIELD |Source| 'DIRECTORY))))
(|Dst-Dir| (STRING (U-CASE (FILENAMEFIELD |Destination| 'DIRECTORY))))
(|Common-point| (CL:MISMATCH |Src-Dir| |Dst-Dir| :TEST 'STRING-EQUAL :FROM-END T)))
(CONCAT (IF (OR (NULL |Common-point|)
(EQL (CL:LENGTH |Src-Dir|)
|Common-point|))
THEN
(* |;;| "Could not find a common denominator, just return the Src-Dir")
|Src-Dir|
ELSE
(* |;;|
 "Just Return the common part, Should be the common directory part.")
(CL:SUBSEQ |Src-Drir| |Common-point|))
"-" |Src-Host| " to " |Dst-Host|))))
(|Smart-Trickle|
(LAMBDA (|Source| |Destination| |RootLogfileName| |MailAddress| |ScheduleAnotherOne| |DontReplaceOldVersions| |DontCopyExtensions| |Retries|) (* \; "Edited 27-Nov-90 10:13 by automgr")
(* |;;;| "The Smart-Trickle will first check to see that the file-server of both the Source and Destination are up and running before trying to copy files between them . If either is down, it will retry every 15 minutes up to four times before giving up. If it fails to connect and ScheduleAnotherOne has a value other than () , then it will reschedule for that time, 24 hrs later. If a server is playing hard to catch, FILE-SERVER-UP-P will try harder (wait longer) for each time around. .")
(LET ((RETRY-TIMES 4) (* \; "How many retries.")
(RETRY-PERIOD 15) (* \; "How many minutes between retries")
(TIMEOUT-PERIOD 60) (* \; "Give up on fileserver after multiples of this period (seconds)")
(|Identifier| (|Smart-Identifier| |Source| |Destination|))
|DateString| |LogfileName|)
(IF (NOT (AND (OR |Retries| (SETQ |Retries| RETRY-TIMES)) (* \; "This is the first time around")
(FILE-SERVER-UPP (STRING (FILENAMEFIELD |Source| 'HOST))
:TIMEOUT
(CL:* (+ (- RETRY-TIMES |Retries|)
1)
TIMEOUT-PERIOD))
(FILE-SERVER-UPP (STRING (FILENAMEFIELD |Destination| 'HOST))
:TIMEOUT
(CL:* (+ (- RETRY-TIMES |Retries|)
1)
TIMEOUT-PERIOD))))
THEN
(* |;;| "At least one of the servers is not up, reschedule a new Smart-trickle to try again in 15 minutes , more correctly , the value of RETRY-PERIOD")
(IF (> |Retries| 0)
THEN
(* |;;| "Just Retry")
(SETREMINDER (MKATOM (CONCAT "Retry-" |Identifier| "-" (GENSYM)))
NIL
`(|Smart-Trickle| ,|Source| ,|Destination| ,|RootLogfileName| ,|MailAddress| ,|ScheduleAnotherOne| ,|DontReplaceOldVersions| ',|DontCopyExtensions| ,(- |Retries| 1))
(GDATE (PLUS (IDATE)
(TIMES 60 RETRY-PERIOD))))
ELSE
(* |;;| "Could not connect to either, or both of the servers after retrying several times.")
(PRINTOUT PROMPTWINDOW "Trickle: Tried to connect to " (FILENAMEFIELD |Source| 'HOST)
" and "
(FILENAMEFIELD |Destination| 'HOST)
" , but one or both, are down!" T (IF |ScheduleAnotherOne|
THEN "Rescheduling another TRICKLE for tomorrow!"))
(* |;;| "Will reschedule another one for tomorrow")
(IF |ScheduleAnotherOne|
THEN (SETREMINDER (MKATOM (CONCAT |Identifier| "-" (GENSYM)))
NIL
`(|Smart-Trickle| ,|Source| ,|Destination| ,|RootLogfileName| ,|MailAddress| ,|ScheduleAnotherOne| ,|DontReplaceOldVersions| ',|DontCopyExtensions|)
(CONCAT (SUBSTRING (GDATE (PLUS (IDATE)
(TIMES 60 60 24)))
1 10)
(IF (EQ |ScheduleAnotherOne| T)
THEN (CONCAT (RAND 1 5)
":"
(RAND 0 59))
ELSE |ScheduleAnotherOne|))))
(* |;;| "Send a message about this")
(IF (AND (\\CH.FIND.ORG.SERVER 'ENVOS T)
(GETD 'LAFITEMODE)
(GETD 'LAFITE.SENDMESSAGE)
(OR (EQL (LAFITEMODE)
'NS)
(MEMBER (LAFITEMODE)
'NS)))
THEN (LAFITE.SENDMESSAGE (CONCAT "To: " "AR-MANAGERS:MV:ENVOS" "
Subject: Trickle had trouble accessing servers." "
Format: Text
Trickle tried to access:
" (FILENAMEFIELD |Source| 'HOST)
" and "
(FILENAMEFIELD |Destination| 'HOST)
"
several times, but gave up at "
(DATE)
" ; one of the servers, or both, were down!" "
Source : " |Source| "
Destination : " |Destination| (IF |ScheduleAnotherOne|
THEN "
Rescheduling another TRICKLE for tomorrow!")
"
<-- Grettings from your friendly Trickler -->" "
"))))
ELSE
(* |;;| " OK, servers were up, run the Trickler.")
(SETQ |DateString| (DATE (DATEFORMAT SPACES NUMBER.OF.MONTH NO.TIME)))
(SETQ |LogfileName| (PACK* (OR |RootLogfileName| '|{UNIX}<tmp>Trickle-log-|)
(SUBSTRING |DateString| 7 8)
(SUBSTRING |DateString| 4 5)
(SUBSTRING |DateString| 1 2)
'.COPYLOG))
(IF (EQ '\ (NTHCHAR |LogfileName| -10))
THEN (SETQ |LogfileName| (MKATOM (RPLSTRING |LogfileName| -10 "0"))))
(* |;;| "ensure that the logfile has one line per file operated on")
(RESETVAR FILELINELENGTH 1000 (COPYFILES |Source| |Destination| (APPEND (LIST '>A (LIST 'OUTPUT |LogfileName|))
(|if| (NULL |DontReplaceOldVersions|)
|then| (LIST 'REPLACE))
(|if| |DontCopyExtensions|
|then| `((DONTCOPY ,@|DontCopyExtensions|))))))
(|TrickleProcessLogfile| |LogfileName| |MailAddress| |Identifier|)
(* |;;| "Will reschedule another trickle for tomorrow")
(IF |ScheduleAnotherOne|
THEN (SETREMINDER (MKATOM (CONCAT |Identifier| "-" (GENSYM)))
NIL
`(|Smart-Trickle| ,|Source| ,|Destination| ,|RootLogfileName| ,|MailAddress| ,|ScheduleAnotherOne| ,|DontReplaceOldVersions| ',|DontCopyExtensions|)
(CONCAT (SUBSTRING (GDATE (PLUS (IDATE)
(TIMES 60 60 24)))
1 10)
(IF (EQ |ScheduleAnotherOne| T)
THEN (CONCAT (RAND 1 5)
":"
(RAND 0 59))
ELSE |ScheduleAnotherOne|))))))))
(|TrickleProcessLogfile|
(LAMBDA (|LogfileName| |MailAddress| |Identifier|) (* \; "Edited 22-Oct-90 18:20 by gadener")
(PROG ((|LogfileStream| (OPENTEXTSTREAM |LogfileName|))
|EndsOfLines|
(|NewLine| (CHARACTER (CHARCODE EOL)))
|EndOfLine| |Deletions| |FailedP|)
(IF (ZEROP (GETEOFPTR |LogfileStream|))
THEN
(* |;;| "Probably an error, people usually don't Trickle empty directories")
(IF |MailAddress|
THEN (TEDIT.INSERT |LogfileStream|
(PACK* "Subject: (Error?) Trickle: " |Identifier| |NewLine|
"To: " |MailAddress| |NewLine| |NewLine|)
1)
(LAFITE.SENDMESSAGE |LogfileStream|)
(CLOSEF |LogfileStream|)
(RETURN)))
(TEDIT.SETSEL |LogfileStream| 1 1 'LEFT)
(SETQ |EndsOfLines| (CONS 0 (WHILE (SETQ |EndOfLine| (TEDIT.FIND |LogfileStream|
|NewLine|))
COLLECT (TEDIT.SETSEL |LogfileStream| |EndOfLine| 1
'RIGHT)
|EndOfLine|)))
(* |;;| "Find lines with skipped and collect for deletion, TEDIT.FIND is very poor on long files, see AR# 4220")
(FOR |EndOfPreviousLine| |on| |EndsOfLines| BIND |StartOfLine| |EndOfLine|
EACHTIME (SETQ |StartOfLine| (AND |EndOfPreviousLine| (ADD1 (CAR |EndOfPreviousLine|
))))
(SETQ |EndOfLine| (CADR |EndOfPreviousLine|))
WHEN (AND |EndOfLine|
(* |;;| " This little sequence will always return T. It is used to check if copying of a file failed. It is put here to avoid having to go through the LogFile several times. Once an error was found, don't bother looking at the file any more.")
(OR (NOT (NULL |FailedP|))
(IF (STRPOS "failed" (TEDIT.SEL.AS.STRING
|LogfileStream|
(TEDIT.SETSEL |LogfileStream| |StartOfLine|
(ADD1 (IDIFFERENCE |EndOfLine|
|StartOfLine|)))))
THEN (SETQ |FailedP| T))
T)
(STRPOS "skipped" (TEDIT.SEL.AS.STRING |LogfileStream|
(TEDIT.SETSEL |LogfileStream| |StartOfLine|
(ADD1 (IDIFFERENCE |EndOfLine|
|StartOfLine|))))))
DO
(* |;;| " if this deletion is an extension of the previous one, extend it, otherwise add it to the collection. This collapsing makes the actual deletion more efficient, since we expect to keep few of the lines.")
(IF (AND |Deletions| (EQUAL (PLUS (CAAR |Deletions|)
(CDAR |Deletions|))
|StartOfLine|))
THEN (RPLACD (CAR |Deletions|)
(PLUS (CDAR |Deletions|)
(DIFFERENCE |EndOfLine| (CAR |EndOfPreviousLine|))))
ELSE (|push| |Deletions| (CONS |StartOfLine| (DIFFERENCE |EndOfLine|
(CAR
|EndOfPreviousLine|
))))))
(* |;;| "Collected deletions")
(FOR |Deletion| |in| |Deletions| DO (TEDIT.DELETE |LogfileStream| (CAR
|Deletion|
)
(CDR |Deletion|)))
(* |;;|
 "KLUDGE!. TEDIT.PUT bombs after putting the file if the stream is not associated with a window.")
(NLSETQ (TEDIT.PUT |LogfileStream| |LogfileName| T T))
(* |;;| "Construct a mail message and send it")
(IF |MailAddress|
THEN (TEDIT.INSERT |LogfileStream|
(CONCAT "Subject: " (IF (ZEROP (GETEOFPTR |LogfileStream|))
THEN "(Empty) "
ELSE "")
(IF (NOT (NULL |FailedP|))
THEN "(Failed) "
ELSE "")
"Trickle: " |Identifier| |NewLine| "To: " |MailAddress|
|NewLine| |NewLine|
(IF (NOT (NULL |FailedP|))
THEN (CONCAT
"***********************************************************"
|NewLine|
"WARNING! Some of the files where not copied. Please check this message,"
|NewLine| "or the log: " |LogfileName|
|NewLine|
"***********************************************************"
|NewLine| |NewLine|)
ELSE ""))
1)
(LAFITE.SENDMESSAGE |LogfileStream|))
(CLOSEF |LogfileStream|))))
)
(DECLARE\: DONTEVAL@LOAD DOCOPY
(FILESLOAD (SYSLOAD)
PROMPTREMINDERS COPYFILES)
(RPAQ? *FUJI-TRICKLE-MAIL-ADDRESS* "AR-MANAGERS:MV:envos, Shunko Inoue:KSPA:Fuji Xerox")
(START-EMULATOR-TRICKLES)
(START-LISPCORE-TRICKLES)
(START-NOTECARDS-TRICKLES)
)
(PUTPROPS ARADMIN COPYRIGHT ("Venue" 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (7786 10686 (PERIODIC-AR-CLEANUP 7796 . 8657) (DO-PERIODIC-AR-CLEANUP 8659 . 10684)) (10752 14133 (PERIODIC-AR-REVIEW 10762 . 11601) (DO-WEEKLY-AR-REVIEW 11603 . 14131)) (14134 14233 (MY-FLOOR 14144 . 14231)) (23289 42338 (|Smart-Identifier| 23299 . 24650) (|Smart-Trickle| 24652 . 35808) (|TrickleProcessLogfile| 35810 . 42336)))))
STOP

1
internal/envos/AREDIT.STATUS Normal file
View File

@@ -0,0 +1 @@
"SYBALSKY.ENVOS" "25-Jun-90 17:42:20"

365
internal/envos/CLMAIL Normal file
View File

@@ -0,0 +1,365 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "14-Jun-90 20:54:42" {DSK}<usr>local>lde>lispcore>internal>library>CLMAIL.;2 17296
changes to%: (VARS CLMAILCOMS)
(FNS CLMAILSHOW CLMAILDISPLAY CLMAILDISPLAYMSG CLMAILSEARCH CLMAILMSGHASH
CLMAILMERGE CLMAILREDOMENU CLMAILHEADSTRING CLMAILFIRST CLMAILLAST CLMAILFWD
CLMAILBKWD CLMAILQUIT MAKECMLHEADHASH MAKECMLMAILHASH UPDATEHASHFILES
CMLMAIL1 CMLMAIL2 CMLMAIL3 CMLMAIL4 CMLMAIL5 CMLMAIL6 CMLMAIL7 CMLMAIL8
CMLMAIL9 CMLMAIL0)
previous date%: "23-Jan-87 16:37:36" {DSK}<usr>local>lde>lispcore>internal>library>CLMAIL.;1)
(* ; "
Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CLMAILCOMS)
(RPAQQ CLMAILCOMS
((FNS CLMAILSHOW CLMAILDISPLAY CLMAILDISPLAYMSG CLMAILSEARCH CLMAILMSGHASH CLMAILMERGE
CLMAILREDOMENU CLMAILHEADSTRING CLMAILFIRST CLMAILLAST CLMAILFWD CLMAILBKWD CLMAILQUIT
MAKECMLHEADHASH MAKECMLMAILHASH UPDATEHASHFILES CMLMAIL1 CMLMAIL2 CMLMAIL3 CMLMAIL4
CMLMAIL5 CMLMAIL6 CMLMAIL7 CMLMAIL8 CMLMAIL9 CMLMAIL0)
(VARS CLM.MENUFORMAT (* "Format list for Free Menu")
CLM.MAILHASHNAME CLM.HEADHASHNAME (* "Names of hashfiles")
CLM.MAILDATANAME CLM.HEADDATANAME (* "Names of unhashed data files")
CLM.VAXCDIR CLM.MSGDIR (* "Names of magic directories"))
(GLOBALVARS CLM.HEADITEMS (*
"A pointer to the first message menu item in CLM.MENUFORMAT for easy referencing"
)
CLM.ABOVEITEM CLM.BELOWITEM CLM.WORD (* "Points at Above:, Below:, and THEWORD fields"
)
CLM.MSGHASH CLM.HEADHASH (* "Streams for message and head line hash files")
CLM.MENUWINDOW
(* "The menu window")
CLM.HEADARRAY CLM.HEAD# (* "Array of head lines for menu and an index into it"))))
(DEFINEQ
(CLMAILSHOW
[LAMBDA NIL (* "Pavel" "29-May-86 15:52")
(* * "First, open the the hash files")
(SETQ CLM.MSGHASH (OPENHASHFILE CLM.MAILHASHNAME 'INPUT))
(SETQ CLM.HEADHASH (OPENHASHFILE CLM.HEADHASHNAME 'INPUT))
(* * "Then create the menu window")
(SETQ CLM.MENUWINDOW (FREEMENU CLM.MENUFORMAT))
(* *
 "Set various pointers into the FM.ITEMS list so we can find the first message menu item easily")
[LET [(WP (WINDOWPROP CLM.MENUWINDOW 'FM.ITEMS]
[SETQ CLM.WORD (for X in WP thereis (EQ 'THEWORD (FM.ITEMPROP X 'ID]
[SETQ CLM.HEADITEMS (for X on WP thereis (EQ 'LINE1 (FM.ITEMPROP (CAR X)
'ID]
[SETQ CLM.ABOVEITEM (for X in WP thereis (EQ 'ABOVEFIELD (FM.ITEMPROP
X
'ID]
(SETQ CLM.BELOWITEM (for X in WP thereis (EQ 'BELOWFIELD (FM.ITEMPROP
X
'ID]
(* * "Finally let user move the menu window (which will open it as a nice side effect)")
(MOVEW CLM.MENUWINDOW (GETBOXPOSITION (WINDOWPROP CLM.MENUWINDOW 'WIDTH)
(WINDOWPROP CLM.MENUWINDOW 'HEIGHT)
100 100 NIL "Specify the position of the menu window"))
(OPENW CLM.MENUWINDOW])
(CLMAILDISPLAY
[LAMBDA (SLOT#) (* jrb%: "29-Oct-86 12:39")
(LET ((MSG# (+ SLOT# CLM.HEAD#)))
(CL:UNLESS (> MSG# (ARRAYSIZE CLM.HEADARRAY))
(CLMAILDISPLAYMSG (CAR (ELT CLM.HEADARRAY MSG#))))])
(CLMAILDISPLAYMSG
[LAMBDA (MSG) (* jrb%: "29-Oct-86 12:39")
(if (NUMBERP MSG)
then (TEDIT (MKATOM (CONCAT CLM.MSGDIR MSG)))
else (ERROR "This isn't a CL message number" MSG])
(CLMAILSEARCH
[LAMBDA NIL (* jrb%: "22-Aug-86 14:24")
(LET [(MSGS (CLMAILMERGE (FM.ITEMPROP CLM.WORD 'LABEL]
(if MSGS
then (SETQ CLM.HEADARRAY (ARRAY (LENGTH MSGS)
'POINTER))
(for I from 1 to (ARRAYSIZE CLM.HEADARRAY)
do (SETA CLM.HEADARRAY I (pop MSGS)))
(SETQ CLM.HEAD# 1)
(CLMAILLAST)
else (FM.CHANGELABEL CLM.WORD "Sorry, that word isn't indexed" CLM.MENUWINDOW])
(CLMAILMSGHASH
[LAMBDA (WORD) (* jrb%: "29-Oct-86 12:38")
(if (CL:SYMBOLP WORD)
then (GETHASHFILE WORD CLM.MSGHASH)
else (CL:ERROR "~S is not a word" WORD])
(CLMAILMERGE
[LAMBDA (STRING) (* ; "Edited 23-Jan-87 16:37 by jrb:")
(LET ((STRINGSTREAM (CL:MAKE-STRING-INPUT-STREAM STRING))
TERM TERMLIST (RESULT 'FIRSTTIME))
(while (NOT (EOFP STRINGSTREAM))
do (CL:TYPECASE (SETQ TERM (READ STRINGSTREAM))
(CL:SYMBOL (SETQ TERMLIST (CLMAILMSGHASH TERM)))
(LIST
(SETQ TERMLIST NIL)
(for TR in TERM do (SETQ TERMLIST (UNION (CLMAILMSGHASH
TR)
TERMLIST))))
(T (CL:ERROR "~S is not a word or list of words" TERM)))
(SETQ RESULT (if (EQ RESULT 'FIRSTTIME)
then TERMLIST
else (INTERSECTION TERMLIST RESULT)))
(if (NULL RESULT)
then (RETURN NIL)))
RESULT])
(CLMAILREDOMENU
[LAMBDA NIL (* jrb%: "17-May-86 00:21")
(FM.CHANGELABEL CLM.ABOVEITEM (SUB1 CLM.HEAD#)
CLM.MENUWINDOW)
(FM.CHANGELABEL CLM.BELOWITEM (MAX 0 (IDIFFERENCE (ARRAYSIZE CLM.HEADARRAY)
(IPLUS CLM.HEAD# 9)))
CLM.MENUWINDOW)
(for ITM in CLM.HEADITEMS bind (APTR _ CLM.HEAD#) do (FM.CHANGELABEL ITM
(CLMAILHEADSTRING
APTR)
CLM.MENUWINDOW)
(SETQ APTR (ADD1 APTR])
(CLMAILHEADSTRING
[LAMBDA (HEAD#) (* jrb%: "31-Mar-86 21:19")
(* * If the index is outside the array, return a null string to blank out that
 slot in the menu)
(* * If the array element is a number, it hasn't been fetched from the hashfile
 yet; do so)
(* * Otherwise just return it)
(COND
((GREATERP HEAD# (ARRAYSIZE CLM.HEADARRAY))
"")
((NUMBERP (ELT CLM.HEADARRAY HEAD#))
(SETA CLM.HEADARRAY HEAD# (CONS (ELT CLM.HEADARRAY HEAD#)
(GETHASHFILE (ELT CLM.HEADARRAY HEAD#)
CLM.HEADHASH)))
(CDR (ELT CLM.HEADARRAY HEAD#)))
(T (CDR (ELT CLM.HEADARRAY HEAD#])
(CLMAILFIRST
[LAMBDA NIL (* jrb%: "31-Mar-86 19:50")
(SETQ CLM.HEAD# 1)
(CLMAILREDOMENU])
(CLMAILLAST
[LAMBDA NIL (* jrb%: "31-Mar-86 21:58")
(SETQ CLM.HEAD# (MAX 1 (IDIFFERENCE (ARRAYSIZE CLM.HEADARRAY)
9)))
(CLMAILREDOMENU])
(CLMAILFWD
[LAMBDA NIL (* jrb%: "31-Mar-86 22:05")
[SETQ CLM.HEAD# (MAX 1 (MIN (IPLUS CLM.HEAD# 10)
(IDIFFERENCE (ARRAYSIZE CLM.HEADARRAY)
9]
(CLMAILREDOMENU])
(CLMAILBKWD
[LAMBDA NIL (* jrb%: "31-Mar-86 22:05")
(SETQ CLM.HEAD# (MAX 1 (IDIFFERENCE CLM.HEAD# 10)))
(CLMAILREDOMENU])
(CLMAILQUIT
[LAMBDA NIL (* jrb%: "31-Mar-86 19:52")
(CLOSEHASHFILE CLM.MSGHASH)
(CLOSEHASHFILE CLM.HEADHASH)
(CLOSEW CLM.MENUWINDOW])
(MAKECMLHEADHASH
[LAMBDA (DATAFILENAME HASHFILENAME) (* jrb%: "26-Mar-86 10:19")
(LET ((HF (CREATEHASHFILE HASHFILENAME 'SMALLEXPR 70 4100))
(DF (OPENSTREAM DATAFILENAME 'INPUT))
KEY SUBJECT SENDER DATE)
(while (NOT (EOFP DF)) do (SETQ KEY (READ DF))
(SETQ SUBJECT (READ DF))
(SETQ SENDER (READ DF))
(SETQ DATE (READ DF))
(PUTHASHFILE KEY (CONCAT SUBJECT " " SENDER " " DATE)
HF) finally (CLOSEHASHFILE HF)
(CLOSEF DF])
(MAKECMLMAILHASH
[LAMBDA (DATAFILENAME HASHFILENAME) (* jrb%: "29-Oct-86 12:43")
(LET ((HF (CREATEHASHFILE HASHFILENAME 'EXPR 80 23000))
(DF (OPENSTREAM DATAFILENAME 'INPUT))
KEY VLIST NEXTITEM)
(SETQ KEY (READ DF))
(CL:UNWIND-PROTECT
(while (NOT (EOFP DF)) do (if (NUMBERP (SETQ NEXTITEM (READ DF)))
then (push VLIST NEXTITEM)
else (PUTHASHFILE KEY (CL:NREVERSE VLIST)
HF)
(SETQ KEY NEXTITEM)
(SETQ VLIST NIL))
finally (PUTHASHFILE KEY (CL:NREVERSE VLIST)
HF))
(CLOSEHASHFILE HF)
(CLOSEF DF))])
(UPDATEHASHFILES
[LAMBDA NIL (* jrb%: "28-May-86 13:32")
(* * First open all the files)
(LET [(MDF (OPENSTREAM CLM.MAILDATANAME 'INPUT))
(HDF (OPENSTREAM CLM.HEADDATANAME 'INPUT))
(MHF (OPENHASHFILE CLM.MAILHASHNAME 'BOTH))
(HHF (OPENHASHFILE CLM.HEADHASHNAME 'BOTH]
(* * Then hash out all the new header lines)
(while (READP HDF) bind KEY SUBJECT VAXCFILE do (SETQ KEY (READ HDF))
(SETQ SUBJECT (READ HDF))
(PUTHASHFILE KEY SUBJECT HHF)
(COPYFILE (SETQ VAXCFILE
(CONCAT CLM.VAXCDIR
KEY))
(CONCAT CLM.MSGDIR KEY))
(DELFILE VAXCFILE)
(PRINTOUT T KEY %,)
finally (CLOSEHASHFILE HHF)
(CLOSEF HDF)
(TERPRI))
(* * And then update the message hash file)
(while (READP MDF) bind (KEY _ (READ MDF))
NEXTITEM VLIST
do (if (NUMBERP (SETQ NEXTITEM (READ MDF)))
then (push VLIST NEXTITEM)
else (PUTHASHFILE KEY (NCONC (GETHASHFILE KEY MHF)
(DREVERSE VLIST))
MHF)
(PRINTOUT T KEY %,)
(SETQ KEY NEXTITEM)
(SETQ VLIST NIL)) finally (PUTHASHFILE KEY (NCONC (GETHASHFILE KEY MHF
)
(DREVERSE VLIST))
MHF)
(CLOSEF MDF)
(CLOSEHASHFILE MHF)
(PRINTOUT T T "DONE!" T])
(CMLMAIL1
[LAMBDA NIL (* jrb%: "31-Mar-86 21:47")
(CLMAILDISPLAY 1])
(CMLMAIL2
[LAMBDA NIL (* jrb%: "31-Mar-86 21:47")
(CLMAILDISPLAY 2])
(CMLMAIL3
[LAMBDA NIL (* jrb%: "31-Mar-86 21:50")
(CLMAILDISPLAY 3])
(CMLMAIL4
[LAMBDA NIL (* jrb%: "31-Mar-86 21:50")
(CLMAILDISPLAY 4])
(CMLMAIL5
[LAMBDA NIL (* jrb%: "31-Mar-86 21:50")
(CLMAILDISPLAY 5])
(CMLMAIL6
[LAMBDA NIL (* jrb%: "31-Mar-86 21:50")
(CLMAILDISPLAY 6])
(CMLMAIL7
[LAMBDA NIL (* jrb%: "31-Mar-86 21:50")
(CLMAILDISPLAY 7])
(CMLMAIL8
[LAMBDA NIL (* jrb%: "31-Mar-86 21:52")
(CLMAILDISPLAY 8])
(CMLMAIL9
[LAMBDA NIL (* jrb%: "31-Mar-86 21:52")
(CLMAILDISPLAY 9])
(CMLMAIL0
[LAMBDA NIL (* jrb%: " 1-Apr-86 09:35")
(CLMAILDISPLAY 0])
)
(RPAQQ CLM.MENUFORMAT
((PROPS FORMAT ROW)
((TYPE DISPLAY LABEL "Common Lisp Mailing List Index" FONT (MODERN 10 BOLD)
HJUSTIFY CENTER))
((TYPE EDITSTART LABEL "Word (implicit AND):" LINKS (EDIT THEWORD)
FONT
(MODERN 10 BOLD))
(TYPE EDIT ID THEWORD LABEL ""))
((TYPE DISPLAY LABEL "Above:" FONT (MODERN 10 BOLD))
(TYPE DISPLAY ID ABOVEFIELD LABEL " ")
(TYPE DISPLAY LABEL "Below:" FONT (MODERN 10 BOLD))
(TYPE DISPLAY ID BELOWFIELD LABEL " "))
((TYPE MOMENTARY LABEL "Search!" FONT (MODERN 10 BOLD)
SELECTEDFN CLMAILSEARCH)
(TYPE MOMENTARY LABEL "First!" FONT (MODERN 10 BOLD)
SELECTEDFN CLMAILFIRST)
(TYPE MOMENTARY LABEL "Last!" FONT (MODERN 10 BOLD)
SELECTEDFN CLMAILLAST)
(TYPE MOMENTARY LABEL "Forwards!" FONT (MODERN 10 BOLD)
SELECTEDFN CLMAILFWD)
(TYPE MOMENTARY LABEL "Backwards!" FONT (MODERN 10 BOLD)
SELECTEDFN CLMAILBKWD)
(TYPE MOMENTARY LABEL "Quit!" FONT (MODERN 10 BOLD)
SELECTEDFN CLMAILQUIT))
((TYPE MOMENTARY LABEL
" " ID
LINE1 SELECTEDFN CMLMAIL0))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL1))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL2))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL3))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL4))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL5))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL6))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL7))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL8))
((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL9))))
(RPAQQ CLM.MAILHASHNAME {ERIS}<COMMONLISP>CLMAIL>MSGHASH)
(RPAQQ CLM.HEADHASHNAME {ERIS}<COMMONLISP>CLMAIL>HEADHASH)
(RPAQQ CLM.MAILDATANAME {VAXC}/user/xais/bane/clmail/newwords)
(RPAQQ CLM.HEADDATANAME {VAXC}/user/xais/bane/clmail/newheads)
(RPAQQ CLM.VAXCDIR {VAXC}/user/xais/bane/clmail/)
(RPAQQ CLM.MSGDIR {ERIS}<COMMONLISP>CLMAIL>)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CLM.HEADITEMS CLM.ABOVEITEM CLM.BELOWITEM CLM.WORD CLM.MSGHASH CLM.HEADHASH
CLM.MENUWINDOW CLM.HEADARRAY CLM.HEAD#)
)
(PUTPROPS CLMAIL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2142 14793 (CLMAILSHOW 2152 . 3870) (CLMAILDISPLAY 3872 . 4146) (CLMAILDISPLAYMSG 4148
. 4407) (CLMAILSEARCH 4409 . 5038) (CLMAILMSGHASH 5040 . 5280) (CLMAILMERGE 5282 . 6419) (
CLMAILREDOMENU 6421 . 7262) (CLMAILHEADSTRING 7264 . 8073) (CLMAILFIRST 8075 . 8233) (CLMAILLAST 8235
. 8474) (CLMAILFWD 8476 . 8775) (CLMAILBKWD 8777 . 8967) (CLMAILQUIT 8969 . 9171) (MAKECMLHEADHASH
9173 . 9946) (MAKECMLMAILHASH 9948 . 10911) (UPDATEHASHFILES 10913 . 13441) (CMLMAIL1 13443 . 13576) (
CMLMAIL2 13578 . 13711) (CMLMAIL3 13713 . 13846) (CMLMAIL4 13848 . 13981) (CMLMAIL5 13983 . 14116) (
CMLMAIL6 14118 . 14251) (CMLMAIL7 14253 . 14386) (CMLMAIL8 14388 . 14521) (CMLMAIL9 14523 . 14656) (
CMLMAIL0 14658 . 14791)))))
STOP

209
internal/envos/CMLHELP Normal file
View File

@@ -0,0 +1,209 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
(IL:FILECREATED "15-Jun-90 11:50:26" IL:|{DSK}<usr>local>lde>lispcore>internal>library>CMLHELP.;2| 12901
IL:|changes| IL:|to:| (IL:VARS IL:CMLHELPCOMS)
IL:|previous| IL:|date:| "20-Oct-86 11:42:05"
IL:|{DSK}<usr>local>lde>lispcore>internal>library>CMLHELP.;1|)
; Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:CMLHELPCOMS)
(IL:RPAQQ IL:CMLHELPCOMS ((IL:INITVARS (IL:CMLPATH '(IL:|{ERIS}<CommonLoops>PCL>|
IL:{ERIS}<COMMONLISP>CODE>
IL:{ERIS}<COMMONLISP>CLC>))
(IL:CMLWINDOW))
(IL:FNS IL:ADDHASHFILE IL:CMLSHOW IL:MAKECMLINDEX IL:CMLWINDOW
IL:CMLHASHFILE)
(IL:INITVARS (IL:CMLDEFS)
(IL:CMLMANHASH))))
(IL:RPAQ? IL:CMLPATH '(IL:|{ERIS}<CommonLoops>PCL>| IL:{ERIS}<COMMONLISP>CODE>
IL:{ERIS}<COMMONLISP>CLC>))
(IL:RPAQ? IL:CMLWINDOW )
(IL:DEFINEQ
(il:addhashfile
(il:lambda (il:name il:val il:harray)
(il:puthashfile il:name (cons il:val (il:gethashfile il:name il:harray))
il:harray)))
(il:cmlshow
(il:lambda (il:name il:to il:manp) (il:* il:|lmm| " 9-May-86 17:13")
(let
((il:out (or il:to (il:|if| il:manp il:|then| (il:setq il:to t)
il:|else|
(il:openstream 'il:{scratch} 'il:both 'il:new))))
il:window
(il:found 0)
il:str)
(il:|for|
il:hf il:|inside| (il:cmlhashfile il:manp)
il:|do|
(let
((il:lst (il:gethashfile (il:u-case il:name)
(car il:hf))))
(il:|for|
il:|occurence| il:|inside| (remove-duplicates il:lst :test 'il:equal)
il:|do|
(il:resetlst (il:resetsave nil (list 'il:closef? (il:setq il:str
(il:|for| il:file il:|inside| (cdr il:hf)
il:|bind| il:fn il:|when|
(il:setq il:fn
(il:infilep (il:packfilename
'il:body
(car il:|occurence|)
'il:body il:file)))
il:|do|
(return (il:openstream il:fn
'il:input
'il:old))))))
(il:|if| il:str il:|then| (il:* il:|we| il:|found| il:|the|
 il:|file| il:|on| il:|this| il:|dir|)
(let ((il:end (or (il:filepos (il:|if| il:manp il:|then|
(il:* il:|end| il:|of| il:|definition|)
"
@ENDDEF" il:|else| (il:* il:|dunno| il:|where| il:|it|
 il:|ends,| il:|just| il:|get| il:|the|
 il:|next| il:|one|)
"
(def")
il:str
(il:plus 4 (cadr il:|occurence|))
nil nil nil (il:uppercasearray))
(il:geteofptr il:str))))
(il:selectq il:out
(il:tedit (il:opentextstream il:str (il:|if| il:window il:|then|
(il:createw nil
"CML definitions")
il:|else|
(il:setq il:window (
 il:cmlwindow
)))
(cadr il:|occurence|)
il:end
(and (not il:manp)
'(il:font (il:terminal 10)
il:paralooks
(il:tabs (48))))))
((il:allfile t)
(il:setq il:window (il:|if| il:window il:|then|
(il:createw nil "CML definitions")
il:|else|
(il:cmlwindow)))
(il:windowprop il:window 'il:title (il:fullname il:str))
(il:tedit.setsel (il:setq il:str
(il:opentextstream
il:str nil nil nil
(and (not il:manp)
'(il:font (il:terminal 10)
il:paralooks
(il:tabs (48))))))
(cadr il:|occurence|)
(il:difference il:end (cadr il:|occurence|)))
(il:opentextstream il:str il:window nil nil
(and (not il:manp)
'(il:font (il:terminal 10)
il:paralooks
(il:tabs (48))))))
(progn (il:printout il:out "(from " (il:fullname il:str)
")" t)
(il:copybytes il:str il:out (cadr il:|occurence|)
il:end)
(il:terpri il:out)))
(il:|add| il:found 1)))))))
(il:|if| (not il:to)
il:|then|
(il:opentextstream il:out (let ((il:w (il:cmlwindow)))
(il:windowprop il:w 'il:title "Common Lisp definition")
il:w)
nil nil '(il:font (il:terminal 10)
il:paralooks
(il:tabs (48))))
(let ((il:pw (il:getpromptwindow (il:cmlwindow))))
(il:clearw il:pw)
(il:selectq il:found
(0 (il:printout il:pw "No occurences of" il:\, il:name "."))
(1 (il:printout il:pw il:found il:\, "occurence of" il:\, il:name "."))
(il:printout il:pw il:found il:\, "occurences of" il:\, il:name "."))))
il:found)))
(il:makecmlindex
(il:lambda (il:pattern il:hf il:manp) (il:* il:|lmm| "28-Apr-86 11:44")
(il:setq il:hf (il:openhashfile (or il:hf "CML.HASH")
'il:new 40 3080))
(il:|bind| il:str il:nf (il:readtable il:_ (il:|if| il:manp il:|then|
(let ((il:rt (il:copyreadtable il:cmlrdtbl)))
(il:setsyntax (il:charcode ",")
'il:sepr il:rt)
(il:setsyntax (il:charcode il:})
'il:sepr il:rt)
(il:setsyntax (il:charcode il:{)
'il:sepr il:rt)
il:rt)
il:|else| il:cmlrdtbl))
il:|for| il:file il:|in| (il:fildir (il:packfilename 'il:body il:pattern 'il:extension
'il:*
'il:version "" 'il:name 'il:*))
il:|do|
(il:resetlst (il:resetsave nil (list 'il:closef? (il:setq il:str (il:openstream
il:file
'il:input
'il:old))))
(il:setq il:nf (il:namefield il:file t))
(il:printout t il:file t)
(il:|while| (il:filepos (il:|if| il:manp il:|then| "
@Def" il:|else| "
(def")
il:str nil nil nil nil (il:uppercasearray))
il:|do|
(il:readc il:str)
(let ((il:pos (il:getfileptr il:str))
(il:deffer (progn (il:bin il:str)
(il:read il:str il:readtable)))
(il:defd (il:read il:str il:readtable)))
(il:printout t ".")
(let ((il:defa (il:|if| (il:listp il:defd)
il:|then|
(il:|if| il:manp il:|then| (cadr il:defd)
il:|else|
(car il:defd))
il:|else| il:defd)))
(il:|if| (symbolp il:defa)
il:|then|
(il:addhashfile il:defa (list il:nf il:pos)
il:hf)))))))))
(il:cmlwindow
(il:lambda nil
(or il:cmlwindow (il:setq il:cmlwindow (il:createw '(0 0 500 300) "CML definitions")))))
(il:cmlhashfile
(il:lambda (il:manp) (il:* il:|lmm| "28-Apr-86 11:59")
(il:|if| il:manp il:|then| (or il:cmlmanhash (il:setq il:cmlmanhash
(list (cons (il:openhashfile '
il:{eris}<commonlisp>manual>cml.hash
'il:input)
'il:{eris}<commonlisp>manual>))))
il:|else|
(or il:cmldefs (il:setq il:cmldefs (il:|for| il:|path| il:|inside| il:cmlpath il:|bind|
il:file il:|when| (il:setq il:file
(il:findfile "CML.HASH" t
(il:mklist il:|path|))
)
il:|collect|
(cons (il:openhashfile il:file 'il:input)
il:|path|)))))))
)
(IL:RPAQ? IL:CMLDEFS )
(IL:RPAQ? IL:CMLMANHASH )
(IL:PUTPROPS IL:CMLHELP IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (1218 12730 (IL:ADDHASHFILE 1231 . 1391) (IL:CMLSHOW 1393 . 8243) (IL:MAKECMLINDEX
8245 . 11324) (IL:CMLWINDOW 11326 . 11453) (IL:CMLHASHFILE 11455 . 12728)))))
IL:STOP

48
internal/envos/COLORFONTHACK Normal file
View File

@@ -0,0 +1,48 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 12:33:48" |{DSK}<usr>local>lde>lispcore>internal>library>COLORFONTHACK.;2| 2214
|changes| |to:| (VARS COLORFONTHACKCOMS)
|previous| |date:| " 6-Dec-88 21:52:32"
|{DSK}<usr>local>lde>lispcore>internal>library>COLORFONTHACK.;1|)
; Copyright (c) 1990 by Venue. All rights reserved.
(PRETTYCOMPRINT COLORFONTHACKCOMS)
(RPAQQ COLORFONTHACKCOMS ((FNS COLORFONTHACK)))
(DEFINEQ
(COLORFONTHACK
(LAMBDA NIL (* \; "Edited 6-Dec-88 21:46 by shih")
(* |;;| "Run through all the color fonts, replacing their bitmaps with appropriate ones.")
(* |;;| "Should be run *after* (COLORDISPLAY 'ON) is called.")
(* |;;| "")
(LET (FONTS FONTDESC CSINFO CSBITMAP NEWBM)
(SETQ FONTS (FONTSAVAILABLE '* '* '* 0 '8DISPLAY))
(FOR FONT IN FONTS DO (SETQ FONTDESC (FONTCREATE FONT))
(SETQ CSINFO (\\GETCHARSETINFO 0 FONTDESC))
(SETQ CSBITMAP (FETCH (CHARSETINFO CHARSETBITMAP)
OF CSINFO))
(IF (NEQ 8 (BITSPERPIXEL CSBITMAP))
THEN (SETQ NEWBM (BITMAPCREATE (BITMAPWIDTH
CSBITMAP)
(BITMAPHEIGHT CSBITMAP)
8))
(* |;;|
 "Bitblt knows how to coerce a 1 bppixel to an 8 bppixel.")
(BITBLT CSBITMAP NIL NIL NEWBM)
(REPLACE (CHARSETINFO CHARSETBITMAP)
OF CSINFO WITH NEWBM))))))
)
(PUTPROPS COLORFONTHACK COPYRIGHT ("Venue" 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (477 2141 (COLORFONTHACK 487 . 2139)))))
STOP

32
internal/envos/COMMON-LISP-PACKAGE Normal file
View File

@@ -0,0 +1,32 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED " 2-Feb-91 14:33:36" |{DSK}<usr>local>lde>lispcore>sources2>COMMON-LISP-PACKAGE.;7| 7002
|changes| |to:| (VARIABLES OLDCLSYMS *COMMON-LISP-PACKAGE*) (VARS COMMON-LISP-PACKAGECOMS) (FUNCTIONS CRUNCH-FILES CREATE-CL-PACKAGE)
|previous| |date:| " 2-Feb-91 13:17:24"
|{DSK}<usr>local>lde>lispcore>sources2>COMMON-LISP-PACKAGE.;5|)
; Copyright (c) 1991 by Venue Corporation. All rights reserved.
(PRETTYCOMPRINT COMMON-LISP-PACKAGECOMS)
(RPAQQ COMMON-LISP-PACKAGECOMS ((VARIABLES *COMMON-LISP-PACKAGE* NEWCLSYMS OLDCLSYMS SPLITCLSYMS) (FUNCTIONS CRUNCH-FILES FLIP-CL CREATE-CL-PACKAGE)))
(DEFGLOBALVAR *COMMON-LISP-PACKAGE* NIL "Place holder for the COMMON-LISP package variable")
(LISP:DEFPARAMETER NEWCLSYMS (QUOTE ("REAL" "BASE-CHARACTER" "EXTENDED-CHARACTER" "READTABLE-CASE" "SIMPLE-STRING" "BASE-STRING" "SIMPLE-BASE-STRING" "BROADCAST-STREAM" "CONCATENATED-STREAM" "ECHO-STREAM" "SYNONYM-STREAM" "STRING-STREAM" "FILE-STREAM" "TWO-WAY-STREAM" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "LOAD-TIME-EVAL" "REALP" "FDEFINITION" "NTH-VALUE" "DESTRUCTURING-BIND" "DEFINE-COMPILER-MACRO" "COMPILER-MACRO-FUNCTION" "COMPILER-MACROEXPAND" "COMPILER-MACROEXPAND-1" "VARIABLE-INFORMATION" "FUNCTION-INFORMATION" "DECLARATION-INFORMATION" "AUGMENT-ENVIRONMENT" "DEFINE-DECLARATION" "PARSE-MACRO" "ENCLOSE" "DECLAIM" "DYNAMIC-EXTENT" "*GENSYM-COUNTER*" "DELETE-PACKAGE" "DEFPACKAGE" "WITH-PACKAGE-ITERATOR" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "COMPLEMENT" "MAP-INTO" "WITH-HASH-TABLE-ITERATOR" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "ROW-MAJOR-AREF" "OPEN-STREAM-P" "BROADCAST-STREAM-STREAMS" "CONCATENATED-STREAM-STREAMS" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "SYNONYM-STREAM-SYMBOL" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "INTERACTIVE-STREAM-P" "STREAM-EXTERNAL-FORMAT" "*READ-EVAL*" "READTABLE-CASE" "*PRINT-READABLY*" "WITH-STANDARD-IO-SYNTAX" "PRINT-UNREADABLE-OBJECT" "WILD-PATHNAME-P" "PATHNAME-MATCH-P" "TRANSLATE-PATHNAME" "LOGICAL-PATHNAME" "TRANSLATE-LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "COMPILE-FILE-PATHNAME" "FILE-STRING-LENGTH" "*LOAD-PRINT*" "*LOAD-PATHNAME*" "*LOAD-TRUENAME*" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "*COMPILE-VERBOSE" "*COMPILE-PRINT*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "LOAD-TIME-VALUE" "FUNCTION-LAMBDA-EXPRESSION" "WITH-COMPILATION-UNIT")))
(LISP:DEFPARAMETER OLDCLSYMS (QUOTE ("COMMON" "COMMONP" "STRING-CHAR" "STRING-CHAR-P" "INT-CHAR" "COMPILER-LET" "CHAR-BIT" "SET-CHAR-BIT" "*MODULES*" "PROVIDE" "REQUIRE" "CHAR-FONT-LIMIT" "CHAR-BITS-LIMIT" "CHAR-BITS" "CHAR-FONT" "MAKE-CHAR" "CHAR-CONTROL-BIT" "CHAR-META-BIT" "CHAR-SUPER-BIT" "CHAR-HYPER-BIT" "*BREAK-ON-WARNINGS*")) "Symbols in LISP and not in COMMON-LISP")
(LISP:DEFPARAMETER SPLITCLSYMS (QUOTE ("LOCALLY" "IN-PACKAGE")))
(LISP:DEFUN CRUNCH-FILES (FL) (LISP:WHEN (AND FL (LISP:SYMBOLP FL)) (LISP:SETQ FL (LIST FL))) (LISP:DOLIST (F FL) (LISP:FORMAT T "Crunching ~a~%" F) (FLIP-CL :LISP) (LOAD F (QUOTE ALLPROP)) (FLIP-CL :NOWHERE) (MAKEFILE F (QUOTE NEW)) (LISP:IF (LISP:PROBE-FILE (CONCAT F ".DFASL")) (LISP:COMPILE-FILE F) (FAKE-COMPILE-FILE F)) (LISP:FORMAT T "Done crunching ~a~%" F)))
(LISP:DEFUN FLIP-CL (WHERE) (LISP:ECASE WHERE (:LISP (LISP:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL) (LISP:RENAME-PACKAGE *LISP-PACKAGE* "LISP" (QUOTE ("CL")) "CL")) (:COMMON-LISP (LISP:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (LISP:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" (QUOTE ("CL")) "CL")) (:NOWHERE (LISP:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (LISP:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL))))
(LISP:DEFUN CREATE-CL-PACKAGE NIL (* |;;| "First, rename the LISP package to get its nicknames out of our way") (LISP:RENAME-PACKAGE (LISP:FIND-PACKAGE "LISP") "LISP" NIL NIL) (* |;;| "Then create the COMMON-LISP package and friends") (LISP:UNLESS (LISP:FIND-PACKAGE "COMMON-LISP") (* |;;| "For the moment, no nicknames for COMMON-LISP; FLIP-CL can be used to fix this later.") (SETQ *COMMON-LISP-PACKAGE* (LISP:MAKE-PACKAGE "COMMON-LISP" :USE NIL)) (* |;;| "We probably want to have COMMON-LISP-USER use XCL; this needs to be discussed") (LISP:MAKE-PACKAGE "COMMON-LISP-USER" :USE (QUOTE ("COMMON-LISP")))) (LET ((WEIRDTAG (CONS NIL NIL)) (OLDPROP (CONS NIL NIL)) (UNSHAREDPROP (CONS NIL NIL)) I) (* |;;| "Flag the atoms in LISP that are not going to be shared into COMMON-LISP") (LISP:DOLIST (I OLDCLSYMS) (PUT (LISP:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG OLDPROP)) (LISP:DOLIST (I SPLITCLSYMS) (PUT (LISP:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG UNSHAREDPROP)) (* |;;| "OK, crunch the external symbols in LISP. We may eventually rehome these symbols into COMMON-LISP") (LISP:DO-EXTERNAL-SYMBOLS (I *LISP-PACKAGE*) (LET ((WEIRD? (GET I WEIRDTAG)) S) (COND ((EQ WEIRD? OLDPROP) (* \; "Just leave it alone") (REMPROP I WEIRDTAG)) ((EQ WEIRD? UNSHAREDPROP) (* \; "Export a new, unshared symbol") (EXPORT (LISP:INTERN (LISP:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*) (REMPROP I WEIRDTAG)) ((NULL WEIRD?) (* \; "Share symbol; if it's already there, shadow it") (LISP:IF (SETQ S (LISP:FIND-SYMBOL (LISP:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*)) (LISP:UNLESS (EQ S I) (LISP:SHADOWING-IMPORT I *COMMON-LISP-PACKAGE*)) (IMPORT I *COMMON-LISP-PACKAGE*)) (EXPORT I *COMMON-LISP-PACKAGE*)) (T (* \; "VERY unlikely...") (ERROR "Garbage on property list during LISP->COMMON-LISP import" (CONS I WEIRD?)))))) (* |;;| "Hose out the new COMMON-LISP symbols") (LISP:DOLIST (I NEWCLSYMS) (EXPORT (LISP:INTERN I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*)) (* |;;| "If these other packages are around, grab their symbols") (LET (P S) (LISP:WHEN (SETQ P (LISP:FIND-PACKAGE "XP")) (LISP:DOLIST (I (QUOTE ("*PRINT-PPRINT-DISPATCH*" "*PPRINT-RIGHT-MARGIN*" "*PPRINT-MISER-WIDTH*" "PPRINT-NEWLINE" "PPRINT-LOGICAL-BLOCK" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-INDENT" "PPRINT-TAB" "PPRINT-FILL" "PPRINT-LINEAR" "PPRINT-TABULAR" "FORMATTER" "COPY-PPRINT-DISPATCH" "PPRINT-DISPATCH" "SET-PPRINT-DISPATCH"))) (SETQ S (LISP:FIND-SYMBOL I P)) (IMPORT S *COMMON-LISP-PACKAGE*) (EXPORT S *COMMON-LISP-PACKAGE*))) (* |;;| "This will have to be changed somewhat as we change the CONDITIONS system to comply with CLtL2") (LISP:WHEN (SETQ P (LISP:FIND-PACKAGE "CONDITIONS")) (LISP:DO-EXTERNAL-SYMBOLS (I P) (IMPORT I *COMMON-LISP-PACKAGE*) (EXPORT I *COMMON-LISP-PACKAGE*))) (FLIP-CL :COMMON-LISP))))
(PUTPROPS COMMON-LISP-PACKAGE COPYRIGHT ("Venue Corporation" 1991))
(DECLARE\: DONTCOPY
(FILEMAP (NIL)))
STOP

1144
internal/envos/DSKTEST Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
internal/envos/DSKTEST.TEDIT Normal file
View File

Binary file not shown.

305
internal/envos/FILEBANGER Normal file
View File

@@ -0,0 +1,305 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Jun-90 21:20:39" {DSK}<usr>local>lde>lispcore>internal>library>FILEBANGER.;2 16050
chnges to%: (VARS FILEBANGERCOMS)
(FNS CHECKFORZEROS)
previous date%: " 1-Oct-87 18:36:57" {DSK}<usr>local>lde>lispcore>internal>library>FILEBANGER.;1
)
(* ; "
Copyright (c) 1983, 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT FILEBANGERCOMS)
(RPAQQ FILEBANGERCOMS
((FNS DOFILEBANGER DOMAKEFILEBANGER DOZEROBANGER FILEBANGER FBCOPYBYTES FBMAKETESTFILE
MAKEBANGERWINDOW MAKEFILEBANGER ZEROBANGER SUSPEND.FILEBANGER WATCHDISKPAGES)
(FNS BINCOM)
(FNS CHECKFORZEROS)
(INITVARS (FBREPEATCOUNT 4)
(FILEBANGERS))
(PROP FILETYPE FILEBANGER)))
(DEFINEQ
(DOFILEBANGER
[LAMBDA (DESTINATION LENGTH NOBREAK) (* ; "Edited 1-Oct-87 18:00 by Daniels")
(push FILEBANGERS (ADD.PROCESS `(FILEBANGER ',LENGTH ',DESTINATION T ',NOBREAK])
(DOMAKEFILEBANGER
[LAMBDA (SOURCE) (* bvm%: "14-AUG-83 13:53")
(push FILEBANGERS (ADD.PROCESS `(MAKEFILEBANGER (QUOTE %, SOURCE])
(DOZEROBANGER
[LAMBDA (TESTFILE1 TESTFILE2 TMPFILENAME) (* bvm%: "14-AUG-83 13:54")
(push FILEBANGERS (ADD.PROCESS `(ZEROBANGER (QUOTE %, TESTFILE1)
(QUOTE %, TESTFILE2)
(QUOTE %, TMPFILENAME])
(FILEBANGER
[LAMBDA (TESTFILE DESTINATION MAKEWINDOW NOBREAK INPARMS OUTPARMS)
(* ; "Edited 1-Oct-87 18:31 by Daniels")
(DECLARE (SPECVARS ERRCNT LOOPCNT))
(RESETLST (PROG ((ERRCNT 0)
(LOOPCNT 0)
(OPTION (AND (NOT NOBREAK)
'BREAK))
MYFILE NEWFILE LASTFILE TMPFILENAME OUTPUTSTREAM)
[COND
[(OR (NULL TESTFILE)
(FIXP TESTFILE))
(SETQ TESTFILE (SETQ MYFILE (FBMAKETESTFILE TESTFILE
(PACKFILENAME 'EXTENSION 'SOURCE
'BODY
(OR DESTINATION 'FILEBANGER]
(T (SETQ TESTFILE (CL:PROBE-FILE (OR TESTFILE (RETURN "No TESTFILE supplied"]
[COND
[MAKEWINDOW (SETQ OUTPUTSTREAM (GETSTREAM (MAKEBANGERWINDOW TESTFILE
"File Banger")
'OUTPUT]
(T (SETQ OUTPUTSTREAM (GETSTREAM T 'OUTPUT]
(COND
((NOT MYFILE)
[SETQ MYFILE (CL:WITH-OPEN-FILE (TESTFILE TESTFILE :DIRECTION :INPUT)
(COPYFILE TESTFILE (PACKFILENAME 'EXTENSION 'FBTESTER
'VERSION NIL 'BODY TESTFILE]
(BINCOM MYFILE TESTFILE OPTION OUTPUTSTREAM)))
[SETQ TMPFILENAME (OR DESTINATION (PACKFILENAME 'EXTENSION 'FBTEMP 'VERSION NIL
'BODY
(OR MYFILE 'FILEBANGER]
LP (PRIN1 (add LOOPCNT 1)
OUTPUTSTREAM)
(RESETLST [RESETSAVE (SETQ NEWFILE (OPENFILE TMPFILENAME 'OUTPUT NIL NIL OUTPARMS
))
'(PROGN (CLOSEF OLDVALUE]
(CL:WITH-OPEN-FILE (MYFILE MYFILE :DIRECTION :INPUT)
(COPYBYTES MYFILE NEWFILE)))
(AND LASTFILE (DELFILE LASTFILE))
[RPTQ FBREPEATCOUNT (PROGN (BLOCK)
(PRIN1 '%. OUTPUTSTREAM)
(COND
((NEQ (BINCOM MYFILE NEWFILE OPTION OUTPUTSTREAM)
T)
(add ERRCNT 1]
(SETQ LASTFILE NEWFILE)
(BLOCK)
(GO LP])
(FBCOPYBYTES
[LAMBDA (INSTREAM ECHOSTREAM START) (* bvm%: "24-JUN-83 19:00")
(SETFILEPTR INSTREAM START)
(RPTQ 40 (\OUTCHAR ECHOSTREAM (\BIN INSTREAM])
(FBMAKETESTFILE
[LAMBDA (LENGTH NAME) (* ; "Edited 1-Oct-87 18:20 by Daniels")
(LET ((PATHNAME))
[CL:WITH-OPEN-FILE (FILE (OR NAME "FILEBANGER.TMP")
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
(SETQ PATHNAME (CL:TRUENAME FILE))
(for I from 1 to (OR LENGTH 1000) do (\OUTCHAR FILE (RAND 32 127]
PATHNAME])
(MAKEBANGERWINDOW
[LAMBDA (FILE TYPE) (* bvm%: "12-AUG-83 13:06")
(PROG (W)
[RESETSAVE (TTYDISPLAYSTREAM (SETQ W (CREATEW NIL (CONCAT TYPE " for " FILE]
(DSPFONT '(GACHA 8) W)
[WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (W P)
(AND [PROCESSP (SETQ P (WINDOWPROP W 'PROCESS]
(PROCESS.EVAL P '(ERROR!]
(WINDOWPROP W 'PAGEFULLFN (FUNCTION NILL))
(RETURN W])
(MAKEFILEBANGER
[LAMBDA (TESTFILE) (* bvm%: "14-AUG-83 13:56")
(DECLARE (SPECVARS ERRCNT LOOPCNT))
(RESETLST (PROG ((LOOPCNT 0)
NEWFILE LASTFILE)
[SETQ TESTFILE (LOADFROM (OR TESTFILE (RETURN "No TESTFILE supplied"]
(MAKEBANGERWINDOW TESTFILE "MAKEFILE Banger")
(SETQ TESTFILE (NAMEFIELD TESTFILE T))
LP (SETQ NEWFILE (MAKEFILE TESTFILE))
(AND (CHECKFORZEROS NEWFILE)
(HELP "Zeros found"))
[COND
(LASTFILE (DELFILE LASTFILE)
(REMPROP LASTFILE 'PAGES]
(SETQ LASTFILE NEWFILE)
(GO LP])
(ZEROBANGER
[LAMBDA (TESTFILE1 TESTFILE2 TMPFILENAME N NOBREAK OUTPUTSTREAM)
(* bvm%: "12-AUG-83 13:07")
(DECLARE (SPECVARS ERRCNT LOOPCNT))
(RESETLST (PROG ((ERRCNT 0)
(LOOPCNT 0)
(OPTION (AND (NOT NOBREAK)
'BREAK))
THISFILE NEWFILE LASTFILE)
[SETQ THISFILE (CLOSEF (SETQ TESTFILE1 (OPENFILE (OR TESTFILE1 (RETURN
"No TESTFILE supplied"
))
'INPUT]
(RESETSAVE NIL (LIST 'CLOSEF? TESTFILE1))
[CLOSEF (SETQ TESTFILE2 (OPENFILE (OR TESTFILE2 (RETURN "No TESTFILE supplied"))
'INPUT]
(RESETSAVE NIL (LIST 'CLOSEF? TESTFILE2))
[CLOSEF (SETQ TMPFILENAME (OPENFILE (OR TMPFILENAME 'ZEROBANGER.TMP)
'OUTPUT]
(RESETSAVE NIL (LIST 'CLOSEF? TMPFILENAME))
(SETQ OUTPUTSTREAM (GETSTREAM (OR OUTPUTSTREAM (MAKEBANGERWINDOW THISFILE
"Zero Banger"))r
'OUTPUT))
LP (COND
((AND N (ILESSP (add N -1)
0))
(RETURN ERRCNT)))
(printout OUTPUTSTREAM (add LOOPCNT 1)
%,)
(OPENFILE TMPFILENAME 'BOTH 'OLD)
(OPENFILE THISFILE 'INPUT)
(COPYBYTES THISFILE TMPFILENAME 0 -1)
(CLOSEF THISFILE)
(SETFILEINFO TMPFILENAME 'LENGTH (GETFILEPTR TMPFILENAME))
(CLOSEF TMPFILENAME) (* (AND LASTFILE (DELFILE LASTFILE)))
(COND
((NEQ (BINCOM THISFILE TMPFILENAME OPTION OUTPUTSTREAM)
T)
(add ERRCNT 1))) (* (SETQ LASTFILE NEWFILE))
(SETQ THISFILE (COND
((EQ THISFILE TESTFILE1)
TESTFILE2)
(T TESTFILE1)))
(GO LP])
(SUSPEND.FILEBANGER
[LAMBDA NIL (* bvm%: "10-AUG-83 17:39")
(for PROC in FILEBANGERS when (AND (PROCESSP PROC)
(NEQ PROC (THIS.PROCESS))) do (SUSPEND.PROCESS PROC))
(CLOSEF (PROG1 PUPTRACEFILE (SETQ PUPTRACEFILE (PUPTRACE PUPTRACEFLG '(832 416 190 336])
(WATCHDISKPAGES
[LAMBDA (THRESHOLD) (* bvm%: "10-AUG-83 17:11")
(OR THRESHOLD (SETQ THRESHOLD 2000))
(while T bind (MARGIN _ THRESHOLD)
LASTFILE do (COND
((ILESSP (DISKFREEPAGES)
(IPLUS THRESHOLD MARGIN))
(COND
(LASTFILE (DELFILE LASTFILE)))
(SETQ LASTFILE (CLOSEF PUPTRACEFILE))
(SETQ PUPTRACEFILE (OPENFILE '{DSK}PUPTRACE.TMP 'OUTPUT
'NEW))
(SETQ MARGIN 0)))
(BLOCK 60000])
)
(DEFINEQ
(BINCOM
[LAMBDA (FILE1 FILE2 OPTION OUTPUTSTREAM) (* ; "Edited 1-Oct-87 18:36 by Daniels")
(RESETLST (PROG ((STRM1 (OPENSTREAM FILE1 'INPUT 'OLD))
(STRM2 (OPENSTREAM FILE2 'INPUT 'OLD))
HERE B1 B2)
(RESETSAVE NIL (LIST 'CLOSEF STRM1))
(RESETSAVE NIL (LIST 'CLOSEF STRM2))
(SETQ OUTPUTSTREAM (GETSTREAM (OR OUTPUTSTREAM T)
'OUTPUT))
(RETURN (COND
((IEQP (GETEOFPTR STRM1)
(GETEOFPTR STRM2))
(for I from 1 to (GETEOFPTR STRM1)
do (IF (ZEROP (MOD I 5120))
THEN (BLOCK))
(COND
((NEQ (SETQ B1 (\BIN STRM1))
(SETQ B2 (\BIN STRM2)))
(COND
((NEQ OPTION 'NOMSG)
(printout OUTPUTSTREAM T (FULLNAME STRM1)
" and "
(FULLNAME STRM2)
" differ at byte " |.P2| (SETQ HERE
(SUB1 (GETFILEPTR
STRM1)))
" (page " |.P2| (fetch (BYTEPTR PAGE)
of HERE)
", byte " |.P2| (fetch (BYTEPTR OFFSET)
of HERE)
"): ")
(\OUTCHAR OUTPUTSTREAM B1)
(printout OUTPUTSTREAM "[" |.P2| B1 "] vs. ")
(\OUTCHAR OUTPUTSTREAM B2)
(printout OUTPUTSTREAM "[" |.P2| B2 "]" T (FULLNAME
STRM1)
" reads:" T)
(FBCOPYBYTES STRM1 OUTPUTSTREAM HERE)
(printout OUTPUTSTREAM T (FULLNAME STRM2)
" reads:" T)
(FBCOPYBYTES STRM2 OUTPUTSTREAM HERE)
(TERPRI T)))
(COND
((EQ OPTION 'BREAK)
(HELP STRM1 STRM2)))
(RETURN I))) finally (RETURN T)))
(T (COND
((NEQ OPTION 'NOMSG)
(printout OUTPUTSTREAM T (FULLNAME STRM1)
" has length " |.P2| (GETEOFPTR STRM1)
", but "
(FULLNAME STRM2)
" has length " |.P2| (GETEOFPTR STRM2)
T)))
(COND
((EQ OPTION 'BREAK)
(HELP STRM1 STRM2)))
(LIST (GETEOFPTR STRM1)
(GETEOFPTR STRM2])
)
(DEFINEQ
(CHECKFORZEROS
[LAMBDA (FILE MINZEROS) (* ; "Edited 14-Jun-90 21:18 by jds")
(RESETLST
(PROG ((STREAM (OPENSTREAM FILE 'INPUT))
(%#FAILURES 0)
N)
(RESETSAVE NIL (LIST 'CLOSEF STREAM))
(OR MINZEROS (SETQ MINZEROS 20))
(replace (STREAM ENDOFSTREAMOP) of STREAM with (FUNCTION NILL))
(printout T (FULLNAME STREAM)
": " T)
(do (SELECTQ (BIN STREAM)
(NIL (RETURN))
(0 (SETQ N 1)
(while (ZEROP (BIN STREAM)) do (add N 1))
(COND
((IGREATERP N MINZEROS)
(printout T |.P2| N " zeros starting at byte " |.P2|
(SUB1 (IDIFFERENCE (GETFILEPTR STREAM)
N))
T)
(add %#FAILURES 1))))
NIL))
(RETURN (AND (NOT (ZEROP %#FAILURES))
%#FAILURES))))])
)
(RPAQ? FBREPEATCOUNT 4)
(RPAQ? FILEBANGERS )
(PUTPROPS FILEBANGER FILETYPE :COMPILE-FILE)
(PUTPROPS FILEBANGER COPYRIGHT ("Venue & Xerox Corporation" 1983 1987 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (853 10546 (DOFILEBANGER 863 . 1083) (DOMAKEFILEBANGER 1085 . 1282) (DOZEROBANGER 1284
. 1606) (FILEBANGER 1608 . 4686) (FBCOPYBYTES 4688 . 4884) (FBMAKETESTFILE 4886 . 5345) (
MAKEBANGERWINDOW 5347 . 5899) (MAKEFILEBANGER 5901 . 6714) (ZEROBANGER 6716 . 9360) (
SUSPEND.FILEBANGER 9362 . 9739) (WATCHDISKPAGES 9741 . 10544)) (10547 14583 (BINCOM 10557 . 14581)) (
14584 15841 (CHECKFORZEROS 14594 . 15839)))))
STOP

105
internal/envos/FLOPPYTESTER Normal file
View File

@@ -0,0 +1,105 @@
(FILECREATED "24-Mar-86 15:18:14" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;9 4308
changes to: (FNS STARTTEST STOPTEST KILLTEST)
(VARS FLOPPYTESTERCOMS)
previous date: "20-Mar-86 21:06:46" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;5)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FLOPPYTESTERCOMS)
(RPAQQ FLOPPYTESTERCOMS ((* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
(P (LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM)))
(INITVARS (ALLOCATIONSW NIL))
(FNS STARTTEST STOPTEST KILLTEST BLTALLOCS BLTALLOC)))
(* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
(LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM))
(RPAQ? ALLOCATIONSW NIL)
(DEFINEQ
(STARTTEST
(LAMBDA (N) (* kbr: "24-Mar-86 15:15")
(SETQ STARTTIME (GDATE))
(CNDIR (QUOTE {FLOPPY}))
(FLOPPY.FORMAT (QUOTE TEST))
(DIRECTORY (QUOTE {FLOPPY}*))
(BLTALLOCS)
(for I from 1 to N do (DOFILEBANGER (PACK* (QUOTE {FLOPPY})
(QUOTE TESTFILE)
I)
(RAND 10 30)))))
(STOPTEST
(LAMBDA NIL (* kbr: "24-Mar-86 15:16")
(SETQ STOPTIME (GDATE))
(for P in FILEBANGERS when (NOT (EQ P (THIS.PROCESS))) do (SUSPEND.PROCESS P))))
(KILLTEST
(LAMBDA NIL (* kbr: "22-Mar-86 17:18")
(for P in FILEBANGERS do (DEL.PROCESS P))
(SETQ FILEBANGERS NIL)))
(BLTALLOCS
[LAMBDA NIL (* kbr: "18-Nov-85 12:32")
(* Debugging fn. Puts up a window representation of 
allocations on floppy. *)
(PROG (PIXELS XLENGTH YLENGTH)
(SETQ PIXELS 5)
(SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
(SETQ YLENGTH \FLOPPY.CYLINDERS)
[COND
((NULL ALLOCATIONSW)
(SETQ ALLOCATIONSW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (ITIMES PIXELS
XLENGTH))
(HEIGHTIFWINDOW (ITIMES PIXELS
YLENGTH)
T)
NIL NIL NIL
"Position FLOPPY ALLOCATIONS window")
"FLOPPY ALLOCATIONS"))
(UNADVISE (QUOTE \PFLOPPY.ALLOCATE))
(ADVISE (QUOTE \PFLOPPY.ALLOCATE)
(QUOTE AFTER)
(QUOTE (COND (!VALUE (BLTALLOC !VALUE]
(BITBLT NIL NIL NIL ALLOCATIONSW NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(for Y from 0 to (SUB1 YLENGTH) do (for X from 0 to (SUB1 XLENGTH)
do (BITMAPBIT ALLOCATIONSW
(ITIMES PIXELS X)
(ITIMES PIXELS Y)
1)))
(for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV)
when [NOT (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
(QUOTE (FREE]
do (BLTALLOC PFALLOC])
(BLTALLOC
[LAMBDA (PFALLOC) (* kbr: "18-Nov-85 12:21")
(PROG (SHADE OPSHADE LEFT BOTTOM PIXELS XLENGTH)
(SETQ PIXELS 5)
(SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
(SETQ SHADE (COND
((EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
(QUOTE (FREE)))
WHITESHADE)
(T BLACKSHADE)))
(SETQ OPSHADE (IDIFFERENCE BLACKSHADE SHADE))
(for I from (fetch (PFALLOC START) of PFALLOC) to (fetch (PFALLOC END)
of PFALLOC)
do (SETQ LEFT (ITIMES PIXELS (IREMAINDER (SUB1 I)
XLENGTH)))
(SETQ BOTTOM (ITIMES PIXELS (IQUOTIENT (SUB1 I)
XLENGTH)))
(BLTSHADE SHADE ALLOCATIONSW LEFT BOTTOM PIXELS PIXELS (QUOTE REPLACE))
(BLTSHADE OPSHADE ALLOCATIONSW LEFT BOTTOM 1 1 (QUOTE REPLACE])
)
(PUTPROPS FLOPPYTESTER COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (745 4220 (STARTTEST 755 . 1203) (STOPTEST 1205 . 1463) (KILLTEST 1465 . 1665) (
BLTALLOCS 1667 . 3253) (BLTALLOC 3255 . 4218)))))
STOP

70
internal/envos/FLOPPYWORK Normal file
View File

@@ -0,0 +1,70 @@
(FILECREATED "19-Jun-86 12:32:16" {ERIS}<LISPCORE>SOURCES>FLOPPYWORK.;1 3836
changes to: (VARS FLOPPYWORKCOMS)
(FNS \PFLOPPY.SCAVENGE.PMPAGE.AFTER1))
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FLOPPYWORKCOMS)
(RPAQQ FLOPPYWORKCOMS ((FNS \PFLOPPY.SCAVENGE.PMPAGE.AFTER1)))
(DEFINEQ
(\PFLOPPY.SCAVENGE.PMPAGE.AFTER1
(LAMBDA (PLOCATION PPMPAGE LOCATION PMPAGE) (* kbr: "19-Jun-86 12:29")
(PROG (LENGTH TYPE FILETYPE FILEID)
RETRY
(COND
((NOT (\PFLOPPY.READPAGENO LOCATION PMPAGE T))
(* Couldn't read this LOCATION.
Assume misformatted track. *)
(GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (\FLOPPY.FORMATTRACKS
\FLOPPY.IBMD512.FLOPPYIOCB
(
\PFLOPPY.PAGENOTODISKADDRESS
LOCATION)
1 T))
(GO RETRY)))
(COND
((NOT (OR (fetch (PMPAGE INTACT) of PMPAGE)
(IEQP LOCATION \PFLOPPYLASTDATAPAGE)))
(RETURN))) (* Force PMPAGE to be a legal marker page.
*)
(replace (PMPAGE SEAL) of PMPAGE with SEAL.PMPAGE)
(replace (PMPAGE VERSION) of PMPAGE with VERSION.PMPAGE)
(SETQ LENGTH (IPLUS LOCATION (IMINUS PLOCATION)
-1))
(COND
((ZEROP LENGTH)
(SETQ TYPE PMPAGEETYPE.FREE)
(SETQ FILETYPE FILETYPE.FREE)
(SETQ FILEID 0))
(T (SETQ TYPE (fetch (PMPAGE NTYPE) of PPMPAGE))
(SETQ FILETYPE (fetch (PMPAGE NFILETYPE) of PPMPAGE))
(SETQ FILEID (COND
((EQ TYPE PMPAGEETYPE.PFILELIST)
1)
(T 0)))))
(replace (PMPAGE PLENGTH) of PMPAGE with LENGTH)
(replace (PMPAGE PTYPE) of PMPAGE with TYPE)
(replace (PMPAGE PFILETYPE) of PMPAGE with FILETYPE)
(replace (PMPAGE PFILEID) of PMPAGE with FILEID)
(* Fix PPMPAGE wrt PMPAGE now *)
(replace (PMPAGE NLENGTH) of PPMPAGE with LENGTH)
(replace (PMPAGE NTYPE) of PPMPAGE with TYPE)
(replace (PMPAGE NFILETYPE) of PPMPAGE with FILETYPE)
(replace (PMPAGE NFILEID) of PPMPAGE with FILEID)
(\PFLOPPY.WRITEPAGENO PLOCATION PPMPAGE)
(COND
((IEQP LOCATION \PFLOPPYLASTDATAPAGE)
(replace (PMPAGE NLENGTH) of PMPAGE with 0)
(replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FREE)
(replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FREE)
(replace (PMPAGE NFILEID) of PMPAGE with 0)
(\PFLOPPY.WRITEPAGENO LOCATION PMPAGE))))))
)
(PUTPROPS FLOPPYWORK COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (355 3755 (\PFLOPPY.SCAVENGE.PMPAGE.AFTER1 365 . 3753)))))
STOP

1
internal/envos/GIVE-AND-TAKE.STATUS Normal file
View File

@@ -0,0 +1 @@
"GADENER.ENVOS" "13-Apr-90 12:31:11"

1362
internal/envos/GRAPEVINE Normal file
View File

File diff suppressed because it is too large Load Diff

71
internal/envos/LARGESKETCHPATCH Normal file
View File

@@ -0,0 +1,71 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 17:09:55" 
|{DSK}<usr>local>lde>lispcore>internal>library>LARGESKETCHPATCH.;2| 3370
|changes| |to:| (VARS LARGESKETCHPATCHCOMS)
|previous| |date:| "27-Feb-87 18:22:14"
|{DSK}<usr>local>lde>lispcore>internal>library>LARGESKETCHPATCH.;1|)
; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT LARGESKETCHPATCHCOMS)
(RPAQQ LARGESKETCHPATCHCOMS ((FNS SKIO.IMAGEBOXFN \\SKIO.IN.TOO.SMALL.TEDITP)))
(DEFINEQ
(SKIO.IMAGEBOXFN
(LAMBDA (IMAGEOBJ STREAM) (* \; "Edited 27-Feb-87 18:04 by rrb")
(* |size| |function| |for| \a |sketch|
 |image| |object.|)
(PROG ((SKOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
SKREG SKW SKH SCALEFACTOR)
(* |determine| |the| |scale| |between| |the| |sketch| |specs| |and| |the|
 |stream.|)
(SETQ SCALEFACTOR (QUOTIENT (|fetch| (SKETCHIMAGEOBJ SKIO.SCALE) |of| SKOBJ)
(DSPSCALE NIL STREAM)))
(SETQ SKW (FIXR (FQUOTIENT (|fetch| (REGION WIDTH) |of| (SETQ SKREG (|fetch| (
SKETCHIMAGEOBJ
SKIO.REGION)
|of| SKOBJ)))
SCALEFACTOR)))
(SETQ SKH (FIXR (FQUOTIENT (|fetch| (REGION HEIGHT) |of| SKREG)
SCALEFACTOR)))
(RETURN (COND
((\\SKIO.IN.TOO.SMALL.TEDITP STREAM SKH)
(* |special| |check| |for| |displaying| |in| \a |Tedit| |window| |that| |is|
 |less| |than| |the| |height| |of| |the| |sketch.|
 |leave| |enough| |height| |for| \a |few| |lines| |of| |text| |too.|)
(|create| IMAGEBOX
XSIZE _ SKW
YSIZE _ (IMAX 12 (DIFFERENCE (|fetch| (REGION HEIGHT)
|of| (DSPCLIPPINGREGION NIL STREAM))
24))
YDESC _ 0
XKERN _ 0))
(T (|create| IMAGEBOX
XSIZE _ SKW
YSIZE _ SKH
YDESC _ 0
XKERN _ 0)))))))
(\\SKIO.IN.TOO.SMALL.TEDITP
(LAMBDA (STREAM HEIGHT) (* \; "Edited 27-Feb-87 18:19 by rrb")
(* |is| |this| |stream| \a TEDIT |window| |that| |is| |smaller| |than|
 |height?|)
(AND (DISPLAYSTREAMP STREAM)
(WINDOWPROP (WFROMDS STREAM)
'TEXTOBJ)
(GREATERP HEIGHT (|fetch| (REGION HEIGHT) |of| (DSPCLIPPINGREGION NIL STREAM))))))
)
(PUTPROPS LARGESKETCHPATCH COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (548 3269 (SKIO.IMAGEBOXFN 558 . 2806) (\\SKIO.IN.TOO.SMALL.TEDITP 2808 . 3267)))))
STOP

506
internal/envos/LFHACKS Normal file
View File

@@ -0,0 +1,506 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated " 4-Jun-87 18:33:02" {eris}<daniels>lisp>lfhacks.\;14 29149
|changes| |to:| (functions determine-system-volume chase-boot-links get-boot-pointer pda-to-vp
vol-num-containing-page vol-index-containing-page
determine-boot-file-runs-using-pointers print-runs-attractively
read-bad-page-table make-page-bad unmake-page-bad determine-file-runs
vp-to-da da-to-vp show-vmem-run-table default-bft fetch-long-cardinal
bootfile-fd write-pv-root-page max-bad-pages write-bad-page-table
bad-page-count list-from-bpt bpt-ref list-bad-pages)
(vars lfhackscoms)
(variables bpt bft-pilot-boot-file bft-germ bft-emulator-microcode
bft-diagnostic-microcode +boot-file-types+)
(setfs bad-page-count bpt-ref)
(commands "EC")
(structures file-run)
(records |PilotDiskAddress| bad-page-table bpt-entry)
|previous| |date:| " 3-Jun-87 18:31:15" {eris}<daniels>lisp>lfhacks.\;11)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(prettycomprint lfhackscoms)
(rpaqq lfhackscoms ((coms (functions read-label)
(variables bpt-label pv-root-page-label))
(coms (variables +boot-file-types+ bft-diagnostic-microcode
bft-emulator-microcode bft-germ bft-pilot-boot-file)
(declare\: eval@compile eval@load dontcopy (records |PilotDiskAddress|))
(functions vol-num-containing-page get-boot-pointer write-pv-root-page
bootfile-fd default-bft determine-system-volume fetch-long-cardinal
filedesc-from-name first-volume-page vp-to-da da-to-vp pda-to-vp))
(coms (declare\: eval@compile eval@load dontcopy (records bad-page-table
bpt-entry))
(functions read-bad-page-table)
(variables bpt)
(functions bad-page-count bpt-ref list-bad-pages list-from-bpt
make-page-bad max-bad-pages unmake-page-bad write-bad-page-table)
(setfs bad-page-count bpt-ref))
(coms (structures file-run)
(functions determine-file-runs show-vmem-run-table check-pages-free
print-runs-attractively)
(functions chase-boot-links determine-boot-file-runs-using-pointers))
(commands "EC")
(variables dsktw)
(advice |\\DoveDisk.HandleMajorError| |\\DoveDisk.TryRecalibrate|
(\\dove.xferdisk :in \\dldisk.execute))
(prop filetype lfhacks)))
(cl:defun read-label (pv-page) (let ((label (create |Label|)))
(|\\PFTransferPage| pv-page (ncreate 'vmempagep)
'vrr label 1)
label))
(cl:defparameter bpt-label (read-label 1) )
(cl:defparameter pv-root-page-label (read-label 0) )
(cl:defconstant +boot-file-types+ '((bft-diagnostic-microcode 0)
(bft-emulator-microcode 1)
(bft-germ 2)
(bft-pilot-boot-file 3)) )
(cl:defconstant bft-diagnostic-microcode 0)
(cl:defconstant bft-emulator-microcode 1)
(cl:defconstant bft-germ 2)
(cl:defconstant bft-pilot-boot-file 3)
(declare\: eval@compile eval@load dontcopy
(declare\: eval@compile
(blockrecord |PilotDiskAddress| ((head byte)
(sector byte)
(cylinder word)))
)
)
(cl:defun vol-num-containing-page (physical-page-number)
(for vol-num from 0 to (sub1 (|fetch| (|PhysicalVolumeDescriptor| |subVolumeCount|) |of|
|\\PhysVolumePage|
))
do (let ((sv-desc (mesaelt (fetch (|PhysicalVolumeDescriptor| |subVolumes|) of
|\\PhysVolumePage|
)
|SubVolumeArray| vol-num)))
(cl:when (and (igeq physical-page-number (fetch (|SubVolumeDesc| |pvPage|) of sv-desc))
(ilessp physical-page-number (iplus (fetch (|SubVolumeDesc| |pvPage|)
of sv-desc)
(fetch (|SubVolumeDesc| |nPages|)
of sv-desc))))
(return vol-num)))))
(cl:defun get-boot-pointer (vol-num bft) (cl:if vol-num (mesaelt (fetch (|LogicalVolumeDescriptor|
|bootingInfo|)
of (elt |\\DFSLogicalVolumes|
vol-num))
|LVBootFiles| bft)
(mesaelt (fetch (|PhysicalVolumeDescriptor|
|bootingInfo|) of
|\\PhysVolumePage|
)
|PVBootFiles| bft)))
(cl:defun write-pv-root-page nil (|\\PFTransferPage| 0 |\\PhysVolumePage| 'vvw pv-root-page-label 1))
(cl:defun bootfile-fd (&optional volume-num (bft (default-bft)))
(or volume-num
(* |;;| "VOLUME-NUM = NIL means use the running sysout.")
(cl:setf volume-num (determine-system-volume)))
(create |FileDescriptor|
|fileID| _ (fetch-long-cardinal (fetch (|DiskFileID| \fid)
of (mesaelt (fetch (|LogicalVolumeDescriptor|
|bootingInfo|)
of (elt |\\DFSLogicalVolumes| volume-num)
)
|LVBootFiles| bft)))
|volNum| _ volume-num
|type| _ |tDiagnosticMicrocode|))
(cl:defun default-bft nil (case (machinetype)
(dove bft-germ)
(cl:otherwise bft-diagnostic-microcode)))
(cl:defun determine-system-volume nil (let* ((first-run (locf (fetch dlvmemfileinfo of \\iocbpage)))
(boot-file-page (da-to-vp (fetch dlvmcyl of first-run)
(fetch dlvmhead of first-run)
(fetch dlvmsector of first-run)))
)
(vol-num-containing-page boot-file-page)))
(cl:defun fetch-long-cardinal (ptr) (\\makenumber (\\getbase ptr 1)
(\\getbase ptr 0)))
(cl:defun filedesc-from-name (name) (let ((filespec (|\\LFFileSpec| name 'old))
|volNum|)
(create |FileDescriptor|
|fileID| _ (|\\LFReadFileID|
(|\\LFGetDirectory|
(setq |volNum|
(|fetch| (|ExpandedName| volnum)
|of| (|fetch| (|DFSFileSpec|
expandedname)
|of| filespec))))
(|fetch| (|DFSFileSpec| fsdirptr)
|of| filespec))
|volNum| _ |volNum|
|type| _ |tLispFile|)))
(cl:defun first-volume-page (vol-index) (fetch (|SubVolumeDesc| |pvPage|)
of (mesaelt (fetch (|PhysicalVolumeDescriptor|
|subVolumes|) of
|\\PhysVolumePage|
)
|SubVolumeArray| vol-index)))
(defmacro vp-to-da (vp) `(cl:locally (declare (globalvars \\dldiskshape.sectorspercylinder
\\dldiskshape.sectorsperhead))
(cl:multiple-value-bind (cylinder rem)
(cl:floor ,vp \\dldiskshape.sectorspercylinder)
(cl:multiple-value-call 'list cylinder (cl:floor rem
\\dldiskshape.sectorsperhead
)))))
(defmacro da-to-vp (cyl hd sec) `(cl:locally (declare (globalvars \\dldiskshape.sectorspercylinder
\\dldiskshape.sectorsperhead))
(iplus (itimes ,cyl \\dldiskshape.sectorspercylinder)
(itimes ,hd \\dldiskshape.sectorsperhead)
,sec)))
(defmacro pda-to-vp (pda) `(let ((pda ,pda))
(da-to-vp (fetch (|PilotDiskAddress| cylinder) of pda)
(fetch (|PilotDiskAddress| head) of pda)
(fetch (|PilotDiskAddress| sector) of pda))))
(declare\: eval@compile eval@load dontcopy
(declare\: eval@compile
(mesaarray bad-page-table ((0 127))
bpt-entry)
(mesarecord bpt-entry ((page swappedfixp)))
)
)
(cl:defun read-bad-page-table (&optional (table bpt)) (|\\PFTransferPage| 1 table 'vvr bpt-label 1))
(cl:defparameter bpt (let ((table (ncreate 'vmempagep)))
(read-bad-page-table table)
table) )
(definline bad-page-count nil (fetch (|PhysicalVolumeDescriptor| |badPageCount|) of
|\\PhysVolumePage|
))
(defmacro bpt-ref (index) `(fetch (bpt-entry page) of (mesaelt bpt bad-page-table ,index)))
(cl:defun list-bad-pages (&optional read?) (and read? (read-bad-page-table))
(cl:dotimes (i (bad-page-count)
(terpri))
(cl:format t "~D " (bpt-ref i))))
(cl:defun list-from-bpt nil (for i from 0 to (cl:1- (bad-page-count)) collect (bpt-ref i)))
(cl:defun make-page-bad (physical-page-number &optional read?)
(and read? (read-bad-page-table))
(let ((bp-list (list-from-bpt)))
(cond
((igeq (cl:list-length bp-list)
(max-bad-pages))
(cl:error "Too many bad pages"))
((member physical-page-number bp-list)
(cl:format *error-output* "~D already marked bad~%" physical-page-number))
(t (let ((new-bp-list (cl:merge 'list (list physical-page-number)
bp-list
'ilessp)))
(for page in new-bp-list as index from 0 do (cl:setf (bpt-ref index)
page)
finally (cl:setf (bad-page-count)
(cl:list-length new-bp-list))
(uninterruptably
(write-bad-page-table)
(write-pv-root-page))))))))
(defmacro max-bad-pages nil (fetch (|PhysicalVolumeDescriptor| |maxBadPages|) of |\\PhysVolumePage|))
(cl:defun unmake-page-bad (physical-page-number &optional read?)
(and read? (read-bad-page-table))
(let ((bp-list (list-from-bpt)))
(cond
((member physical-page-number bp-list)
(cl:setf bp-list (remove physical-page-number bp-list))
(for page in bp-list as index from 0 do (cl:setf (bpt-ref index)
page) finally (cl:setf (bad-page-count)
(cl:list-length
bp-list))
(uninterruptably
(write-bad-page-table)
(write-pv-root-page))))
(t (cl:format *error-output* "~D not in bad page table~%" physical-page-number)))))
(cl:defun write-bad-page-table nil (|\\PFTransferPage| 1 bpt 'vvw bpt-label 1))
(cl:defsetf bad-page-count nil (new-count)
`(cl:if (> ,new-count (max-bad-pages))
(cl:error "Too many bad pages")
(replace (|PhysicalVolumeDescriptor| |badPageCount|)
of |\\PhysVolumePage| with ,new-count)))
(cl:defsetf bpt-ref (index) (new-val)
`(replace (bpt-entry page)
of (\\addbase bpt (iplus ((openlambda (|index|)
(or (and (ileq 0 |index|)
(ileq |index| 127))
(error '|indexOutOfRange|))
(itimes 2 (idifference |index| 0)))
,index))) with ,new-val))
(cl:defstruct (file-run (:type list)
(:conc-name "FR-")) file-page vol-page length)
(cl:defun determine-file-runs (file-desc)
(let ((file-length (|\\PFFindFileSize| file-desc))
(page-runs nil)
(file-page 0))
(cl:loop (cl:push (make-file-run :file-page file-page :vol-page (|\\PFFindPageAddr| file-desc
file-page)
:length
(difference (fetch (|PageGroup| |nextFilePage|)
of (fetch (|FileDescriptor| pagegroup) of file-desc))
file-page))
page-runs)
(setq file-page (fetch (|PageGroup| |nextFilePage|) of (fetch (|FileDescriptor|
pagegroup)
of file-desc)))
(cl:when (>= file-page file-length)
(return (reverse page-runs))))))
(cl:defun show-vmem-run-table
nil (let ((linkbase (locf (fetch (iocbpage dlvmemfileinfo) of \\iocbpage))))
(cl:format t "File Page Numbers => Disk Page Numbers~%")
(bind (vp _ 0)
end-of-run-vp da end-of-run-da run-list
eachtime (cl:setf da (da-to-vp (fetch (dlvmemrun dlvmcyl) of linkbase)
(fetch (dlvmemrun dlvmhead) of linkbase)
(fetch (dlvmemrun dlvmsector) of linkbase)))
while (neq 0 (fetch (dlvmemrun dlfirstfilepage) of (fetch (dlvmemrun dlnextrun)
of linkbase)))
do (cl:setf end-of-run-vp (cl:1- (fetch (dlvmemrun dlfirstfilepage)
of (fetch (dlvmemrun dlnextrun) of linkbase)))
end-of-run-da
(iplus da (idifference end-of-run-vp vp)))
(cl:format t "[~D..~D] => [~D..~D]~A~%" vp end-of-run-vp da end-of-run-da
(cond
((some run-list #'(lambda (prev-addr-range)
(and (igeq da (car prev-addr-range))
(ileq da (cdr prev-addr-range)))))
" <= Entirely bogus VMem run!")
((not (eqp (idifference end-of-run-vp vp)
(idifference end-of-run-da da)))
" <= VMem run length doesn't match disk run length!")
(t "")))
(push run-list (cons da end-of-run-da))
(cl:setf vp (fetch (dlvmemrun dlfirstfilepage) of (fetch (dlvmemrun dlnextrun)
of linkbase))
linkbase
(fetch (dlvmemrun dlnextrun) of linkbase))
finally (cl:setf end-of-run-vp (fetch (ifpage |DLLastVmemPage|) of |\\InterfacePage|))
(cl:format t "[~D..~D] => [~D..~D]~%" vp end-of-run-vp da
(iplus da (idifference end-of-run-vp vp))))))
(cl:defun check-pages-free (vol file-runs &optional (one-at-a-time? t))
(* |;;| "Check that the labels for the given pages look good. Doesn't check the VAM yet.")
(for run in file-runs
do (with-resource |\\DFSVAMjunkPage| (if one-at-a-time?
then (for vol-page from (fr-vol-page run) as counter
from 1 to (fr-length run)
do (proceed-case (|\\PFGetFreePage| vol vol-page
|\\DFSVAMjunkPage| 1)
(continue nil :report
"Skip this page and continue"))
)
else (|\\PFGetFreePage| vol (fr-vol-page run)
|\\DFSVAMjunkPage|
(fr-length run))))))
(cl:defun print-runs-attractively (file-runs &optional vol-num)
(let ((offset (cl:if vol-num (first-volume-page vol-num)
0)))
(for run in file-runs first (cl:format t "File Page Numbers => Disk Page Numbers~%")
do (cl:format t "[~D..~D] => [~D..~D]~%" (fr-file-page run)
(cl:1- (+ (fr-file-page run)
(fr-length run)))
(+ (fr-vol-page run)
offset)
(cl:1- (+ (fr-vol-page run)
offset
(fr-length run)))))))
(cl:defun chase-boot-links (fn &key vol-num (bft (default-bft))
verbose)
(* |;;| "runs through the bootfile starting from the appropriate boot pointer, using the LV boot pointer is a particular volume is specified, following the boot links. FN is called on each page with a physical page number, file page number, and file id. If verbose is true, will print something every 100 pages.")
(let ((boot-pointer (get-boot-pointer vol-num bft)))
(cl:when (cl:zerop (fetch (|DiskFileID| |da|) of boot-pointer))
(cl:error "No boot pointer found."))
(with-resource |label| (bind (correct-id _ (fetch-long-cardinal (fetch (|DiskFileID| \fid)
of boot-pointer)))
(last-boot-file-page _ (cl:1- (|\\PFFindFileSize| (bootfile-fd
vol-num bft))))
(vp _ (pda-to-vp (fetch (|DiskFileID| |da|) of boot-pointer)))
(fp _ (cl:1- (fetch (|DiskFileID| |firstPage|) of boot-pointer)))
(buffer _ (ncreate 'vmempagep))
file-id first (cl:when verbose (cl:princ "Processing bootfile"
*error-output*))
for page-num from 0
do
(* |;;| "Read next page")
(cl:when (eql (cl:mod fp 100)
99)
(cl:when verbose (cl:princ "." *error-output*))
(block))
(let ((status (|\\PFTransferPage| vp buffer 'vrr |label| 1)))
(cl:when (not (eq status 'ok))
(cl:cerror "Continue processing the file"
"Can't read page ~D: status = ~S" vp status)))
(cl:when (not (eql (cl:1+ fp)
(fetch (|Label| |filePage|) of |label|)))
(cl:cerror "Continue processing the file"
"Boot file pages not contiguous: prev = ~D, current = ~D"
fp (fetch (|Label| |filePage|) of |label|)))
(cl:when (not (eql (cl:setf file-id (fetch (|Label| |fileID|)
of |label|))
correct-id))
(cl:cerror "Continue processing the file"
"File id in label (~D) doesn't match boot pointer (~D)"
file-id correct-id))
(cl:setf fp (fetch (|Label| |filePage|) of |label|))
(cl:funcall fn vp fp page-num file-id)
(cond
((and (eql -1 (fetch (|PilotDiskLabel| |BootLinkA|)
of |label|))
(eql -1 (fetch (|PilotDiskLabel| |BootLinkB|)
of |label|)))
(cl:when verbose (cl:princ "<boot link all 1's> "
*error-output*))
(return))
((igeq fp last-boot-file-page)
(cl:when verbose (cl:princ "<end of file> " *error-output*))
(return))
((and (cl:zerop (fetch (|PilotDiskLabel| |BootLinkA|)
of |label|))
(cl:zerop (fetch (|PilotDiskLabel| |BootLinkB|)
of |label|)))
(* |;;| "No boot link - continue to next page")
(cl:incf vp))
(t
(* |;;| "Have a real boot link - jump to new disk address")
(cl:setf vp (pda-to-vp (\\makenumber (fetch (
|PilotDiskLabel|
|BootLinkB|)
of |label|)
(fetch (|PilotDiskLabel|
|BootLinkA|)
of |label|))))
(cl:when verbose (cl:format *error-output* "<Jump to ~D>" vp
))))))
(cl:when verbose (cl:princ "done." *error-output*)
(cl:terpri *error-output*))))
(cl:defun determine-boot-file-runs-using-pointers (&rest key-args &key vol-num (bft (default-bft))
verbose)
(let ((offset (first-volume-page (vol-num-containing-page (pda-to-vp (fetch (|DiskFileID| |da|)
of (get-boot-pointer
vol-num bft))))))
(run-list nil)
last-vp run)
(cl:apply 'chase-boot-links
#'(cl:lambda (vp fp page-num file-id)
(declare (ignore page-num file-id))
(cl:flet ((new-run (fp vp)
(cl:push (cl:setf run (make-file-run :file-page fp :vol-page
(- vp offset)
:length 1))
run-list)
(cl:setf last-vp vp)))
(cond
((null last-vp)
(new-run fp vp))
((eql vp (cl:incf last-vp))
(cl:incf (fr-length run)))
(t (new-run fp vp))))) key-args)
(reverse run-list)))
(defcommand "EC" (expression)
(* |;;| "\"eval compiled\"")
(cl:funcall (cl:compile nil `(cl:lambda nil ,expression))))
(defglobalvar dsktw )
(xcl:reinstall-advice '|\\DoveDisk.HandleMajorError| :before '((:last (prin2 'h dsktw))))
(xcl:reinstall-advice '|\\DoveDisk.TryRecalibrate| :before '((:last (prin2 'r dsktw))))
(xcl:reinstall-advice '(\\dove.xferdisk :in \\dldisk.execute) :after
'((:last (if (eq !value 'ok)
then
(prin2 '+ dsktw)
else
(prin2 '- dsktw)))))
(putprops lfhacks filetype :compile-file)
(putprops lfhacks copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
(filemap (nil)))
stop

815
internal/envos/LISPDIAGNOSTICS Normal file
View File

@@ -0,0 +1,815 @@
(FILECREATED "19-Dec-84 19:20:52" {ERIS}<LISPCORE>LIBRARY>LISPDIAGNOSTICS.;37 31535
changes to: (FNS DSKPROC.DO1COPY)
previous date: "16-Dec-84 18:48:51" {ERIS}<LISPCORE>LIBRARY>LISPDIAGNOSTICS.;36)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LISPDIAGNOSTICSCOMS)
(RPAQQ LISPDIAGNOSTICSCOMS ((COMS (* "This would be a good one for the system to have")
(FNS UNSHADEALLITEMS printout.SUBR))
(INITVARS (DIAGNOSTICSRECORDSTREAM T)
(DIAGNOSTICSCONTROLWINDOW.POSITION (create POSITION XCOORD _
800 YCOORD _ 80)))
(VARS (EXERCISE.RUNNER NIL)
(EXERCISE.STATE (QUOTE STOP))
EXERCISE.POSSIBILITIES)
(CONSTANTS \LD.INFOSHADE)
(GLOBALVARS DIAGNOSTICSRECORDSTREAM DIAGNOSTICSCONTROLWINDOW.POSITION
EXERCISE.RUNNER EXERCISE.STATE EXERCISE.POSSIBILITIES)
(FNS EXERCISE \LD.BLOCKCHECK \LD.STOPPROCS)
(COMS (* "Some user-interface, menu-like things")
(CONSTANTS (\LD.DPM.MENUBORDERSIZE 3))
(INITVARS (\LD.DCW.WINDOW NIL)
(\LD.DPM.MENU NIL)
(\LD.DPM.WINDOW NIL)
(\LD.DPM.WINDOWBORDERSIZE NIL)
(\LD.DPM.ITEMS NIL)
(\LD.DPM.SPACEWIDTH NIL))
(FNS MAKEDIAGNOSTICSMENU \LD.DCW.WHENSELECTED \LD.DPM.WHENSELECTED)
(GLOBALVARS \LD.DCW.WINDOW \LD.DPM.MENU \LD.DPM.WINDOW
\LD.DPM.WINDOWBORDERSIZE \LD.DPM.FONTHEIGHT
\LD.DPM.ITEMS \LD.DPM.SPACEWIDTH))
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS EXERCISE.POSSIBILITIES)
(MACROS ldprintout))
(COMS (* "Various background activities to stress hardware")
(FNS DSKPROC DSKPROC.AUX DSKPROC.DO1COPY ETHERPROC DAEMONPROC))
(COMS (* "Various diagnostic and benchmark activities")
(FNS EMUPROC 20RECLAIM)
(* "After the TANSPEED benchmark")
(FNS \LD.TANSPEED)
(* "Extraction from Gabriel's BROWSE benchmark")
(FNS \LD.BROWSE \LD.BROWSEINIT \LD.BROWSEMATCH)
(VARS (!BROWSEINIT NIL))
(GLOBALVARS !BROWSEINIT)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS CHAR1)))
(DECLARE: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY (* "PPLossage")
(ADDVARS (DISPLAYFONTEXTENSIONS STRIKE)
(DISPLAYFONTDIRECTORIES {FLOPPY})
(LISPUSERSDIRECTORIES {FLOPPY}))
(VARS (!MTUSERAIDFLG NIL))
(FILES (COMPILED FROM VALUEOF LISPUSERSDIRECTORIES)
PAGEHOLD MACROTESTAUX MACROTEST PLURAL)
(P (MAKEDIAGNOSTICSMENU)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA printout.SUBR)))))
(* "This would be a good one for the system to have")
(DEFINEQ
(UNSHADEALLITEMS
(LAMBDA (MENU) (* JonL " 1-Dec-84 18:19")
(PROG ((ITEMS (fetch (MENU ITEMS) of MENU)))
(MAPC ITEMS (FUNCTION (LAMBDA (ITEM)
(SHADEITEM ITEM MENU WHITESHADE)))))))
(printout.SUBR
(LAMBDA N (* JonL " 1-Dec-84 22:52")
(* * Temporarily, this prints out to \TopLevelTtyWindow until we can also make a broadcast stream.)
(OR (IGEQ N 2)
(SHOULDNT "Too few args"))
(bind X (STREAM _(ARG N 1)) for I from 2 to N do (SELECTQ (SETQ X (ARG N I))
(T (TERPRI STREAM)
(TERPRI \TopLevelTtyWindow))
((, -1)
(SPACES 1 STREAM)
(SPACES 1 \TopLevelTtyWindow))
(PROGN (PRIN1 X STREAM)
(PRIN1 X \TopLevelTtyWindow))))))
)
(RPAQ? DIAGNOSTICSRECORDSTREAM T)
(RPAQ? DIAGNOSTICSCONTROLWINDOW.POSITION (create POSITION XCOORD _ 800 YCOORD _ 80))
(RPAQQ EXERCISE.RUNNER NIL)
(RPAQQ EXERCISE.STATE STOP)
(RPAQQ EXERCISE.POSSIBILITIES ((T (EMUPROC)
"BenchMarks")
((AND (HOSTNAMEP (QUOTE DSK))
(IGEQ (DISKFREEPAGES)
500))
(DSKPROC)
"Disk Activity")
((START.CLEARINGHOUSE T)
(ETHERPROC)
"Ethernet Activity")
(T (DAEMONPROC)
"Swap-out WorkingSet")))
(DECLARE: EVAL@COMPILE
(RPAQQ \LD.INFOSHADE 16920)
(CONSTANTS \LD.INFOSHADE)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DIAGNOSTICSRECORDSTREAM DIAGNOSTICSCONTROLWINDOW.POSITION EXERCISE.RUNNER EXERCISE.STATE
EXERCISE.POSSIBILITIES)
)
(DEFINEQ
(EXERCISE
(LAMBDA (N) (* JonL "16-Dec-84 17:09")
(SETQ EXERCISE.STATE NIL)
(RESETLST (PROG ((OEMS ERRORMESSAGESTREAM)
(ODRS DIAGNOSTICSRECORDSTREAM)
(DPM.FONT MENUFONT)
RUNNINGPROCS MENUSTATE DCWMENU DCWITEMS)
(if (AND (EQ DIAGNOSTICSRECORDSTREAM T)
(HOSTNAMEP (QUOTE DSK)))
then (RESETSAVE (SETQ DIAGNOSTICSRECORDSTREAM (OPENSTREAM (QUOTE
{DSK}DIAGNOSTICSRECORD)
(QUOTE OUTPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE)
(SETQ DIAGNOSTICSRECORDSTREAM T)))))
(if (EQ ERRORMESSAGESTREAM T)
then (SETQ ERRORMESSAGESTREAM DIAGNOSTICSRECORDSTREAM))
(if (WINDOWP \LD.DCW.WINDOW)
then (DETACHALLWINDOWS \LD.DCW.WINDOW)
else (MAKEDIAGNOSTICSMENU))
(OPENW \LD.DCW.WINDOW)
(UNSHADEALLITEMS (SETQ DCWMENU (CAR (WINDOWPROP \LD.DCW.WINDOW (QUOTE MENU)))))
(SHADEITEM (ASSOC (QUOTE StartExercise)
(SETQ DCWITEMS (fetch (MENU ITEMS) of DCWMENU)))
DCWMENU \LD.INFOSHADE)
(SETQ RUNNINGPROCS (SETQ \LD.DPM.ITEMS))
(SETQ \LD.DPM.SPACEWIDTH (STRINGWIDTH " " DPM.FONT))
(SETQ \LD.DPM.FONTHEIGHT (FONTHEIGHT DPM.FONT))
(bind PROC for \Possibility in (PROG1 EXERCISE.POSSIBILITIES
(* Comment PPLossage))
as THISHEIGHT from 0 by (IPLUS \LD.DPM.FONTHEIGHT \LD.DPM.MENUBORDERSIZE)
eachtime (if (EQ EXERCISE.STATE (QUOTE STOP))
then (RETURN (SETQ RUNNINGPROCS)))
when (SETQ PROC
(CAR (LISTP (NLSETQ (PROGN (NLSETQ (DEL.PROCESS
(CAR (fetch (EXERCISE.POSSIBILITIES
PROCFORM)
of \Possibility))))
(AND (EVAL (fetch (EXERCISE.POSSIBILITIES
TESTFORM)
of \Possibility))
(ADD.PROCESS (fetch (
EXERCISE.POSSIBILITIES PROCFORM) of \Possibility)
(QUOTE SUSPEND)
T)))))))
do (DECLARE (SPECVARS \Possibility))
(push \LD.DPM.ITEMS (LIST (CONCAT " " (fetch (EXERCISE.POSSIBILITIES
MENUITEMFORM)
of \Possibility))
NIL "LEFT to WakeUp, MIDDLE to Suspend"
(LIST (PROCESS.NAME PROC)
THISHEIGHT)))
(push RUNNINGPROCS PROC))
(if (OR (NULL RUNNINGPROCS)
(EQ EXERCISE.STATE (QUOTE STOP)))
then (UNSHADEALLITEMS DCWMENU)
(RETURN (QUOTE ABORT)))
(SETQ \LD.DPM.MENU
(create MENU
ITEMS _ \LD.DPM.ITEMS
MENUFONT _ DPM.FONT
MENUBORDERSIZE _ 1
MENUCOLUMNS _ 1
WHENSELECTEDFN _(FUNCTION \LD.DPM.WHENSELECTED)))
(SETQ \LD.DPM.ITEMS (fetch (MENU ITEMS) of \LD.DPM.MENU))
(* Just to be sure of the right EQality!)
(ATTACHMENU \LD.DPM.MENU \LD.DCW.WINDOW (QUOTE TOP)
(QUOTE RIGHT))
(SETQ \LD.DPM.WINDOW (OR (CAR (ATTACHEDWINDOWS \LD.DCW.WINDOW))
(SHOULDNT)))
(SETQ \LD.DPM.WINDOWBORDERSIZE (WINDOWPROP \LD.DPM.WINDOW (QUOTE BORDER)))
(SETQ EXERCISE.RUNNER)
(SETQ EXERCISE.STATE (QUOTE RUNNING))
(printout.SUBR DIAGNOSTICSRECORDSTREAM T " Legend" T T
"! -> Completed !DIAGNOSE of MACROTEST"
T "@ -> Completed TANSPEED benchmark" T
"# -> Completed BROWSE benchmark"
T "$ - > Found a Clearing House on the EtherNet" T
"- -> Looked, but faild to find a Clearing House"
T "[xxx] -> Tried 32 retrievals from CH and got xxx failures" T T
"{xxx} - > Copied and deleted xxx copies of the Disk file"
"(xxx) -> Finished with xxx'th run of the EMUPROC loop." T
"GDATE on new line marks release of working set pages."
T T T)
(MAPC RUNNINGPROCS (FUNCTION WAKE.PROCESS))
(SHADEITEM (ASSOC (QUOTE StartExercise)
DCWITEMS)
DCWMENU WHITESHADE)
LP (* Just let the processes run until we STOP them)
(if (OR (EQ (SETQ MENUSTATE (BLOCK 10000))
(QUOTE STOP))
(EQ EXERCISE.STATE (QUOTE STOP)))
then (PROG ((MENU (CAR (WINDOWPROP \LD.DCW.WINDOW (QUOTE MENU))))
ITEM)
(AND (SETQ ITEM (ASSOC (QUOTE StopExercise)
(fetch (MENU ITEMS) of MENU)))
(SHADEITEM ITEM MENU \LD.INFOSHADE))
(\LD.STOPPROCS RUNNINGPROCS MENU)
(DETACHALLWINDOWS \LD.DCW.WINDOW)
(AND (NEQ DIAGNOSTICSRECORDSTREAM T)
(CLOSEF DIAGNOSTICSRECORDSTREAM))
(AND ITEM (SHADEITEM ITEM MENU WHITESHADE)))
(SETQ ERRORMESSAGESTREAM OEMS)
(SETQ DIAGNOSTICSRECORDSTREAM ODRS)
(RETURN (QUOTE STOP))
elseif MENUSTATE
then (* Someday, look for more interesting signals)
)
(GO LP)))))
(\LD.BLOCKCHECK
(LAMBDA (TIME POS NAME) (* JonL "16-Dec-84 17:10")
(PROG ((SIGNAL (if (DISMISS TIME)
elseif (NULL TIME)
then (* Allow two passes around the scheduler loop when 
blocking for 0 time; this helps the MOUSE tracker)
(BLOCK)))
NEWP OLDP)
(if (OR (EQ SIGNAL (QUOTE STOP))
(EQ EXERCISE.STATE (QUOTE STOP)))
then (RETFROM POS (QUOTE STOP))
elseif SIGNAL
then (* Do some action precipitaed by the menu)
)
(if (EQ NAME (QUOTE DON'T))
then (RETURN)
elseif (AND NAME (LITATOM NAME))
elseif (AND POS (LITATOM POS))
then (SETQ NAME POS)
else (SHOULDNT))
(if (SETQ NEWP (find ITEM in \LD.DPM.ITEMS suchthat (EQ NAME (CAR (CADDDR ITEM)))))
then (if (AND EXERCISE.RUNNER (SETQ OLDP (find ITEM in \LD.DPM.ITEMS
suchthat (EQ EXERCISE.RUNNER
(CAR (CADDDR ITEM))))))
then (* First, take away the "baton" from the old process)
(BITBLT NIL NIL NIL \LD.DPM.WINDOW \LD.DPM.WINDOWBORDERSIZE
(CADR (CADDDR OLDP))
\LD.DPM.SPACEWIDTH \LD.DPM.FONTHEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE))
(BITBLT NIL 0 0 \LD.DPM.WINDOW \LD.DPM.WINDOWBORDERSIZE (CADR (CADDDR NEWP))
\LD.DPM.SPACEWIDTH \LD.DPM.FONTHEIGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE) (* Here, we give the "baton" to the process NAME -- by 
turning on some bits in the menuitem reflecting that 
process)
(SETQ EXERCISE.RUNNER NAME)))))
(\LD.STOPPROCS
(LAMBDA (PROCS MENU) (* JonL " 1-Dec-84 21:13")
(* When we want to stop, the find out who is still alive, and give them the STOP signal; then wait around for 60 
seconds so to see if they "give up" gracefully.)
(MAPC (SETQ PROCS (MAPCONC (MKLIST PROCS)
(FUNCTION (LAMBDA (PROC)
(AND (PROCESSP PROC)
(LIST PROC))))))
(FUNCTION (LAMBDA (PROC)
(WAKE.PROCESS PROC (QUOTE STOP)))))
(bind STOPPERS PN forDuration 60 timerUnits (QUOTE SECONDS) until (NULL PROCS) eachtime (BLOCK)
when (SETQ STOPPERS (for P in PROCS when (PROCESS.FINISHEDP P) collect P))
do (SETQ PROCS (LDIFFERENCE PROCS STOPPERS))
(for P ITEM in STOPPERS
do (SETQ PN (PROCESS.NAME P))
(if (SETQ ITEM (find ITEM in \LD.DPM.ITEMS suchthat (EQ PN (CAR (CADDDR ITEM)))))
then (SHADEITEM ITEM MENU DARKBITSHADE))))
(if PROCS
then (printout.SUBR DIAGNOSTICSRECORDSTREAM T "Processes which didn't terminate normally: "
(MAPCAR PROCS (QUOTE PROCESS.NAME))
T)
(MAPC PROCS (FUNCTION DEL.PROCESS)))))
)
(* "Some user-interface, menu-like things")
(DECLARE: EVAL@COMPILE
(RPAQQ \LD.DPM.MENUBORDERSIZE 3)
(CONSTANTS (\LD.DPM.MENUBORDERSIZE 3))
)
(RPAQ? \LD.DCW.WINDOW NIL)
(RPAQ? \LD.DPM.MENU NIL)
(RPAQ? \LD.DPM.WINDOW NIL)
(RPAQ? \LD.DPM.WINDOWBORDERSIZE NIL)
(RPAQ? \LD.DPM.ITEMS NIL)
(RPAQ? \LD.DPM.SPACEWIDTH NIL)
(DEFINEQ
(MAKEDIAGNOSTICSMENU
(LAMBDA NIL (* JonL "16-Dec-84 17:06")
(AND (WINDOWP \LD.DCW.WINDOW)
(CLOSEW \LD.DCW.WINDOW))
(SETQ \LD.DCW.WINDOW (ADDMENU (create MENU
ITEMS _(QUOTE ((StartExercise
(PROG ((\INTERRUPTABLE NIL))
(SETQ EXERCISE.STATE (QUOTE RUN))
(ADD.PROCESS (QUOTE (EXERCISE))))
"Begins diagnostic suite processes")
(StopExercise (WAKE.PROCESS (QUOTE EXERCISE)
(SETQ
EXERCISE.STATE
(QUOTE STOP)))
"Stops and deletes the diagnostic processes (if any)")))
WHENSELECTEDFN _(FUNCTION \LD.DCW.WHENSELECTED)
MENUFONT _(FONTCREATE (QUOTE HELVETICA)
18)
MENUTITLEFONT _(FONTCREATE (QUOTE TIMESROMAN)
12)
TITLE _ "Diagnostics Control"
CENTERFLG _ T
ITEMHEIGHT _ 30
ITEMWIDTH _(IMAX 150 (IPLUS 20 (STRINGWIDTH
"StartExercise"
(FONTCREATE (QUOTE HELVETICA)
18))))
MENUBORDERSIZE _ \LD.DPM.MENUBORDERSIZE)
NIL DIAGNOSTICSCONTROLWINDOW.POSITION))
(WINDOWPROP \LD.DCW.WINDOW (QUOTE AFTERMOVEFN)
(FUNCTION (LAMBDA (WINDOW)
(OR (EQ WINDOW \LD.DCW.WINDOW)
(SHOULDNT))
(PROG ((REG (WINDOWPROP WINDOW (QUOTE REGION))))
(SETQ DIAGNOSTICSCONTROLWINDOW.POSITION (create POSITION
XCOORD _(fetch
(REGION LEFT)
of REG)
YCOORD _(fetch
(REGION BOTTOM)
of REG)))))))
(WINDOWPROP \LD.DCW.WINDOW (QUOTE RESHAPEFN)
(QUOTE DON'T))
(WINDOWPROP \LD.DCW.WINDOW (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (WINDOW)
(SETQ \LD.DCW.WINDOW))))
\LD.DCW.WINDOW))
(\LD.DCW.WHENSELECTED
(LAMBDA (ITEM MENU BUTTON) (* JonL " 1-Dec-84 18:29")
(SHADEITEM ITEM MENU GRAYSHADE)
(EVAL (CADR ITEM))))
(\LD.DPM.WHENSELECTED
(LAMBDA (ITEM MENU BUTTON) (* JonL " 1-Dec-84 00:08")
(PROG ((STUFF (CADDDR ITEM)))
(* This STUFF in the 4th slot of the menuitem should be a list of the process name and the height in the menuwindow 
of this item.)
(APPLY* (SELECTQ BUTTON
(LEFT (FUNCTION WAKE.PROCESS))
(MIDDLE (FUNCTION SUSPEND.PROCESS))
(RETURN))
(OR (FIND.PROCESS (CAR STUFF))
(RETURN))))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \LD.DCW.WINDOW \LD.DPM.MENU \LD.DPM.WINDOW \LD.DPM.WINDOWBORDERSIZE \LD.DPM.FONTHEIGHT
\LD.DPM.ITEMS \LD.DPM.SPACEWIDTH)
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD EXERCISE.POSSIBILITIES (TESTFORM PROCFORM MENUITEMFORM))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS ldprintout MACRO ((STREAM . REST)
(PROGN (* How we'd like a broadcast stream here!)
(printout STREAM . REST)
(printout \TopLevelTtyWindow . REST))))
)
)
(* "Various background activities to stress hardware")
(DEFINEQ
(DSKPROC
(LAMBDA (N) (* JonL "16-Dec-84 18:27")
(* Cause a lot of DSK activity)
(RESETLST (RESETSAVE NIL (QUOTE (PROGN (CLOSEF? (QUOTE {DSK}RANDOMDATA))
(CLOSEF? (QUOTE {CORE}RANDOMDATA))
(until (NULL (DELFILE (QUOTE {DSK}RANDOMDATA))))
(until (NULL (DELFILE (QUOTE {CORE}RANDOMDATA))))
(RESETLST (PROG1
(* Comment PPLossage))
(RESETSAVE (CNDIR (QUOTE {DSK}))
(LIST (FUNCTION CNDIR)
(DIRECTORYNAME T)))
((LAMBDA (X)
(MAPC X (FUNCTION CLOSEF?))
(MAPC X (FUNCTION DELFILE)))
(DIRECTORY (QUOTE TEMPRANDOMCOPY*)))))))
(DSKPROC.AUX N))))
(DSKPROC.AUX
(LAMBDA (N) (* JonL "16-Dec-84 18:44")
(OR (FIXP N)
(SETQ N MAX.SMALLP))
(PROG (SOURCE CORESOURCE NFILES)
(until (NULL (DELFILE (QUOTE {DSK}RANDOMDATA))))
(until (NULL (DELFILE (QUOTE {CORE}RANDOMDATA))))
(SETQ CORESOURCE (OPENFILE (QUOTE {CORE}RANDOMDATA)
(QUOTE OUTPUT))) (* First, create a moderately large file to copy)
(for I from 0 to 99
do (\LD.BLOCKCHECK 100 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(for J from 0 to 9 do (printout CORESOURCE "Now here's yet another line, the "
(IPLUS (ITIMES I 10)
J 1)
"'th one." T)))
(TERPRI CORESOURCE)
(CLOSEF CORESOURCE)
(SETQ SOURCE (DSKPROC.DO1COPY CORESOURCE (QUOTE {DSK}RANDOMDATA)
CORESOURCE))
(printout.SUBR DIAGNOSTICSRECORDSTREAM T
"Finished initializing the source file for DSKPROC"
T)
(\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC)) (* Then make a random number of copies, and then delete
them)
(to N
do (MAPC (bind SS DS to (SETQ NFILES (RAND 3 7))
collect (\LD.BLOCKCHECK (ITIMES 1000 (RAND 1 5))
(QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(DSKPROC.DO1COPY SOURCE (PACK* (QUOTE {DSK}TEMPRANDOMCOPY)
(SELECTC (RAND 1 5)
(1 "25.TXT")
(2 ".TXT")
(3 "MUMBLE")
(4 "2345.MUMBLE")
(5 "")
(SHOULDNT)))
CORESOURCE))
(FUNCTION (LAMBDA (FILE)
(\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(DELFILE FILE))))
(printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE {)
NFILES
(QUOTE }))))))
(DSKPROC.DO1COPY
(LAMBDA (SOURCE DESTINATION CORESOURCE) (* JonL "19-Dec-84 18:53")
(LET ((SS (OPENSTREAM SOURCE (QUOTE INPUT)))
(DS (OPENSTREAM DESTINATION (QUOTE OUTPUT)))
(FILELEN 0)
THISROUND)
(SETQ FILELEN (GETFILEINFO SS (QUOTE LENGTH)))
(bind (NBYTES _ FILELEN) while (IGREATERP NBYTES 0)
do (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(to (SETQ THISROUND (IMIN NBYTES 512)) do (BOUT DS (BIN SS)))
(add NBYTES (IMINUS THISROUND)))
(CLOSEF DS)
(\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(if CORESOURCE
then (CLOSEF SS)
(SETQ SS (OPENSTREAM CORESOURCE (QUOTE INPUT)))
else (SETFILEPTR SS 0))
(SETQ DS (OPENSTREAM DS (QUOTE INPUT))) (* Now compare the file to see that it "made it")
(if (NEQ FILELEN (GETFILEINFO DS (QUOTE LENGTH)))
then (!MRAID DESTINATION "DSK copy failure -- wrong length")
else (bind (NBYTES _ FILELEN)
(I _ -1) while (IGREATERP NBYTES 0)
do (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(to (SETQ THISROUND (IMIN NBYTES 512)) eachtime (PROG1 (add I 1)
(* Comment PPLossage)
)
when (NEQ (BIN SS)
(BIN DS))
do (!MRAID DESTINATION (CONCAT "DSK copy failure -- data different at filepos "
I))
(RETURN (SETQ THISROUND)))
(add NBYTES (IMINUS (OR THISROUND (RETURN))))))
(CLOSEF SS)
(CLOSEF DS)
(\LD.BLOCKCHECK 500 (QUOTE DSKPROC.AUX)
(QUOTE DSKPROC))
(FULLNAME DS))))
(ETHERPROC
(LAMBDA (N) (* JonL " 9-Dec-84 13:45")
(DECLARE (GLOBALVARS LOCAL.CLEARINGHOUSE))
(OR (FIXP N)
(SETQ N MAX.SMALLP))
(for I to N
bind (J _ 0)
(JF _ 0)
do (if (EVENP I 64)
then (\LD.BLOCKCHECK 1000 (QUOTE ETHERPROC))
(SETQ LOCAL.CLEARINGHOUSE)
(printout.SUBR DIAGNOSTICSRECORDSTREAM (if (CAR (LISTP (NLSETQ (START.CLEARINGHOUSE
T))))
then (QUOTE $)
else (QUOTE -))))
(if LOCAL.CLEARINGHOUSE
then (\LD.BLOCKCHECK (if (EVENP I 8)
then 1000
else NIL)
(QUOTE ETHERPROC))
(if (CAR (LISTP (NLSETQ (CH.LIST.ORGANIZATIONS))))
else (add JF 1))
(if (IGEQ (add J 1)
32)
then (SETQ J 1)
(printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE %[)
JF
(QUOTE %]))
(SETQ JF 0))
else (\LD.BLOCKCHECK 20000 (QUOTE ETHERPROC))
(SETQ LOCAL.CLEARINGHOUSE)
(NLSETQ (START.CLEARINGHOUSE T))))))
(DAEMONPROC
(LAMBDA (N) (* JonL " 7-Dec-84 01:37")
(OR (FIXP N)
(SETQ N MAX.SMALLP))
(to N
do (to (CONSTANT (QUOTIENT (TIMES 10 60)
10))
do (\LD.BLOCKCHECK 10000 (QUOTE DAEMONPROC)
(QUOTE DON'T)))
(* * Random perturbation of the working set every 10 minutes +or- a few seconds)
(\LD.BLOCKCHECK (ITIMES 1000 (RAND 5 10))
(QUOTE DAEMONPROC))
(\RELEASEWORKINGSET)
(printout.SUBR DIAGNOSTICSRECORDSTREAM T (GDATE)
T))))
)
(* "Various diagnostic and benchmark activities")
(DEFINEQ
(EMUPROC
(LAMBDA (N) (* JonL " 7-Dec-84 01:23")
(* Basically, just runs a lot of test of emulator 
instructons)
(OR (FIXP N)
(SETQ N MAX.SMALLP)) (* First, run the standard MACROTEST diagnostics)
(for RUN# to N
do (if (AND (GETD (QUOTE !NUMBERTEST))
(GETD (QUOTE CHECKFREELISTS)))
then (for TEST in (QUOTE (!NUMBERTEST !FNUMTEST !MIXNUMTEST !GCTEST !CONSTEST !FVARTEST
!INTERPTEST CHECKCONSPAGES CHECKFREELISTS
20RECLAIM CHECKFREELISTS))
do (\LD.BLOCKCHECK 500 (QUOTE EMUPROC))
(APPLY* TEST))
(printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE !)))
(\LD.BLOCKCHECK (ITIMES 1000 (RAND 1 5))
(QUOTE EMUPROC))
(\LD.TANSPEED)
(\LD.BLOCKCHECK (ITIMES 1000 (RAND 1 5))
(QUOTE EMUPROC))
(\LD.BROWSE)
(\LD.BLOCKCHECK 1000 (QUOTE EMUPROC))
(printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE %()
RUN#
(QUOTE %))))))
(20RECLAIM
(LAMBDA NIL (* JonL "28-Nov-84 13:52")
(FRPTQ 20 (RECLAIM))))
)
(* "After the TANSPEED benchmark")
(DEFINEQ
(\LD.TANSPEED
(LAMBDA NIL (* JonL " 7-Dec-84 01:22")
(* TANSPEED benchmark is a fairly good test of floating
point arithmetic also)
(for I F (A _ 1.0) from 0 to 2498
do (AND (EVENP I 32)
(\LD.BLOCKCHECK 500 (QUOTE EMUPROC)))
(SETQ A (FPLUS (TAN (ARCTAN (ANTILOG (LOG (SQRT (FTIMES A A))))
T)
T)
1.0))
finally (if (LESSP 25.0 (ABS (SETQ F (DIFFERENCE A 2500.0))))
then (!MRAID (LIST (QUOTE (TANSPEED))
(QUOTE =>)
F
(QUOTE should-have-been)
2476.246))
else (printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE @))))))
)
(* "Extraction from Gabriel's BROWSE benchmark")
(DEFINEQ
(\LD.BROWSE
(LAMBDA NIL (* JonL " 7-Dec-84 01:23")
(* Unfortunately, this has to be a copy of the code in 
BROWSE since we want to do the init phase only once)
(if !BROWSEINIT
else (SETQ !BROWSEINIT
(\LD.BROWSEINIT 100 10 4
(QUOTE ((A A A B B B B A A A A A B B A A A)
(A A B B B B A A (A A)
(B B))
(A A A B (B A)
B A B A))))))
(for UNITS
on (bind A N (RAND _ 21)
(L _ !BROWSEINIT) while L
do (\LD.BLOCKCHECK NIL (QUOTE EMUPROC))
(if (EQ 0 (SETQ N (IMOD (SETQ RAND (IMOD (ITIMES RAND 17)
251))
(LENGTH L))))
then (push A (pop L))
else (for N from N to 2 by -1 as X on L do NIL finally (PROGN (push A (CADR X))
(RPLACD X
(CDDR X)))))
finally (RETURN A))
do (for PATS on (QUOTE ((*A ?B *B ?B A *A A *B *A)
(*A *B *B *A (*A)
(*B))
(? ? *(B A)* ? ?)))
do (for P on (GETP (CAR UNITS)
(QUOTE PATTERN))
do (\LD.BLOCKCHECK NIL (QUOTE EMUPROC))
(\LD.BROWSEMATCH (CAR PATS)
(CAR P)
NIL))))
(printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE #))))
(\LD.BROWSEINIT
(LAMBDA (N M NPATS IPATS) (* JonL "30-Nov-84 22:50")
(SETQ IPATS (SUBST NIL NIL IPATS))
(bind (A _ NIL)
(LOSER _(LAST IPATS)) first (RPLACD LOSER IPATS) for old N from N to 1 by -1
as (I _ M) by (if (ZEROP I)
then M
else (SUB1 I))
as (NAME _(GENSYM)) by (GENSYM)
do (\LD.BLOCKCHECK NIL (QUOTE EMUPROC))
(push A NAME)
(RPTQ I (PUTPROP NAME (GENSYM)
NIL))
(PUTPROP NAME (QUOTE PATTERN)
(bind (A _ NIL) for I from NPATS to 1 by -1 as IPATS on IPATS
do (push A (CAR IPATS)) finally (RETURN A)))
(RPTQ (DIFFERENCE M I)
(PUTPROP NAME (GENSYM)
NIL))
finally (PROGN (* Just to break the circularity)
(RPLACD LOSER NIL)
(RETURN A)))))
(\LD.BROWSEMATCH
(LAMBDA (PAT DAT ALIST) (* JonL "25-FEB-83 13:38")
(COND
((NULL PAT)
(NULL DAT))
((NULL DAT)
NIL)
((OR (EQ (CAR PAT)
(QUOTE ?))
(EQ (CAR PAT)
(CAR DAT)))
(\LD.BROWSEMATCH (CDR PAT)
(CDR DAT)
ALIST))
((EQ (CAR PAT)
(QUOTE *))
(OR (\LD.BROWSEMATCH (CDR PAT)
DAT ALIST)
(\LD.BROWSEMATCH (CDR PAT)
(CDR DAT)
ALIST)
(\LD.BROWSEMATCH PAT (CDR DAT)
ALIST)))
(T (COND
((NLISTP (CAR PAT))
(COND
((EQ (CHAR1 (CAR PAT))
(QUOTE ?))
(PROG ((VAL (FASSOC (CAR PAT)
ALIST)))
(RETURN (COND
(VAL (\LD.BROWSEMATCH (CONS (CDR VAL)
(CDR PAT))
DAT ALIST))
(T (\LD.BROWSEMATCH (CDR PAT)
(CDR DAT)
(CONS (CONS (CAR PAT)
(CAR DAT))
ALIST)))))))
((EQ (CHAR1 (CAR PAT))
(QUOTE *))
(PROG ((VAL (FASSOC (CAR PAT)
ALIST)))
(RETURN (COND
(VAL (\LD.BROWSEMATCH (APPEND (CDR VAL)
(CDR PAT))
DAT ALIST))
(T (for (L _ NIL) by (NCONC L (LIST (CAR D))) as E
on (CONS NIL DAT) as (D _ DAT) by (CDR D)
do (COND
((\LD.BROWSEMATCH (CDR PAT)
D
(CONS (CONS (CAR PAT)
L)
ALIST))
(RETURN T)))))))))))
(T (AND (NOT (NLISTP (CAR DAT)))
(\LD.BROWSEMATCH (CAR PAT)
(CAR DAT)
ALIST)
(\LD.BROWSEMATCH (CDR PAT)
(CDR DAT)
ALIST))))))))
)
(RPAQQ !BROWSEINIT NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS !BROWSEINIT)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS CHAR1 MACRO ((X) (NTHCHAR X 1)))
)
)
(DECLARE: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY
(ADDTOVAR DISPLAYFONTEXTENSIONS STRIKE)
(ADDTOVAR DISPLAYFONTDIRECTORIES {FLOPPY})
(ADDTOVAR LISPUSERSDIRECTORIES {FLOPPY})
(RPAQQ !MTUSERAIDFLG NIL)
(FILESLOAD (COMPILED FROM VALUEOF LISPUSERSDIRECTORIES)
PAGEHOLD MACROTESTAUX MACROTEST PLURAL)
(MAKEDIAGNOSTICSMENU)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA printout.SUBR)
)
(PUTPROPS LISPDIAGNOSTICS COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2711 3681 (UNSHADEALLITEMS 2721 . 3006) (printout.SUBR 3008 . 3679)) (4453 13303 (
EXERCISE 4463 . 9943) (\LD.BLOCKCHECK 9945 . 11961) (\LD.STOPPROCS 11963 . 13301)) (13663 16365 (
MAKEDIAGNOSTICSMENU 13673 . 15632) (\LD.DCW.WHENSELECTED 15634 . 15824) (\LD.DPM.WHENSELECTED 15826 .
16363)) (17007 23842 (DSKPROC 17017 . 17977) (DSKPROC.AUX 17979 . 20024) (DSKPROC.DO1COPY 20026 .
21970) (ETHERPROC 21972 . 23219) (DAEMONPROC 23221 . 23840)) (23901 25276 (EMUPROC 23911 . 25131) (
20RECLAIM 25133 . 25274)) (25320 26202 (\LD.TANSPEED 25330 . 26200)) (26260 30754 (\LD.BROWSE 26270 .
27769) (\LD.BROWSEINIT 27771 . 28807) (\LD.BROWSEMATCH 28809 . 30752)))))
STOP

BIN
internal/envos/LISPDIAGNOSTICS.TEDIT Normal file
View File

Binary file not shown.

1741
internal/envos/NSMAIL Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
internal/envos/NSMAIL.TEDIT Normal file
View File

Binary file not shown.

96
internal/envos/READINTERPRESS Normal file
View File

@@ -0,0 +1,96 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Jun-90 18:59:13" {DSK}<usr>local>lde>lispcore>internal>library>READINTERPRESS.;2 16698
changes to%: (VARS READINTERPRESSCOMS)
previous date%: " 5-Jan-89 17:42:57"
{DSK}<usr>local>lde>lispcore>internal>library>READINTERPRESS.;1)
(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT READINTERPRESSCOMS)
(RPAQQ READINTERPRESSCOMS
[(* "Utilities for reading Interpress files")
(FNS PRINTMASTER)
(FNS OPCODE TOKEN FINDNONPRIMNAME FINDOPNAME SHORTINT TOKENFORMAT FINDSEQUENCETYPE PRINTTOKEN
PRINTSEQUENCE SEARCHIPLIST READINT.IP SHOWFILE SHOWBYTE)
(MACROS BIN.RIP)
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
INTERPRESS))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA SHORTINT TOKEN])
(* "Utilities for reading Interpress files")
(DEFINEQ
(PRINTMASTER
[LAMBDA (FILE OUTPUTFILE FROM TO) (* ; "Edited 1-Dec-88 12:51 by Briggs")
(RESETLST
(PROG (ISTREAM)
[RESETSAVE (SETQ ISTREAM (OPENSTREAM FILE 'INPUT))
'(PROGN (CLOSEF OLDVALUE]
[COND
(OUTPUTFILE (RESETSAVE (SETQ OUTPUTFILE (OPENSTREAM OUTPUTFILE 'OUTPUT))
'(PROGN (CLOSEF OLDVALUE)
(AND RESETSTATE (DELFILE OLDVALUE]
(* Print the encoding string)
(bind C until (EQ (SETQ C (BIN ISTREAM))
(CHARCODE SPACE)) do (PRINTCCODE C OUTPUTFILE))
(TERPRI OUTPUTFILE)
(SETFILEPTR ISTREAM (IMAX (\GETFILEPTR ISTREAM)
(OR FROM 0)))
(until (OR (EOFP ISTREAM)
(AND TO (IGEQ (\GETFILEPTR ISTREAM)
TO))) do (printout OUTPUTFILE |.I5| (GETFILEPTR
ISTREAM)
"|" 8)
(PRINTTOKEN ISTREAM OUTPUTFILE))))])
)
(DEFINEQ
(OPCODE
[LAMBDA (BYTE1 BYTE2) (* rmk%: "19-APR-83 17:51")
(FINDOPNAME (IPLUS (LLSH (LOGAND BYTE1 31)
8)
(OR BYTE2 0])
(TOKEN
[LAMBDA BYTES (* edited%: "20-APR-83 10:06")
(COND
((ZEROP BYTES)
NIL)
((NLISTP (ARG BYTES 1))
(APPLY (FUNCTION TOKEN)
(ARG BYTES 1)))
(T (SELECTQ (TOKENFORMAT (ARG BYTES 1))
(SHORTINT (APPLY (FUNCTION SHORTINT)
(for I from 1 to BYTES collect (ARG BYTES I))))
(SHORTOP (FINDOPNAME (LOGAND (ARG BYTES 1)
31)))
(LONGOP (FINDOPNAME (IPLUS (LLSH (LOGAND (ARG BYTES 1)
31)
8)
(OR (ARG BYTES 2)
0))))
(SHORTSEQUENCE [PROG [LEN (TYPE (FINDSEQUENCETYPE (LOGAND (ARG BYTES 1)
31]
(COND
((IGREATERP BYTES 0)
(SETQ LEN (ARG BYTES 2])
(LONGSEQUENCE)
(SHOULDNT])
(FINDNONPRIMNAME
[LAMBDA (CODE) (* rmk%: "15-Mar-84 09:07")
(SEARCHIPLIST CODE (CONSTANT NONPRIMS])
(FINDOPNAME
[LAMBDA (CODE) (* rmk%: "16-Jun-84 15:24")

242
internal/envos/RS232TEST Normal file
View File

@@ -0,0 +1,242 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "26-Jun-90 19:15:35" |{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;2| 9419
|changes| |to:| (VARS RS232TESTCOMS)
|previous| |date:| "20-Feb-87 00:10:14"
|{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;1|)
; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT RS232TESTCOMS)
(RPAQQ RS232TESTCOMS
((FNS RSTEST TESTCLEANUP XMITTEST)
(* |;;|
 "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(FNS RS232.TEST RS232.MICROTEST RS232.QUICKTEST RS232.MENU RS232TMENU.SELFN)
(VARS RS232.TEST.MENU.ITEMS)
(* |;;|
 "Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(FNS TTY.TEST TTY.MICROTEST TTY.QUICKTEST TTY.MENU TTYTMENU.SELFN)))
(DEFINEQ
(rstest
(lambda nil (* \; "Edited 14-Jan-87 16:00 by jds")
(let (oo)
(resetlst (resetsave (setq oo (openstream '{rs232} 'output))
'closef?)
(|for| i |from| 1 |do| (printout oo "Line " i
": 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
\
")
(printout t "Line " i t))))))
(testcleanup
(lambda nil (* \; "Edited 16-Jan-87 09:51 by jds")
(* |;;| "Close the streams used by the rs232 test.")
(and (boundp 'out)
out
(closef? out))
(and (boundp in)
in
(closef? in))))
(XMITTEST
(LAMBDA (BAUDRATE XONXOFF?) (* \; "Edited 19-Feb-87 20:59 by jds")
(* |;;| "Set up the rs232 port at BAUDRATE with XOn-XOff flow control if XONXOFF? is T. Then print forever, lines of text. Show an indication on the screen for each line, so the user can tell if flow control has shut things off.")
(RS232C.INIT BAUDRATE 8 'NONE 1 (COND
(XONXOFF? 'XONXOFF)
(T 'NONE)))
(SETQ OUT (OPENSTREAM '{RS232} 'OUTPUT))
(SETQ IN (OPENSTREAM '{RS232} 'INPUT))
(ERSETQ (FOR I FROM 1 DO (PRINTOUT OUT "Line " I ": 0 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
\
")
(|printout| T "Line " I T)))
(CLOSEF? OUT)
(CLOSEF? IN)))
)
(* |;;| "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(DEFINEQ
(rs232.test
(lambda nil (* \; "Edited 19-Feb-87 22:43 by jds")
(* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")
(printout t t t "Starting RS-232 port test." t
"Make sure the line monitor is attached to the RS-232 port, "
"and its cable goes to the DCE socket on the monitor." t)
(mouseconfirm)
(printout t "Set the line monitor for: " t)
(|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
|do| (|for| stopbits |in| '(1 1.5 2)
|do| (rs232.microtest 9600 bits parity stopbits))))))
(rs232.microtest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:37 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(printout t bits "bits, " (cond
((eq parity 'none)
"NO")
(t parity))
" parity, " stopbits " stop bits..." t)
(mouseconfirm)
(rs232.quicktest speed bits parity stopbits)))
(rs232.quicktest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:38 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(rs232c.init speed bits parity stopbits 'none)
(let ((out (openstream '{rs232} 'output)))
(prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
out)
(closef out))))
(rs232.menu
(lambda nil (* \; "Edited 19-Feb-87 22:45 by jds")
(let ((ww (addmenu (|create| menu
menucolumns _ 4
items _ rs232.test.menu.items
whenselectedfn _ (function rs232tmenu.selfn)))))
(windowprop ww 'title "RS-232 Tests"))))
(rs232tmenu.selfn
(lambda (item menu key) (* \; "Edited 19-Feb-87 22:57 by jds")
(* |;;| "Called from the RS-232 test menu")
(let* ((info (cadr item))
(bits (car info))
(parity (cadr info))
(stopbits (caddr info)))
(rs232.quicktest 9600 bits parity stopbits))))
)
(RPAQQ RS232.TEST.MENU.ITEMS
((|5/N/1| (5 NONE 1))
(|6/N/1| (6 NONE 1))
(|7/N/1| (7 NONE 1))
(|8/N/1| (8 NONE 1))
(|5/N/1.5| (5 NONE 1.5))
(|6/N/1.5| (6 NONE 1.5))
(|7/N/1.5| (7 NONE 1.5))
(|8/N/1.5| (8 NONE 1.5))
(|5/N/2| (5 NONE 2))
(|6/N/2| (6 NONE 2))
(|7/N/2| (7 NONE 2))
(|8/N/2| (8 NONE 2))
(|5/O/1| (5 ODD 1))
(|6/O/1| (6 ODD 1))
(|7/O/1| (7 ODD 1))
(|8/O/1| (8 ODD 1))
(|5/O/1.5| (5 ODD 1.5))
(|6/O/1.5| (6 ODD 1.5))
(|7/O/1.5| (7 ODD 1.5))
(|8/O/1.5| (8 ODD 1.5))
(|5/O/2| (5 ODD 2))
(|6/O/2| (6 ODD 2))
(|7/O/2| (7 ODD 2))
(|8/O/2| (8 ODD 2))
(|5/E/1| (5 EVEN 1))
(|6/E/1| (6 EVEN 1))
(|7/E/1| (7 EVEN 1))
(|8/E/1| (8 EVEN 1))
(|5/E/1.5| (5 EVEN 1.5))
(|6/E/1.5| (6 EVEN 1.5))
(|7/E/1.5| (7 EVEN 1.5))
(|8/E/1.5| (8 EVEN 1.5))
(|5/E/2| (5 EVEN 2))
(|6/E/2| (6 EVEN 2))
(|7/E/2| (7 EVEN 2))
(|8/E/2| (8 EVEN 2))))
(* |;;|
"Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(DEFINEQ
(tty.test
(lambda nil (* \; "Edited 19-Feb-87 22:42 by jds")
(* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")
(printout t t t "Starting TTY port test." t
"Make sure the line monitor is attached to the TTY port, "
"and its cable goes to the DTE socket on the monitor." t)
(mouseconfirm)
(printout t "Set the line monitor for: " t)
(|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
|do| (|for| stopbits |in| '(1 1.5 2)
|do| (tty.microtest 9600 bits parity stopbits))))))
(tty.microtest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:41 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(printout t bits "bits, " (cond
((eq parity 'none)
"NO")
(t parity))
" parity, " stopbits " stop bits..." t)
(mouseconfirm)
(tty.init speed bits parity stopbits)))
(tty.quicktest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:40 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(tty.init speed bits parity stopbits 'none)
(let ((out (openstream '{tty} 'output)))
(prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
out)
(closef out))))
(tty.menu
(lambda nil (* \; "Edited 19-Feb-87 22:57 by jds")
(let ((ww (addmenu (|create| menu
menucolumns _ 4
items _ rs232.test.menu.items
whenselectedfn _ (function ttytmenu.selfn)))))
(windowprop ww 'title "TTY Tests"))))
(ttytmenu.selfn
(lambda (item menu key) (* \; "Edited 19-Feb-87 22:59 by jds")
(* |;;| "Called from the RS-232 test menu")
(let* ((info (cadr item))
(bits (car info))
(parity (cadr info))
(stopbits (caddr info)))
(tty.quicktest 9600 bits parity stopbits))))
)
(PUTPROPS RS232TEST COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (979 2623 (RSTEST 989 . 1466) (TESTCLEANUP 1468 . 1789) (XMITTEST 1791 . 2621)) (2732
5433 (RS232.TEST 2742 . 3570) (RS232.MICROTEST 3572 . 4151) (RS232.QUICKTEST 4153 . 4640) (RS232.MENU
4642 . 5042) (RS232TMENU.SELFN 5044 . 5431)) (6665 9325 (TTY.TEST 6675 . 7493) (TTY.MICROTEST 7495 .
8061) (TTY.QUICKTEST 8063 . 8543) (TTY.MENU 8545 . 8938) (TTYTMENU.SELFN 8940 . 9323)))))
STOP

105
internal/envos/SKETCHCOLOR Normal file
View File

@@ -0,0 +1,105 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 19:20:18" {DSK}<usr>local>lde>lispcore>internal>library>SKETCHCOLOR.;2 4982
changes to%: (VARS SKETCHCOLORCOMS)
previous date%: " 9-Jan-87 16:47:16"
{DSK}<usr>local>lde>lispcore>internal>library>SKETCHCOLOR.;1)
(* ; "
Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT SKETCHCOLORCOMS)
(RPAQQ SKETCHCOLORCOMS ((FNS COLORTEXTURETEST LEVELTEXTURE PRIMARYTEXTURE)
(VARS (SKETCHINCOLORFLG T))
(FILES COLOR STYLESHEET)
(ADVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)))
(DEFINEQ
(COLORTEXTURETEST
[LAMBDA (W) (* rrb "22-Aug-85 10:16")
(* puts up a test pattern of primary
 colors.)
(PROG ((LFT 90))
(CLEARW W)
(for BLUELEVEL from 94 by 50 to 300
do (printout W "BLUE: " BLUELEVEL " " 'RED)
(DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W)
50)
W)
(DSPXPOSITION 0 W)
(for GREENLEVEL from 94 by 50 to 300
do (printout W "Green: " GREENLEVEL)
[for REDLEVEL from 94 by 50 to 300
do (BITBLT NIL 0 0 W (DIFFERENCE REDLEVEL 20)
(DSPYPOSITION NIL W)
45 45 'TEXTURE 'REPLACE (TEXTUREOFCOLOR (LIST REDLEVEL GREENLEVEL
BLUELEVEL]
(DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W)
50)
W)
(DSPXPOSITION 0 W])
(LEVELTEXTURE
[LAMBDA (LEVEL) (* rrb "20-Aug-85 16:42")
(* returns a |16x16| texture which is merged so that only light bits on both go
 to light with a primary color pattern to get a level primary pattern.)
(COND
((ILESSP LEVEL 100)
BLACKSHADE16)
((ILESSP LEVEL 150)
DARKGRAY16)
((ILESSP LEVEL 200)
MEDIUMGRAY16)
((ILESSP LEVEL 245)
LIGHTGRAY16)
(T WHITESHADE16])
(PRIMARYTEXTURE
[LAMBDA (PRIMARY LEVEL) (* rrb "20-Aug-85 16:42")
(* returns the |16x16| texture for a
 primary color level.)
(PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY
(RED REDTEXTURE)
(BLUE BLUETEXTURE)
(GREEN GREENTEXTURE)
(\ILLEGAL.ARG PRIMARY]
(BITBLT (LEVELTEXTURE LEVEL)
0 0 TEXTURE 0 0 16 16 'INPUT 'ERASE)
(RETURN TEXTURE])
)
(RPAQQ SKETCHINCOLORFLG T)
(FILESLOAD COLOR STYLESHEET)
[XCL:REINSTALL-ADVICE '\FILLCIRCLE.DISPLAY :BEFORE '((:LAST (COND
((LISTP TEXTURE)
(COND
((TEXTUREP (CAR TEXTURE))
(SETQ TEXTURE (CAR TEXTURE)))
(T (SETQ TEXTURE
(TEXTUREOFCOLOR (CADR TEXTURE]
[XCL:REINSTALL-ADVICE '\POLYSHADE.DISPLAY :BEFORE '((:LAST (COND
((LISTP FILL.SHADE)
(COND
((TEXTUREP (CAR FILL.SHADE))
(SETQ FILL.SHADE (CAR FILL.SHADE))
)
(T (SETQ FILL.SHADE
(TEXTUREOFCOLOR (CADR
FILL.SHADE
]
(READVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)
(PUTPROPS SKETCHCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (719 3316 (COLORTEXTURETEST 729 . 2076) (LEVELTEXTURE 2078 . 2610) (PRIMARYTEXTURE 2612
. 3314)))))
STOP

109
internal/envos/SOURCELOOKUP Normal file
View File

@@ -0,0 +1,109 @@
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
(FILECREATED "26-Mar-87 09:52:19" {ERIS}<LISPCORE>LIBRARY>INTERNAL>SOURCELOOKUP.;1 5861
previous date%: "21-Jan-86 09:49:57" {ERIS}<JAMES>KOTO>SOURCELOOKUP.;2)
(* "
Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT SOURCELOOKUPCOMS)
(RPAQQ SOURCELOOKUPCOMS ((VARS KotoSourceIndex)
(FNS LOCATE.FUNCTION LOCATE.FILE)
(FILES WHEREIS)))
(RPAQQ KotoSourceIndex
((|KOTO SOURCES #1| 10MBDRIVER 4045STREAM AARITH ABASIC ACODE ADDARITH ADIR ADVISE AERROR
AFONT AINTERRUPT AOFD)
(|KOTO SOURCES #2| ADISPLAY APRINT APUTDQ ASSIST ASTACK BIG BITMAPFNS BRKDWN BUSEXTENDER)
(|KOTO SOURCES #3| ATERM ATTACHEDWINDOW BREAK BROWSER BSP CENTRONICS)
(|KOTO SOURCES #4| ATBL BUSMASTER BYTECOMPILER CHAT CIRCLPRINT)
(|KOTO SOURCES #5| C150STREAM CHATTERMINAL CHECKSET CLISP CLISPIFY CML CMLARITH CMLFLOATARRAY
CMLSETF)
(|KOTO SOURCES #6| CMLARRAY CMLARRAYINSPECTOR CMLCHARACTER CMLCOMPILE CMLEXEC CMLHELP
CMLPRETTY CMLPRINT CMLSPECIALFORMS CMLSTREAMS CMLSTRUCT CMLTYPES COLOR COLORDEMO
COMPATIBILITY)
(|KOTO SOURCES #7| COMMENT COMMON COMPILE COMPILEBANG COPYFILES COREIO COURIER DATABASEFNS
DEDIT DEXEC)
(|KOTO SOURCES #8| DECL DES DFILE DINFO DISKDLION DLAP)
(|KOTO SOURCES #9| DLFIXINIT DLRS232C DLTTY DMCHAT DMISC DORADOCOLOR DOVEDECLS DOVEDISK
DOVEDISPLAY DOVEDISPLAYHACK DSKDISPLAY)
(|KOTO SOURCES #10| DPUPFTP DWIMIFY EDITBITMAP)
(|KOTO SOURCES #11| DOVEETHER DOVEFLOPPY DOVEINPUTOUTPUT EDIT FILECACHE HLCOLOR)
(|KOTO SOURCES #12| DOVEMISC DSPRINTDEF DTDECLARE DWIM ETHERRECORDS FILEBROWSER FILEIO
FILESETS)
(|KOTO SOURCES #13| FLOPPY)
(|KOTO SOURCES #14| FASTFX80STREAM FILEPKG FONT FONTSAMPLE ICONW)
(|KOTO SOURCES #15| FREEMENU FX80STREAM GCHAX GRAPHER)
(|KOTO SOURCES #16| FTPSERVER FXPRINTER GRAPHZOOM HARDCOPY HASH HIST HPRINT)
(|KOTO SOURCES #17| HELPDL HELPSYS HLDISPLAY HRULE IDLER IMAGEIO IMAGEOBJ INSPECT)
(|KOTO SOURCES #18| INTERPRESS IOCHAR IRISCONSTANTS IRISIO IRISNET IRISSTREAM LAMBDATRAN)
(|KOTO SOURCES #19| IRISLIB KERMIT KERMITMENU KEYBOARDEDITOR LABEL LISTEN LLARITH LLSUBRS)
(|KOTO SOURCES #20| LEAF LLARRAYELT LLBFS LLCODE)
(|KOTO SOURCES #21| LLBASIC LLBIGNUM LLCHAR LLCOLOR LLDATATYPE LLFCOMPILE MACROAUX)
(|KOTO SOURCES #22| LLDISPLAY LLETHER LLFLOAT LOADIRIS)
(|KOTO SOURCES #23| LLFAULT LLGC LLINTERP LLKEY)
(|KOTO SOURCES #24| LLHUNK LLNEW LLNS LLNSDECLS LLPARAMS LLREAD LLSTK LLTIMER LOADFNS MEM
POSTLOADUP)
(|KOTO SOURCES #25| LOCALFILE MACHINEINDEPENDENT MACROS PUPCHAT)
(|KOTO SOURCES #26| MAKEINIT MASTERSCOPE MATCH MATMULT MENU MISC)
(|KOTO SOURCES #27| MINISERVE MOD44IO MSANALYZE NEWPRINTDEF PCALLSTATS PRETTY)
(|KOTO SOURCES #28| NSCHAT PRESS PROC PUP)
(|KOTO SOURCES #29| MODARITH MSPARSE NSPRINT PASSWORDS PMAP PUPPRINT RDSYS READAIS READNUMBER
READSYS REMOTEVMEM RENAMEMACROS TEDITABBREV)
(|KOTO SOURCES #30| RECORD RENAMEFNS RESOURCE RS232CHAT RS232CMENU SAMEDIR
SCAVENGEDSKDIRECTORY SFFONT SIMPLIFY SKETCHEDIT SKETCHOBJ TEDITCHAT)
(|KOTO SOURCES #31| SKETCHELEMENTS SPELL)
(|KOTO SOURCES #32| SKETCHSTREAM SPLICE SPP SPY SYSEDIT TABLEBROWSER TEDIT TEDITHISTORY)
(|KOTO SOURCES #33| TEDITFILE TEDITLOOKS TEDITPAGE VMEM)
(|KOTO SOURCES #34| TEDITMENU TEDITWINDOW VT100KP)
(|KOTO SOURCES #35| TEDITCOMMAND TEDITFIND TEDITFNKEYS TEDITHCPY TEDITSCREEN TEK4010CHAT
XXGEOM)
(|KOTO SOURCES #36| TEDITSELECTION TELERAID TEXEC TEXTOFD TFBRAVO)
(|KOTO SOURCES #37| TRSERVER TTYCHAT TTYIN UNDO VANILLADISK WTFIX)
(|KOTO SOURCES #38| VIRTUALKEYBOARDS WBREAK WINDOW XXFILL)
(|KOTO SOURCES #39| SKETCH)
(|KOTO SOURCES #40| SKETCH VTCHAT WEDIT WHEREIS)))
(DEFINEQ
(LOCATE.FUNCTION
[LAMBDA (FUNC QUIETFLG) (* ckj "21-Jan-86 09:49")
(* * finds which Koto source file and floppy FUNC is defined on)
(* * KotoSourceIndex is a list where each element is a list whose car is a
 floppy name and cdr is the floppy contents)
(PROG (WhichFile? WhichFloppy?)
(SETQ WhichFile? (CAR (WHEREIS FUNC NIL T)))
(if WhichFile?
then (SETQ WhichFloppy? (LOCATE.FILE WhichFile? KotoSourceIndex))
else (if (NOT QUIETFLG)
then (printout T .FONT BOLDFONT FUNC .FONT DEFAULTFONT " not found." T))
(RETURN))
(if (NOT QUIETFLG)
then (printout T "The function " .FONT BOLDFONT FUNC .FONT DEFAULTFONT
" is defined in the file " .FONT BOLDFONT WhichFile? .FONT DEFAULTFONT
" located on floppy " .FONT BOLDFONT WhichFloppy? .FONT DEFAULTFONT "." T))
(RETURN (LIST WhichFile? WhichFloppy?])
(LOCATE.FILE
[LAMBDA (FILENAME FLOPPYINDEX) (* DERING " 8-Jan-85 14:05")
(* * FLOPPYINDEX IS A LIST WHERE EACH ELEMENT IS A LIST WHOSE CAR IS THE FLOPPY
 NAME AND CDR IS THE FILES RESIDING ON THE FLOPPY.)
(COND
((NULL (CAR FLOPPYINDEX))
NIL)
((EQMEMB FILENAME (CAR FLOPPYINDEX))
(CAAR FLOPPYINDEX))
(T (LOCATE.FILE FILENAME (CDR FLOPPYINDEX])
)
(FILESLOAD WHEREIS)
(PUTPROPS SOURCELOOKUP COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4149 5747 (LOCATE.FUNCTION 4159 . 5274) (LOCATE.FILE 5276 . 5745)))))
STOP

BIN
internal/envos/SOURCELOOKUP.TEDIT Normal file
View File

Binary file not shown.

54
internal/envos/STACKHACK Normal file
View File

@@ -0,0 +1,54 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "26-Jun-90 19:26:19" |{DSK}<usr>local>lde>lispcore>internal>library>STACKHACK.;2| 2119
|changes| |to:| (VARS STACKHACKCOMS)
|previous| |date:| "11-May-88 11:28:17"
|{DSK}<usr>local>lde>lispcore>internal>library>STACKHACK.;1|)
; Copyright (c) 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT STACKHACKCOMS)
(RPAQQ STACKHACKCOMS ((FNS DO-SKIP-FRAMES SKIP-FRAMES FRAGMENT-STACK)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA DO-SKIP-FRAMES)))))
(DEFINEQ
(do-skip-frames
(lambda i (* \; "Edited 7-Mar-88 15:35 by ") (envapply (quote skip-frames) (list (arg i 1) (arg i 2)) (quote skip-frames) (quote skip-frames)))
)
(skip-frames
(lambda (n fn) (* \; "Edited 11-May-88 11:19 by MASINTER")
(* \;
 "create some stack with N holes and then call FN")
(|if| (zerop n)
|then| (cl:funcall fn)
|else| (cl:macrolet ((longcall (fn &rest args)
`(apply ',fn (list* ,@args ',(|to| 500 |collect| nil)))
))
(longcall do-skip-frames (sub1 n)
fn)))))
(fragment-stack
(lambda nil (* \; "Edited 11-May-88 11:27 by MASINTER")
(add.process '(do (skip-frames 10 (function (lambda nil
(dismiss 5000))))))))
)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA DO-SKIP-FRAMES)
)
(PUTPROPS STACKHACK COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (770 1878 (DO-SKIP-FRAMES 780 . 946) (SKIP-FRAMES 948 . 1602) (FRAGMENT-STACK 1604 .
1876)))))
STOP

401
internal/envos/TEDITCOLOR Normal file
View File

@@ -0,0 +1,401 @@
(FILECREATED "26-Feb-86 10:59:11" {ERIS}<LISPCORE>LIBRARY>TEDITCOLOR.;3 26648
changes to: (VARS TEDITCOLORCOMS)
previous date: "26-Feb-86 10:44:36" {ERIS}<LISPCORE>LIBRARY>TEDITCOLOR.;1)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TEDITCOLORCOMS)
(RPAQQ TEDITCOLORCOMS ((* * These function definitions should be added to IMAGEOBJ, TEDITSCREEN,
and TEDITWINDOW. They have been tested to the point of creating,
putting, and getting color TEDIT files. \TEDIT.SLOWBLTCHAR is a new
function. *)
(* * NOTE: The MACRO property for SCREENBITMAP was eliminated 25-FEB.
Either LOAD the new EXPORTS.ALL or just (REMPROP (QUOTE SCREENBITMAP)
(QUOTE MACRO))
so that the IMAGEOBJ functions will compile correctly. *)
(COMS (* * Modifications to IMAGEOBJ. *)
(FNS BITMAPOBJ.SNAPW COERCETOBITMAP))
(COMS (* * Modifications to TEDITSCREEN. (\TEDIT.SLOWBLTCHAR is a new
function.)
*)
(FNS \TEDIT.BLTCHAR \TEDIT.SLOWBLTCHAR \TEDIT.CREATE.LINECACHE
\TEDIT.LINECACHE))
(COMS (* * Modifications to TEDITWINDOW. *)
(FNS TEDIT.MINIMAL.WINDOW.SETUP))))
(* * These function definitions should be added to IMAGEOBJ, TEDITSCREEN, and TEDITWINDOW.
They have been tested to the point of creating, putting, and getting color TEDIT files.
\TEDIT.SLOWBLTCHAR is a new function. *)
(* * NOTE: The MACRO property for SCREENBITMAP was eliminated 25-FEB. Either LOAD the new
EXPORTS.ALL or just (REMPROP (QUOTE SCREENBITMAP) (QUOTE MACRO)) so that the IMAGEOBJ functions
will compile correctly. *)
(* * Modifications to IMAGEOBJ. *)
(DEFINEQ
(BITMAPOBJ.SNAPW
(LAMBDA NIL (* kbr:
"25-Feb-86 17:06")
(* * makes an image object of a prompted for region of the screen.)
(PROG (SCREENREGION SCREEN REGION BM)
(SETQ SCREENREGION (GETSCREENREGION))
(SETQ SCREEN (fetch (SCREENREGION SCREEN) of SCREENREGION))
(SETQ REGION (fetch (SCREENREGION REGION) of SCREENREGION))
(SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REGION)
(fetch (REGION HEIGHT) of REGION)
(BITSPERPIXEL (SCREENBITMAP SCREEN))))
(BITBLT (SCREENBITMAP SCREEN)
(fetch (REGION LEFT) of REGION)
(fetch (REGION BOTTOM) of REGION)
BM 0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
(COPYINSERT (BITMAPTEDITOBJ BM 1 0)))))
(COERCETOBITMAP
(LAMBDA (BMSPEC) (* kbr:
"25-Feb-86 17:09")
(* tries to interpret
X as a spec for a
bitmap.)
(PROG (BM CR)
(RETURN (COND
((BITMAPP BMSPEC)
BMSPEC)
((LITATOM BMSPEC) (* use value.)
(COND
((BITMAPP (EVALV BMSPEC (QUOTE COERCETOBITMAP))))))
((REGIONP BMSPEC) (* if BMSPEC is a
region, treat it as a
region of the screen.)
(SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC)
(fetch (REGION HEIGHT) of BMSPEC)
(BITSPERPIXEL (SCREENBITMAP))))
(BITBLT (SCREENBITMAP)
(fetch (REGION LEFT) of BMSPEC)
(fetch (REGION BOTTOM) of BMSPEC)
BM 0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
BM)
((type? SCREENREGION BMSPEC) (* if BMSPEC is a
screenregion)
(SETQ BM (BITMAPCREATE (fetch (SCREENREGION WIDTH) of BMSPEC)
(fetch (SCREENREGION HEIGHT) of BMSPEC)
(BITSPERPIXEL (SCREENBITMAP (fetch (SCREENREGION SCREEN)
of BMSPEC)))))
(BITBLT (SCREENBITMAP (fetch (SCREENREGION SCREEN) of BMSPEC))
(fetch (SCREENREGION LEFT) of BMSPEC)
(fetch (SCREENREGION BOTTOM) of BMSPEC)
BM 0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE))
BM)
((WINDOWP BMSPEC)
(SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC (QUOTE WIDTH))
(WINDOWPROP BMSPEC (QUOTE HEIGHT))
(BITSPERPIXEL BMSPEC))) (* open the window and
bring it to the top.)
(TOTOPW BMSPEC)
(SETQ CR (DSPCLIPPINGREGION NIL BMSPEC))
(BITBLT BMSPEC (fetch LEFT of CR)
(fetch BOTTOM of CR)
BM 0 0 (fetch WIDTH of CR)
(fetch HEIGHT of CR))
BM))))))
)
(* * Modifications to TEDITSCREEN. (\TEDIT.SLOWBLTCHAR is a new function.) *)
(DEFINEQ
(\TEDIT.BLTCHAR
(LAMBDA (CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT)
(* kbr:
"25-Feb-86 22:40")
(* Version of \BLTCHAR
peculiar to TEdit --
relies on \DISPLAYLINE
to make sure things keep
working right.)
(* puts a character on a guaranteed display stream.
Much of the information needed by the BitBlt microcode is prestored by the
routines that change it. This is kept in the BitBltTable.)
(* knows about the
representation of
display stream image
data)
(* MUST NOT POINT AT A
WINDOW'S
DISPLAYSTREAM!!!)
(* ASSUMES THAT WE NEVER WANT TO PRINT TO THE LEFT OF ORIGIN 0 ON THE
LINE CACHE BITMAP, OR THAT IF WE DO, ALL BETS ARE OFF)
(DECLARE (LOCALVARS . T))
(PROG (CHAR8CODE NEWX LEFT RIGHT IMAGEWIDTH)
(SETQ CHAR8CODE (\CHAR8CODE CHARCODE))
(COND
((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA)
(\CHARSET CHARCODE)))
(\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE))))
(COND
((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA)
(RETURN (\TEDIT.SLOWBLTCHAR CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT
CLIPRIGHT))))
(SETQ IMAGEWIDTH (\GETBASE (fetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of DISPLAYDATA)
(\CHAR8CODE CHARCODE)))
(SETQ NEWX (IPLUS CURX IMAGEWIDTH))
(SETQ LEFT (IMAX 0 CURX))
(SETQ RIGHT (IMIN CLIPRIGHT NEWX))
(COND
((ILESSP LEFT RIGHT) (* Only print anything
if there is a place to
put it)
(UNINTERRUPTABLY
(freplace (PILOTBBT PBTDESTBIT) of DDPILOTBBT with LEFT)
(* Set up the
bitblt-table source
left)
(freplace (PILOTBBT PBTWIDTH) of DDPILOTBBT with (IMIN IMAGEWIDTH
(IDIFFERENCE
RIGHT LEFT)))
(freplace (PILOTBBT PBTSOURCEBIT) of DDPILOTBBT
with (\GETBASE (fetch (\DISPLAYDATA DDOFFSETSCACHE) of DISPLAYDATA)
(\CHAR8CODE CHARCODE)))
(\PILOTBITBLT DDPILOTBBT 0))
(RETURN T))))))
(\TEDIT.SLOWBLTCHAR
(LAMBDA (CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT)
(* kbr:
"25-Feb-86 22:40")
(* Version of
\SLOWBLTCHAR peculiar to
TEdit -- relies on
\DISPLAYLINE to make
sure things keep working
right. Does not handle
rotated fonts.)
(PROG (CHAR8CODE NEWX LEFT RIGHT IMAGEWIDTH DESTBIT WIDTH SOURCEBIT)
(SETQ CHAR8CODE (\CHAR8CODE CHARCODE))
(SETQ IMAGEWIDTH (\GETBASE (fetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of DISPLAYDATA)
(\CHAR8CODE CHARCODE)))
(SETQ NEWX (IPLUS CURX IMAGEWIDTH))
(SETQ LEFT (IMAX 0 CURX))
(SETQ RIGHT (IMIN CLIPRIGHT NEWX))
(COND
((ILESSP LEFT RIGHT)
(SETQ DESTBIT LEFT)
(SETQ WIDTH (IDIFFERENCE RIGHT LEFT))
(SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DISPLAYDATA)
LEFT)
CURX))
(SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA
DDDestination)
of DISPLAYDATA))
(1)
(4 (SETQ DESTBIT (LLSH DESTBIT 2))
(SETQ WIDTH (LLSH WIDTH 2))
(SETQ SOURCEBIT (LLSH SOURCEBIT 2)))
(8 (SETQ DESTBIT (LLSH DESTBIT 3))
(SETQ WIDTH (LLSH WIDTH 3))
(SETQ SOURCEBIT (LLSH SOURCEBIT 3)))
(24 (SETQ DESTBIT (ITIMES 24 DESTBIT))
(SETQ WIDTH (ITIMES 24 WIDTH))
(SETQ SOURCEBIT (ITIMES 24 SOURCEBIT)))
(SHOULDNT))
(.WHILE.TOP.DS. DISPLAYSTREAM (freplace (PILOTBBT PBTDESTBIT) of DDPILOTBBT
with DESTBIT)
(freplace (PILOTBBT PBTWIDTH) of DDPILOTBBT with WIDTH)
(freplace (PILOTBBT PBTSOURCEBIT) of DDPILOTBBT with SOURCEBIT)
(\PILOTBITBLT DDPILOTBBT 0))
(RETURN T))))))
(\TEDIT.CREATE.LINECACHE
(LAMBDA (#CACHES BITSPERPIXEL) (* kbr:
"25-Feb-86 18:47")
(* Create a
linked-together set of
LINECACHEs, for saving
line images.)
(PROG ((CACHES (for I from 1 to #CACHES collect (create LINECACHE
LCBITMAP _(BITMAPCREATE
100 15
BITSPERPIXEL)))
))
(for CACHE on CACHES do (* Link the caches
together.)
(replace LCNEXTCACHE of (CAR CACHE)
with (OR (CADR CACHE)
(CAR CACHES))))
(RETURN CACHES))))
(\TEDIT.LINECACHE
(LAMBDA (CACHE WIDTH HEIGHT) (* kbr:
"25-Feb-86 18:48")
(* Given a candidate
line cache, return the
bitmap, making sure it's
at least WIDTH by HEIGHT
big.)
(PROG ((BITMAP (fetch LCBITMAP of CACHE))
CW CH)
(SETQ CW (fetch BITMAPWIDTH of BITMAP))
(SETQ CH (fetch BITMAPHEIGHT of BITMAP))
(COND
((AND (IGEQ CW WIDTH)
(IGEQ CH HEIGHT))
(RETURN BITMAP))
(T (RETURN (replace LCBITMAP of CACHE with (BITMAPCREATE (IMAX CW WIDTH)
(IMAX CH HEIGHT)
(BITSPERPIXEL BITMAP))))))
)))
)
(* * Modifications to TEDITWINDOW. *)
(DEFINEQ
(TEDIT.MINIMAL.WINDOW.SETUP
(LAMBDA (WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW) (* kbr:
"25-Feb-86 18:46")
(* Do the absolute
minimum setup so that
TEXTOBJ and WINDOW know
about each other.
Does NOT include mouse
interface or scrolling.)
(* If AFTERWINDOW is non-NIL, the new window will be placed after
AFTERWINDOW in the TEXTOBJ's list. This lists us maintain an ordering of
windows, for splitting and unsplitting.)
(PROG ((SEL (fetch SEL of TEXTOBJ))
TEDITPROMPTWINDOW DS PROP TWIDTH THEIGHT LINES OLDWINDOWS)
(OR WINDOW (\ILLEGAL.ARG WINDOW))
(replace (TEDITCARET TCCARETDS) of (COND
((LISTP (fetch CARET of TEXTOBJ))
(CAR (FLAST (fetch CARET of TEXTOBJ)
)))
(T (fetch CARET of TEXTOBJ)))
with (WINDOWPROP WINDOW (QUOTE DSP))) (* The displaystream
for flashing the caret)
(replace SELWINDOW of TEXTOBJ with WINDOW)
(WINDOWPROP WINDOW (QUOTE PROCESS)
NIL) (* For the moment,
this window has no
process)
(WINDOWPROP WINDOW (QUOTE TEDIT.PROPS)
PROPS) (* Put the props on
the window for others
... **this should go**)
(WINDOWPROP WINDOW (QUOTE TEXTSTREAM)
TEXTSTREAM) (* Save the text
stream for the user to
get at via the window.)
(WINDOWPROP WINDOW (QUOTE TEXTOBJ)
TEXTOBJ) (* Give a handle on
the TEXTOBJ for the text
being edited.)
(WINDOWPROP WINDOW (QUOTE TEDIT.CURSORREGION)
(LIST 0 0 0 0)) (* Used by
CursorMovedFn)
(WINDOWPROP WINDOW (QUOTE CURSORMOVEDFN)
(FUNCTION TEDIT.CURSORMOVEDFN))
(WINDOWPROP WINDOW (QUOTE CURSOROUTFN)
(FUNCTION TEDIT.CURSOROUTFN))
(SETQ DS (WINDOWPROP WINDOW (QUOTE DSP)))
(DSPRIGHTMARGIN 32767 DS) (* So we don't get
spurious RETURNs printed
out by the system)
(SETQ OLDWINDOWS (fetch \WINDOW of TEXTOBJ))
(replace \WINDOW of TEXTOBJ
with (COND
((LISTP OLDWINDOWS) (* There are windows
already. Add this to the
list.)
(COND
(AFTERWINDOW (* We know which
window to put it after.
Put it there)
(RPLACD (FMEMB AFTERWINDOW OLDWINDOWS)
(CONS WINDOW (CDR (FMEMB AFTERWINDOW OLDWINDOWS)))))
(T (* Otherwise, just add
it at the end of the
list)
(NCONC1 OLDWINDOWS WINDOW))))
(WINDOW (LIST WINDOW))))
(replace DISPLAYCACHE of TEXTOBJ with (CAR (\TEDIT.CREATE.LINECACHE
1
(BITSPERPIXEL WINDOW))))
(* and a CACHE for
creating line images for
display)
(replace DISPLAYCACHEDS of TEXTOBJ with (DSPCREATE (fetch LCBITMAP
of (fetch
DISPLAYCACHE
of TEXTOBJ)
)))
(* A displaystream for
changeing the image
caches)
(DSPOPERATION (QUOTE PAINT)
(fetch DISPLAYCACHEDS of TEXTOBJ))
(DSPCLIPPINGREGION (create REGION
LEFT _ 0
BOTTOM _ 0
WIDTH _ 100
HEIGHT _ 15)
(fetch DISPLAYCACHEDS of TEXTOBJ)) (* Remember its size,
too.)
(COND
((SETQ PROP (LISTGET PROPS (QUOTE REGION))) (* The caller wants to
set a region.
Use his)
(replace WTOP of TEXTOBJ with (fetch PTOP of PROP))
(replace WRIGHT of TEXTOBJ with (fetch RIGHT of PROP))
(replace WBOTTOM of TEXTOBJ with (fetch BOTTOM of PROP))
(replace WLEFT of TEXTOBJ with (fetch LEFT of PROP)))
(T (* Otherwise, default
to the whole window)
(replace WLEFT of TEXTOBJ with 0)
(replace WBOTTOM of TEXTOBJ with 0)
(replace WTOP of TEXTOBJ with (fetch HEIGHT of (DSPCLIPPINGREGION
NIL DS)))
(replace WRIGHT of TEXTOBJ with (fetch WIDTH of (
DSPCLIPPINGREGION
NIL DS)))))
(SETQ LINES (\SHOWTEXT TEXTOBJ NIL WINDOW))
(WINDOWPROP WINDOW (QUOTE LINES)
LINES) (* Display the text in
the window, for later
use.)
(replace LINES of TEXTOBJ with (COND
(AFTERWINDOW
(for LINE
in (fetch LINES of TEXTOBJ)
as WINDOW in OLDWINDOWS
join (COND
((EQ WINDOW AFTERWINDOW)
(LIST LINE LINES))
(T (LIST LINE)))))
((LISTP (fetch LINES of TEXTOBJ))
(NCONC1 (fetch LINES of TEXTOBJ)
LINES))
(LINES (LIST LINES))))
(\FIXSEL SEL TEXTOBJ)
(TEDIT.NORMALIZECARET TEXTOBJ SEL)
(\SHOWSEL SEL NIL T)
(\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW)
(\COPYSEL SEL TEDIT.SELECTION))))
)
(PUTPROPS TEDITCOLOR COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2176 6545 (BITMAPOBJ.SNAPW 2186 . 3223) (COERCETOBITMAP 3225 . 6543)) (6630 16302 (
\TEDIT.BLTCHAR 6640 . 10617) (\TEDIT.SLOWBLTCHAR 10619 . 13567) (\TEDIT.CREATE.LINECACHE 13569 . 15010
) (\TEDIT.LINECACHE 15012 . 16300)) (16347 26567 (TEDIT.MINIMAL.WINDOW.SETUP 16357 . 26565)))))
STOP

194
internal/envos/USPS Normal file
View File

@@ -0,0 +1,194 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 19:31:43" |{DSK}<usr>local>lde>lispcore>internal>library>USPS.;2| 9175
|changes| |to:| (VARS USPSCOMS)
|previous| |date:| "13-Feb-89 13:49:35" |{DSK}<usr>local>lde>lispcore>internal>library>USPS.;1|
)
; Copyright (c) 1989, 1990 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT USPSCOMS)
(RPAQQ USPSCOMS
(
(* |;;| "Image Objects and functions for dealing with various kinds of mail.")
(COMS
(* |;;| "FIMs -- \"Facing Identification Marks\" used with Business Reply Mail. The top of a FIM must be within 1/8\" of the top of the envelope or card, and the right edge of the FIM must be 2\" +/- 1/8\" from the right edge of the card. You can tilt the FIM no more than 5 degrees from vertical.")
(FNS USPS-FIM.BUTTONEVENTINFN USPS-FIM.COPYFN USPS-FIM.CREATE USPS-FIM.CREATE.MENU
USPS-FIM.DISPLAYFN USPS-FIM.GETFN3 USPS-FIM.IMAGEBOXFN USPS-FIM.INIT
USPS-FIM.PUTFN)
(GLOBALVARS USPS-FIM.IMAGEFNS USPS-FIM.MENU
(USPS-FIM.STYLES '((A T T NIL NIL T NIL NIL T T)
(B T NIL T T NIL T T NIL T)
(C T T NIL T NIL T NIL T T)
(D T T T NIL T NIL T T T))))
(P (USPS-FIM.INIT)))))
(* |;;| "Image Objects and functions for dealing with various kinds of mail.")
(* |;;|
"FIMs -- \"Facing Identification Marks\" used with Business Reply Mail. The top of a FIM must be within 1/8\" of the top of the envelope or card, and the right edge of the FIM must be 2\" +/- 1/8\" from the right edge of the card. You can tilt the FIM no more than 5 degrees from vertical."
)
(DEFINEQ
(USPS-FIM.BUTTONEVENTINFN
(LAMBDA (IMAGEOBJ WINDOW SELECTION X Y SELWINDOW TEXTSTREAM BUTTON OPERATION)
(* \; "Edited 13-Feb-89 12:29 by jds")
(* |;;;| "the user has pressed a button inside the bitmap object IMAGEOBJ. Bring up a menu of bitmap edit operations.")
(PROG* ((FIM-STYLE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)))
(COND
((OR (EQ BUTTON 'RIGHT)
(AND OPERATION (NEQ OPERATION 'NORMAL))) (* \; " If he's extending a selection, or is selecting for move/copy/delete, DON'T bring up the bitmap editing menu!")
(RETURN)))
(IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM (OR (MENU (COND
((|type?| MENU USPS-FIM.MENU)
USPS-FIM.MENU)
(T (SETQ USPS-FIM.MENU (
 USPS-FIM.CREATE.MENU
)))))
FIM-STYLE))
(IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP NIL) (* \;
 "And clear any cached shrunk bitmaps so the display looks reasonable.")
(RETURN 'CHANGED))))
(USPS-FIM.COPYFN
(LAMBDA (IMAGEOBJ) (* \; "Edited 13-Feb-89 13:03 by jds")
(* |;;| "makes a copy of a bitmap image object.")
(USPS-FIM.CREATE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))))
(USPS-FIM.CREATE
(LAMBDA (FIM-STYLE) (* \; "Edited 13-Feb-89 12:00 by jds")
(* |;;| "returns an IMAGEOBJ that displays/prints as a Postal Service Facing Identification Mark for business-reply mail.")
(IMAGEOBJCREATE FIM-STYLE BITMAPIMAGEFNS)))
(USPS-FIM.CREATE.MENU
(LAMBDA NIL (* \; "Edited 13-Feb-89 12:27 by jds")
(* |;;| "Creates the menu that comes up when you button in a FIM image object.")
(|create| MENU
TITLE _ "New Facing Style"
ITEMS _ '(A B C D)
CENTERFLG _ T
CHANGEOFFSETFLG _ 'Y
MENUOFFSET _ (|create| POSITION
XCOORD _ -1
YCOORD _ 0))))
(USPS-FIM.DISPLAYFN
(LAMBDA (IMAGEOBJ IMAGE.STREAM) (* \; "Edited 13-Feb-89 12:18 by jds")
(* |;;| "Display a bitmap IMAGEOBJ on IMAGE.STREAM. Scales and rotates it if appropriate, and moves it down by DESCENT.")
(LET* ((FIM-STYLE-LIST (CDR (ASSOC (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)
USPS-FIM.STYLES)))
(STREAM-SCALE (DSPSCALE NIL IMAGE.STREAM))
(LINE-PITCH (FIXR (FTIMES STREAM-SCALE 72.27 1/16)))
(LINE-WIDTH (FIXR (FTIMES STREAM-SCALE 72.27 0.031)))
(FIM-HEIGHT (FIXR (FTIMES STREAM-SCALE (CONSTANT (TIMES 72.27 5/8)))))
SHRUNK.BITMAP)
(RELMOVETO 0 (IMINUS FIM-HEIGHT)
IMAGE.STREAM)
(|for| LINE-P |in| FIM-STYLE-LIST |do| (COND
(LINE-P (RELDRAWTO 0 FIM-HEIGHT
LINE-WIDTH
'PAINT IMAGE.STREAM)
(RELMOVETO LINE-PITCH
(IMINUS FIM-HEIGHT)
IMAGE.STREAM))
(T (RELMOVETO LINE-PITCH 0
IMAGE.STREAM)))))))
(USPS-FIM.GETFN3
(LAMBDA (STREAM) (* \; "Edited 13-Feb-89 13:49 by jds")
(* |;;;| "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.")
(USPS-FIM.CREATE (SELECTQ (\\BIN STREAM)
(0 'A)
(1 'B)
(2 'C)
(3 'D)
(HELP "Illegal FIM style")))))
(USPS-FIM.IMAGEBOXFN
(LAMBDA (IMAGEOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* \; "Edited 13-Feb-89 12:19 by jds")
(* |;;| "returns an imagebox describing the size of the scaled bitmap")
(LET* ((FIM-STYLE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
(SCALE (DSPSCALE NIL IMAGE.STREAM))
WIDTH HEIGHT)
(SETQ WIDTH (FIXR (FTIMES SCALE (CONSTANT (FTIMES 72.27 (+ 9/16 0.031))))))
(SETQ HEIGHT (FIXR (FTIMES SCALE (CONSTANT (TIMES 72.27 5/8)))))
(|create| IMAGEBOX
XSIZE _ WIDTH
YSIZE _ HEIGHT
YDESC _ HEIGHT
XKERN _ 0))))
(USPS-FIM.INIT
(LAMBDA NIL (* \; "Edited 13-Feb-89 12:02 by jds")
(* |;;|
 "returns the function vector which gives the functional information for a bitmap image object.")
(SETQ BITMAPIMAGEFNS (IMAGEFNSCREATE (FUNCTION USPS-FIM.DISPLAYFN)
(FUNCTION USPS-FIM.IMAGEBOXFN)
(FUNCTION USPS-FIM.PUTFN)
(FUNCTION USPS-FIM.GETFN3)
(FUNCTION USPS-FIM.COPYFN)
(FUNCTION USPS-FIM.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)))))
(USPS-FIM.PUTFN
(LAMBDA (OBJECT STREAM) (* \; "Edited 13-Feb-89 12:05 by jds")
(* \;
 "Put a description of a FIM object into the file.")
(LET* ((FIM-STYLE (IMAGEOBJPROP OBJECT 'OBJECTDATUM)))
(\\BOUT STREAM (SELECTQ FIM-STYLE
(A 0)
(B 1)
(C 2)
(D 3)
(HELP "Invalid FIM Style" FIM-STYLE))))))
)
(DECLARE\: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS USPS-FIM.IMAGEFNS USPS-FIM.MENU
(USPS-FIM.STYLES '((A T T NIL NIL T NIL NIL T T)
(B T NIL T T NIL T T NIL T)
(C T T NIL T NIL T NIL T T)
(D T T T NIL T NIL T T T))))
)
(USPS-FIM.INIT)
(PUTPROPS USPS COPYRIGHT ("Venue & Xerox Corporation" 1989 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (1863 8764 (USPS-FIM.BUTTONEVENTINFN 1873 . 3332) (USPS-FIM.COPYFN 3334 . 3583) (
USPS-FIM.CREATE 3585 . 3891) (USPS-FIM.CREATE.MENU 3893 . 4397) (USPS-FIM.DISPLAYFN 4399 . 5982) (
USPS-FIM.GETFN3 5984 . 6518) (USPS-FIM.IMAGEBOXFN 6520 . 7182) (USPS-FIM.INIT 7184 . 8146) (
USPS-FIM.PUTFN 8148 . 8762)))))
STOP

97
internal/envos/datepatch Normal file
View File

@@ -0,0 +1,97 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 13:42:42" {DSK}<usr>local>lde>lispcore>internal>library>datepatch.;2 17784
changes to%: (VARS DATEPATCHCOMS)
previous date%: "30-May-89 12:29:12" {DSK}<usr>local>lde>lispcore>internal>library>datepatch.;1
)
(* ; "
Copyright (c) 1989, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT DATEPATCHCOMS)
(RPAQQ DATEPATCHCOMS
(
(* ;; "Patches to the date parser and printer: IDATE parses many more dates now (full month names, more time zones). GDATE handles timezones outside of US.")
(FNS IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE \OUTDATE-STRING \UNPACKDATE)
(VARS TIME.ZONES)
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays)
(LOCALVARS . T)
(GLOBALVARS TIME.ZONES \TimeZoneComp \DayLightSavings)
(SPECVARS *STR* *POS*))))
(* ;;
"Patches to the date parser and printer: IDATE parses many more dates now (full month names, more time zones). GDATE handles timezones outside of US."
)
(DEFINEQ
(IDATE
(LAMBDA (STR DEFAULTTIME) (* ; "Edited 4-May-89 18:22 by bvm") (if (NULL STR) then (DAYTIME) else (PROG ((*STR* (MKSTRING STR)) (*POS* 1) MONTH DAY YEAR HOUR MINUTES SECONDS N1 N2 CH DLS TIMEZONE) (DECLARE (CL:SPECIAL *STR* *POS*)) TOP (OR (SETQ N1 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ((/ - SPACE) (* ; "Okay to put inside date") (add *POS* 1)) ("," (if (LISTP N1) then (* ; "Assume str was something like Mon, Apr 1.... Trash the day.") (add *POS* 1) (GO TOP))) ("." (if (LISTP N1) then (* ; "Abbreviated month?") (add *POS* 1))) NIL) (OR (SETQ N2 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ((/ - SPACE %,) (add *POS* 1)) ("." (if (LISTP N2) then (* ; "Abbreviated month?") (add *POS* 1))) NIL) (if (NOT (FIXP (SETQ YEAR (\IDATESCANTOKEN)))) then (RETURN NIL) elseif (< YEAR 100) then (* ; "default to this century") (add YEAR 1900) elseif (OR (< YEAR 1900) (> YEAR 2037)) then (* ; "out of range") (RETURN NIL)) (* ; "Now figure out day and month") (if (FIXP N2) then (* ; "Must be month-day") (SETQ DAY N2) (SETQ MONTH N1) elseif (FIXP (SETQ DAY N1)) then (* ; "day-month") (SETQ MONTH N2) else (RETURN NIL)) (if (FIXP MONTH) then (if (OR (< MONTH 1) (> MONTH 12)) then (* ; "invalid month") (RETURN NIL)) elseif (SETQ MONTH (\IDATE-PARSE-MONTH MONTH)) else (RETURN NIL)) (if (OR (< DAY 1) (> DAY (SELECTQ MONTH ((9 4 6 11) (* ; "30 days hath September...") 30) (2 (if (EVENP YEAR 4) then 29 else 28)) 31))) then (RETURN NIL)) (while (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE SPACE)) do (* ; "Skip spaces") (add *POS* 1)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ("," (* ; "Ok to terminate date with comma") (add *POS* 1)) (NIL (* ; "No time. Ok if DEFAULTTIME passed in") (if (NULL DEFAULTTIME) then (RETURN NIL)) (SETQ SECONDS (IREMAINDER DEFAULTTIME 60)) (SETQ MINUTES (IREMAINDER (SETQ DEFAULTTIME (IQUOTIENT DEFAULTTIME 60)) 60)) (SETQ HOUR (IQUOTIENT DEFAULTTIME 60)) (GO DONE)) NIL) (* ;; "Now scan time") (if (NOT (FIXP (SETQ HOUR (\IDATESCANTOKEN)))) then (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE %:)) then (* ; "hh:mm") (add *POS* 1) (OR (FIXP (SETQ MINUTES (\IDATESCANTOKEN))) (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE %:)) then (* ; "hh:mm:ss") (add *POS* 1) (OR (FIXP (SETQ SECONDS (\IDATESCANTOKEN))) (RETURN NIL)) (SETQ CH (NTHCHARCODE *STR* *POS*))) else (* ; "break apart time given without colon") (SETQ MINUTES (IREMAINDER HOUR 100)) (SETQ HOUR (IQUOTIENT HOUR 100))) (if CH then (* ; "There's more") (while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1)))) (if (AND (FMEMB CH (CHARCODE (A P a p))) (FMEMB (NTHCHARCODE *STR* (ADD1 *POS*)) (CHARCODE (M m))) (FMEMB (NTHCHARCODE *STR* (+ *POS* 2)) (CHARCODE (SPACE - NIL)))) then (* ; "AM or PM appended") (if (NOT (< HOUR 13)) then (* ; "bogus") (RETURN NIL)) (if (EQ HOUR 12) then (* ; "wrap to zero") (SETQ HOUR 0)) (if (FMEMB CH (CHARCODE (P p))) then (* ; "PM = 12 hours later") (add HOUR 12)) (SETQ CH (NTHCHARCODE *STR* (add *POS* 2))) (while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))))) (* ;; "Now check for time zone") (if (AND (EQ CH (CHARCODE -)) (ALPHACHARP (NTHCHARCODE *STR* (ADD1 *POS*)))) then (* ; "Some obsolete date forms gave time zone separated from time by hyphen") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1)))) (SELCHARQ CH ((+ -) (* ; "Explicit offset +-hhmm from GMT") (add *POS* 1) (if (NOT (FIXP (SETQ TIMEZONE (\IDATESCANTOKEN)))) then (RETURN NIL)) (CL:MULTIPLE-VALUE-BIND (H M) (CL:TRUNCATE TIMEZONE 100) (SETQ TIMEZONE (if (EQ M 0) then H else (* ; "Non-hour timezone. Use ratios.") (+ H (/ M 60))))) (if (EQ CH (CHARCODE +)) then (* ; "we represent time zones the other way around, so have to negate") (SETQ TIMEZONE (- TIMEZONE)))) (if (AND CH (ALPHACHARP CH)) then (* ; "Perhaps symbolic time zone") (PROG ((START *POS*)) LP (if (NULL (SETQ CH (NTHCHARCODE *STR* (add *POS* 1)))) elseif (ALPHACHARP CH) then (GO LP) elseif (EQ CH (CHARCODE SPACE)) then (* ; "Space may terminate, except that some time zones have space in middle, e.g., EET DST.") (if (AND (SETQ CH (NTHCHARCODE *STR* (ADD1 *POS*))) (ALPHACHARP CH)) then (add *POS* 1) (GO LP)) else (* ; "Non-alphabetic in timezone") (RETURN NIL)) (* ;; "Potential time zone from START to before POS") (SETQ TIMEZONE (SUBSTRING *STR* START (SUB1 *POS*))) (RETURN (SETQ TIMEZONE (for ZONE in TIME.ZONES bind DST do (if (STRING-EQUAL TIMEZONE (CADR ZONE)) then (RETURN (CAR ZONE)) elseif (AND (SETQ DST (CADDR ZONE)) (STRING-EQUAL TIMEZONE DST)) then (* ; "The daylight equivalent is off by one hour") (RETURN (SUB1 (CAR ZONE))))))))))) DONE (RETURN (AND (< HOUR 24) (< MINUTES 60) (OR (NOT SECONDS) (< SECONDS 60)) (\PACKDATE YEAR (SUB1 MONTH) DAY HOUR MINUTES (OR SECONDS 0) TIMEZONE))))))
)
(\IDATESCANTOKEN
(LAMBDA NIL (* ; "Edited 4-May-89 15:20 by bvm") (DECLARE (CL:SPECIAL *STR* *POS*)) (* ;; "Returns next token in STR, starting at POS. Is either an integer or list of alphabetic charcodes. Skips blanks") (PROG (RESULT CH) LP (SETQ CH (NTHCHARCODE *STR* *POS*)) (RETURN (COND ((NULL CH) NIL) ((EQ CH (CHARCODE SPACE)) (* ; "Skip leading spaces") (add *POS* 1) (GO LP)) ((DIGITCHARP CH) (SETQ RESULT (- CH (CHARCODE 0))) (while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) (DIGITCHARP CH)) do (SETQ RESULT (+ (- CH (CHARCODE 0)) (TIMES RESULT 10)))) RESULT) ((ALPHACHARP CH) (CONS (UCASECODE CH) (while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) (ALPHACHARP CH)) collect (UCASECODE CH))))))))
)
(\IDATE-PARSE-MONTH
(LAMBDA (MONTH) (* ; "Edited 4-May-89 14:54 by bvm") (* ;; "MONTH is a list of upper case character codes. Figure out which month (1-12) we mean. We require that MONTH be at least 3 characters long and a prefix of month name") (* ;; "These ugly macros produce code, essentially a decision tree, that walks down the list of char codes looking for exactly the right ones.") (CL:MACROLET ((DISCRIMINATE (FORMS) (* ;; "The entry -- start MINCHARS at 3 and turn the month names into char codes. FORMS is quoted list to workaround masterscope stupidity") (BQUOTE (DISCRIMINATE-1 3 (\,@ (FOR F IN (CADR FORMS) COLLECT (CONS (CHCON (CAR F)) (CDR F))))))) (DISCRIMINATE-1 (MINCHARS &BODY FORMS) (IF (NULL (CDR FORMS)) THEN (* ; "only one case") (BQUOTE (COND ((DISCRIMINATE-2 (\, MINCHARS) (\, (CAAR FORMS))) (\,@ (CDAR FORMS))))) ELSE (* ; "Discriminate on the first code and recur on the tails") (LIST* (QUOTE CASE) (BQUOTE (CAR CODEVAR)) (WHILE FORMS BIND REST C COLLECT (SETQ REST (CL:REMOVE (SETQ C (CAAAR FORMS)) FORMS :KEY (QUOTE CAAR))) (BQUOTE ((\, C) (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-1 (\, (SUB1 MINCHARS)) (\,@ (FOR F IN (CL:SET-DIFFERENCE FORMS (SETQ FORMS REST)) COLLECT (CONS (CDAR F) (CDR F))))))))))) (DISCRIMINATE-2 (MINCHARS MATCHLST) (* ;; "True if codes match MATCHLST, with prefix at least MINCHARS long.") (IF (NULL MATCHLST) THEN (BQUOTE (NULL CODEVAR)) ELSE (LET ((CODE (BQUOTE (AND (EQ (CAR CODEVAR) (\, (POP MATCHLST))) (PROGN (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-2 (\, (SUB1 MINCHARS)) (\, MATCHLST))))))) (IF (<= MINCHARS 0) THEN (* ; "Ok to match null") (BQUOTE (OR (NULL CODEVAR) (\, CODE))) ELSE (* ; "Must match exactly so far") CODE))))) (LET ((CODEVAR MONTH)) (* ; "This LET is solely to allow more compact code (PVAR_ is one byte less than IVARX_)") (DISCRIMINATE (QUOTE (("JANUARY" 1) ("FEBRUARY" 2) ("MARCH" 3) ("APRIL" 4) ("MAY" 5) ("JUNE" 6) ("JULY" 7) ("AUGUST" 8) ("SEPTEMBER" 9) ("OCTOBER" 10) ("NOVEMBER" 11) ("DECEMBER" 12)))))))
)
(\OUTDATE
(LAMBDA (UD FORMAT STRING) (* ; "Edited 30-May-89 12:28 by bvm") (DESTRUCTURING-BIND (YEAR MONTH DAY HOUR MINUTE SECOND DST WDAY) UD (LET ((SEPR (CHARCODE -)) (HOUR.LENGTH 2) SIZE S N NO.DATE NO.TIME NO.LEADING.SPACES TIME.ZONE TIME.ZONE.LENGTH YEAR.LENGTH MONTH.LENGTH DAY.LENGTH WDAY.LENGTH NO.SECONDS NUMBER.OF.MONTH MONTH.LONG MONTH.LEADING YEAR.LONG DAY.OF.WEEK DAY.SHORT CIVILIAN.TIME) (if (NOT FORMAT) then NIL elseif (NEQ (CAR (LISTP FORMAT)) (QUOTE DATEFORMAT)) then (LISPERROR "ILLEGAL ARG" FORMAT) else (for TOKEN in FORMAT do (SELECTQ TOKEN (NO.DATE (SETQ NO.DATE T)) (NO.TIME (SETQ NO.TIME T)) (NUMBER.OF.MONTH (SETQ NUMBER.OF.MONTH T)) (YEAR.LONG (SETQ YEAR.LONG T)) (MONTH.LONG (SETQ MONTH.LONG T)) (MONTH.LEADING (SETQ MONTH.LEADING T)) (SLASHES (SETQ SEPR (CHARCODE /))) (SPACES (SETQ SEPR (CHARCODE SPACE))) (NO.LEADING.SPACES (SETQ NO.LEADING.SPACES T)) (TIME.ZONE (SETQ TIME.ZONE (OR (LISTP (CDR (if (FIXP \TimeZoneComp) then (ASSOC \TimeZoneComp TIME.ZONES) else (* ; "Ugh, not a small integer") (CL:ASSOC \TimeZoneComp TIME.ZONES :TEST (QUOTE =))))) \TimeZoneComp))) (NO.SECONDS (SETQ NO.SECONDS T)) (DAY.OF.WEEK (SETQ DAY.OF.WEEK T)) (DAY.SHORT (SETQ DAY.SHORT T)) (CIVILIAN.TIME (SETQ CIVILIAN.TIME T)) NIL))) (SETQ SIZE (+ (if NO.DATE then 0 else (+ (if MONTH.LEADING then (SETQ SEPR (CHARCODE SPACE)) (SETQ NUMBER.OF.MONTH NIL) (* ; "Will use a comma") 1 else 0) (SETQ MONTH.LENGTH (if NUMBER.OF.MONTH then (* ; "Month input is zero-based") (if (AND (< (add MONTH 1) 10) NO.LEADING.SPACES) then 1 else 2) else (SETQ MONTH (CL:NTH MONTH (QUOTE ("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")))) (if MONTH.LONG then (NCHARS MONTH) else 3))) (SETQ DAY.LENGTH (if (AND (OR NO.LEADING.SPACES MONTH.LEADING) (< DAY 10)) then 1 else 2)) (SETQ YEAR.LENGTH (if (OR YEAR.LONG (> YEAR 1999)) then 4 else (SETQ YEAR (IREMAINDER YEAR 100)) 2)) (if DAY.OF.WEEK then (SETQ DAY.OF.WEEK (CL:NTH WDAY (QUOTE ("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")))) (+ 3 (SETQ WDAY.LENGTH (if DAY.SHORT then (* ; "3 letters plus %" ()%"") 3 else (NCHARS DAY.OF.WEEK)))) else 0) 2)) (if NO.TIME then 0 else (+ (if NO.DATE then 5 else 6) (if NO.SECONDS then 0 else 3) (if CIVILIAN.TIME then (* ; "Use AM/PM") (SETQ CIVILIAN.TIME (if (> HOUR 11) then (* ; "PM") (if (> HOUR 12) then (add HOUR -12)) (CHARCODE p) else (if (EQ HOUR 0) then (SETQ HOUR 12)) (CHARCODE a))) (if (AND (< HOUR 10) NO.LEADING.SPACES) then (SETQ HOUR.LENGTH 1) else 2) else 0) (if (NULL TIME.ZONE) then 0 elseif (NUMBERP TIME.ZONE) then (* ; "Use the -0800 format") 6 else (* ; "Depends on dst: (normal dst). If missing, we are forced to use numeric format") (SETQ TIME.ZONE (OR (if DST then (CADR TIME.ZONE) else (CAR TIME.ZONE)) \TimeZoneComp)) (ADD1 (SETQ TIME.ZONE.LENGTH (NCHARS TIME.ZONE)))))))) (SETQ S (ALLOCSTRING SIZE (CHARCODE SPACE))) (if (NOT NO.DATE) then (if MONTH.LEADING then (* ; "Month day, year") (RPLSTRING S 1 MONTH) (SETQ N MONTH.LENGTH) (RPLCHARCODE S (add N 1) SEPR) (\RPLRIGHT S (add N (if (< DAY 10) then 1 else 2)) DAY 1) (RPLCHARCODE S (add N 1) (CHARCODE ",")) else (* ; "Day<sepr>month<sepr>year") (\RPLRIGHT S (SETQ N DAY.LENGTH) DAY 1) (RPLCHARCODE S (add N 1) SEPR) (if NUMBER.OF.MONTH then (\RPLRIGHT S (add N MONTH.LENGTH) MONTH MONTH.LENGTH) else (\OUTDATE-STRING S N MONTH (NOT MONTH.LONG)) (add N MONTH.LENGTH))) (RPLCHARCODE S (add N 1) SEPR) (\RPLRIGHT S (add N YEAR.LENGTH) YEAR 2) (OR NO.TIME (add N 1)) (if DAY.OF.WEEK then (* ; "Day of week at very end in parens") (LET ((START (SUB1 (- SIZE WDAY.LENGTH)))) (RPLCHARCODE S START (CHARCODE "(")) (\OUTDATE-STRING S START DAY.OF.WEEK DAY.SHORT) (RPLCHARCODE S SIZE (CHARCODE ")")))) else (SETQ N 0)) (if (NOT NO.TIME) then (\RPLRIGHT S (add N HOUR.LENGTH) HOUR (if CIVILIAN.TIME then 1 else 2)) (RPLCHARCODE S (ADD1 N) (CHARCODE %:)) (\RPLRIGHT S (add N 3) MINUTE 2) (if (NOT NO.SECONDS) then (RPLCHARCODE S (ADD1 N) (CHARCODE %:)) (\RPLRIGHT S (add N 3) SECOND 2)) (if CIVILIAN.TIME then (RPLCHARCODE S (ADD1 N) CIVILIAN.TIME) (RPLCHARCODE S (add N 2) (CHARCODE m))) (if TIME.ZONE then (if (NUMBERP TIME.ZONE) then (* ; "+0800 etc") (if DST then (* ; "Daylight savings is in effect, so time zone is off by an hour") (SETQ TIME.ZONE (SUB1 TIME.ZONE))) (RPLCHARCODE S (+ N 2) (if (<= TIME.ZONE 0) then (* ; "East of GMT, which is denoted + in this notation") (SETQ TIME.ZONE (- TIME.ZONE)) (CHARCODE +) else (CHARCODE -))) (if (FIXP TIME.ZONE) then (* ; "integral number of hours") (\RPLRIGHT S (+ N 4) TIME.ZONE 2) (RPLSTRING S (+ N 5) "00") else (CL:MULTIPLE-VALUE-BIND (H M) (CL:TRUNCATE TIME.ZONE) (\RPLRIGHT S (+ N 4) H 2) (\RPLRIGHT S (+ N 6) (ROUND (TIMES M 60)) 2))) else (RPLSTRING S (+ N 2) TIME.ZONE)))) (if STRING then (SUBSTRING S 1 -1 STRING) else S))))
)
(\OUTDATE-STRING
(LAMBDA (S N STRING SHORTP) (* ; "Edited 18-May-89 18:38 by bvm") (* ;; "Append STRING to S, using only the first 3 chars if SHORTP is true. N is the index of the last char appended to S. Returns new N") (if SHORTP then (* ; "Use only first 3 chars") (for I from 1 to 3 do (RPLCHARCODE S (+ N I) (NTHCHARCODE STRING I))) else (RPLSTRING S (ADD1 N) STRING)))
)
(\UNPACKDATE
(LAMBDA (D) (* ; "Edited 4-May-89 18:18 by bvm") (* ;; "Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds daylightp DayOfWeek). D defaults to current date. --- DayOfWeek is zero for Monday --- --- D is first converted to the alto standard, a 32-bit unsigned integer, representing the number of seconds since jan 1, 1901-Gmt. We have to be a little tricky in our computations to avoid the sign bit.") (SETQ D (OR D (DAYTIME))) (PROG ((CHECKDLS \DayLightSavings) (DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D) 1) 30)) MONTH SEC HR DAY4 YDAY WDAY YEAR4 TOTALDAYS MIN DLS FRAC) (* ; "DQ is number of minutes since day 0, getting us past the sign bit problem.") (SETQ SEC (IMOD (+ D (CONSTANT (- 60 (IMOD MIN.FIXP 60)))) 60)) (SETQ MIN (IREMAINDER DQ 60)) (* ;; "Now we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897") (LET ((ZONE \TimeZoneComp)) (if (NOT (FIXP ZONE)) then (* ; "Gack, a non-hour offset. Use the integer here, then adjust the minutes, etc.") (CL:MULTIPLE-VALUE-SETQ (ZONE FRAC) (CL:FLOOR ZONE))) (SETQ HR (IREMAINDER (SETQ DQ (- (+ (IQUOTIENT DQ 60) (CONSTANT (ITIMES 24 \4YearsDays))) ZONE)) 24)) (if FRAC then (SETQ FRAC (ROUND (TIMES FRAC -60))) (* ; "Minutes to add (time zones are never below the minute offset)") (CL:MULTIPLE-VALUE-SETQ (FRAC MIN) (CL:FLOOR (+ MIN FRAC) 60)) (if (NEQ FRAC 0) then (* ; "Adjust the hours") (CL:MULTIPLE-VALUE-SETQ (FRAC HR) (CL:FLOOR (+ HR FRAC) 24))))) (SETQ TOTALDAYS (IQUOTIENT DQ 24)) (if FRAC then (* ; "For non-integral time zones, here's the last of the leftover.") (add TOTALDAYS FRAC)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ; "DAY4 = number of days since last leap year day 0") (SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 (QUOTE ((789 . 3) (424 . 2) (59 . 1) (0 . 0))))))) (* ; "pretend every year is a leap year, adding one for days after Feb 28") (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ; "YEAR4 = number of years til that last leap year / 4") (SETQ YDAY (IREMAINDER DAY4 366)) (* ; "YDAY is the ordinal day in the year (jan 1 = zero)") (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3) 7)) (if (AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) then (* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") (if (> (SETQ HR (ADD1 HR)) 23) then (* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") (SETQ TOTALDAYS (ADD1 TOTALDAYS)) (SETQ HR 0) (SETQ CHECKDLS NIL) (GO DTLOOP))) (SETQ MONTH (\DTSCAN YDAY (QUOTE ((335 . 11) (305 . 10) (274 . 9) (244 . 8) (213 . 7) (182 . 6) (152 . 5) (121 . 4) (91 . 3) (60 . 2) (31 . 1) (0 . 0))))) (* ; "Now return year, month, day, hr, min, sec") (RETURN (LIST (+ 1897 (ITIMES YEAR4 4) (IQUOTIENT DAY4 366)) (CDR MONTH) (ADD1 (- YDAY (CAR MONTH))) HR MIN SEC DLS WDAY))))
)
)
(RPAQQ TIME.ZONES
((8 "PST" "PDT")
(7 "MST" "MDT")
(6 "CST" "CDT")
(5 "EST" "EDT")
(0 "GMT" "BST")
(0 "UT")
(-1 "MET" "MET DST")
(-2 "EET" "EET DST")))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \4YearsDays 1461)
(CONSTANTS \4YearsDays)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS TIME.ZONES \TimeZoneComp \DayLightSavings)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(SPECVARS *STR* *POS*)
)
)
(PUTPROPS DATEPATCH COPYRIGHT ("Venue & Xerox Corporation" 1989 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1141 17140 (IDATE 1151 . 6017) (\IDATESCANTOKEN 6019 . 6745) (\IDATE-PARSE-MONTH 6747
. 8757) (\OUTDATE 8759 . 13596) (\OUTDATE-STRING 13598 . 13980) (\UNPACKDATE 13982 . 17138)))))
STOP

BIN
internal/envos/datepatch.tedit Normal file
View File

Binary file not shown.

BIN
internal/envos/filebanger.tedit Normal file
View File

Binary file not shown.

3
internal/envos/internal-library-readme.tedit Normal file
View File

@@ -0,0 +1,3 @@
Files in this directory /usr/local/lde/iternal/
where copied from {eris}<lispcore>internal>library>
31-Jan-90

BIN
internal/envos/unixmail.tedit Normal file
View File

Binary file not shown.

BIN
internal/envos/vpcdisk-setup.tedit Normal file
View File

Binary file not shown.

BIN
library/COLOR-BRAINSTORMING.TXT Normal file
View File

Binary file not shown.

236
library/COLOR.TEDIT Normal file
View File

File diff suppressed because one or more lines are too long

1243
library/MAIKOCOLOR
View File

File diff suppressed because it is too large Load Diff

BIN
library/MAIKOCOLOR.TEDIT Normal file
View File

Binary file not shown.

1118
lispusers/COLORDEMO
View File

File diff suppressed because it is too large Load Diff

BIN
lispusers/COLORDEMO.TEDIT Normal file
View File

Binary file not shown.

BIN
lispusers/COLORNNCC.TEDIT Normal file
View File

Binary file not shown.

138
lispusers/COLOROBJ
View File

@@ -1,63 +1,67 @@
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
(FILECREATED " 4-Feb-87 23:58:42" {ERIS}<LISPUSERS>LYRIC>COLOROBJ.;2 7868
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Jun-90 21:02:08" {DSK}<usr>local>lde>lispcore>internal>library>COLOROBJ.;2 7921
changes to%: (VARS COLOROBJCOMS COLOROBJFNS)
changes to%: (FNS COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN
COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN)
(VARS COLOROBJCOMS)
previous date%: "26-Feb-86 14:47:40" {ERIS}<LISPUSERS>LYRIC>COLOROBJ.;1)
previous date%: " 4-Feb-87 23:58:42" {DSK}<usr>local>lde>lispcore>internal>library>COLOROBJ.;1
)
(* "
Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
(* ; "
Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT COLOROBJCOMS)
(RPAQQ COLOROBJCOMS [(FNS * COLOROBJFNS)
(FILES COLOR)
(INITVARS (COLOROBJ.DEFAULT.COLOR 'RED))
(VARS (COLOROBJFNS '(COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN
COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN
COLOROBJ.WHENOPERATEDONFN))
(COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN)
(FUNCTION COLOROBJ.IMAGEBOXFN)
(FUNCTION COLOROBJ.PUTFN)
(FUNCTION COLOROBJ.GETFN)
(FUNCTION COLOROBJ.COPYFN)
(FUNCTION COLOROBJ.BUTTONEVENTFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION COLOROBJ.WHENOPERATEDONFN)
(FUNCTION NILL])
(RPAQQ COLOROBJCOMS
[(FNS * COLOROBJFNS)
(FILES COLOR)
(INITVARS (COLOROBJ.DEFAULT.COLOR 'RED))
(VARS (COLOROBJFNS '(COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN
COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
(COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN)
(FUNCTION COLOROBJ.IMAGEBOXFN)
(FUNCTION COLOROBJ.PUTFN)
(FUNCTION COLOROBJ.GETFN)
(FUNCTION COLOROBJ.COPYFN)
(FUNCTION COLOROBJ.BUTTONEVENTFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION COLOROBJ.WHENOPERATEDONFN)
(FUNCTION NILL])
(RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN
COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
(DEFINEQ
(COLOROBJ.CREATE
[LAMBDA (COLOR) (* gbn "13-Jan-86 16:00")
(* * create a color object. color is anything acceptable to dspcolor
 (atoms on colornames, rgb triples, indices))
[LAMBDA (COLOR) (* gbn "13-Jan-86 16:00")
(* * create a color object. color is anything acceptable to dspcolor
 (atoms on colornames, rgb triples, indices))
(LET ((COLOROBJ (IMAGEOBJCREATE NIL COLOROBJ.IMAGEFNS)))
(IMAGEOBJPROP COLOROBJ 'COLOR (OR COLOR COLOROBJ.DEFAULT.COLOR))
COLOROBJ])
(COLOROBJ.DISPLAYFN
[LAMBDA (COLOROBJ IMAGE.STREAM) (* gbn "13-Jan-86 17:51")
(* On the display a color object shows up as the color name, otherwise it has
 no image. On any stream it has the sideeffect of changing the foreground color)
[LAMBDA (COLOROBJ IMAGE.STREAM) (* gbn "13-Jan-86 17:51")
(* On the display a color object shows up as the color name, otherwise it has
 no image. On any stream it has the sideeffect of changing the foreground color)
(LET* ((COLOR (IMAGEOBJPROP COLOROBJ 'COLOR))
(X (DSPXPOSITION NIL IMAGE.STREAM))
(Y (DSPYPOSITION NIL IMAGE.STREAM)))
(DSPCOLOR COLOR IMAGE.STREAM)
(SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM)
(DISPLAY (DSPFONT '(WEIGHT BOLD) IMAGE.STREAM)
(DISPLAY (DSPFONT '(WEIGHT BOLD)
IMAGE.STREAM)
(LET* ((STRING (IMAGEOBJPROP COLOROBJ 'COLOR))
(STRINGREGION (STRINGREGION STRING IMAGE.STREAM))
(LEFT (ADD1 (fetch (REGION LEFT) of STRINGREGION)))
@@ -65,9 +69,13 @@ Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
(REGION (create REGION
LEFT _ LEFT
BOTTOM _ BOTTOM
HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of STRINGREGION)
HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of
STRINGREGION
)
2)
WIDTH _ (IPLUS (fetch (REGION WIDTH) of STRINGREGION)
WIDTH _ (IPLUS (fetch (REGION WIDTH) of
STRINGREGION
)
6)))
(TOP (fetch (REGION TOP) of REGION))
(RIGHT (fetch (REGION RIGHT) of REGION)))
@@ -86,16 +94,16 @@ Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
(NILL])
(COLOROBJ.GETFN
[LAMBDA (INPUT.STREAM TEXTSTREAM) (* gbn "13-Jan-86 15:42")
[LAMBDA (INPUT.STREAM TEXTSTREAM) (* gbn "13-Jan-86 15:42")
(* reads the COLOR and creates an
 COLOROBJ)
 COLOROBJ)
(COLOROBJ.CREATE (READ INPUT.STREAM])
(COLOROBJ.IMAGEBOXFN
[LAMBDA (COLOROBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* gbn "13-Jan-86 16:01")
(* * Returns a null imagebox, except to the display, where it returns the size
 of the box)
[LAMBDA (COLOROBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* gbn "13-Jan-86 16:01")
(* * Returns a null imagebox, except to the display, where it returns the size
 of the box)
(LET NIL (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM)
(DISPLAY (create IMAGEBOX
@@ -113,44 +121,46 @@ Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
XKERN _ 0])
(COLOROBJ.PUTFN
[LAMBDA (COLOROBJ OUTPUT.STREAM) (* gbn "13-Jan-86 15:57")
[LAMBDA (COLOROBJ OUTPUT.STREAM) (* gbn "13-Jan-86 15:57")
(* prints only the color to the file)
(PRINT (IMAGEOBJPROP COLOROBJ 'COLOR)
OUTPUT.STREAM])
(COLOROBJ.COPYFN
[LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* gbn "13-Jan-86 15:58")
[LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* gbn "13-Jan-86 15:58")
(COLOROBJ.CREATE (IMAGEOBJPROP IMAGEOBJ 'COLOR)
TOSTREAM])
(COLOROBJ.WHENOPERATEDONFN
[LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23")
[LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23")
(* DUMMY)
])
)
(FILESLOAD COLOR)
(RPAQ? COLOROBJ.DEFAULT.COLOR 'RED)
(RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN
COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
(RPAQ COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN)
(FUNCTION COLOROBJ.IMAGEBOXFN)
(FUNCTION COLOROBJ.PUTFN)
(FUNCTION COLOROBJ.GETFN)
(FUNCTION COLOROBJ.COPYFN)
(FUNCTION COLOROBJ.BUTTONEVENTFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION COLOROBJ.WHENOPERATEDONFN)
(FUNCTION NILL)))
(PUTPROPS COLOROBJ COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
(RPAQ COLOROBJ.IMAGEFNS
(IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN)
(FUNCTION COLOROBJ.IMAGEBOXFN)
(FUNCTION COLOROBJ.PUTFN)
(FUNCTION COLOROBJ.GETFN)
(FUNCTION COLOROBJ.COPYFN)
(FUNCTION COLOROBJ.BUTTONEVENTFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION COLOROBJ.WHENOPERATEDONFN)
(FUNCTION NILL)))
(PUTPROPS COLOROBJ COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1994 6812 (COLOROBJ.CREATE 2004 . 2428) (COLOROBJ.DISPLAYFN 2430 . 4799) (
COLOROBJ.GETFN 4801 . 5136) (COLOROBJ.IMAGEBOXFN 5138 . 6118) (COLOROBJ.PUTFN 6120 . 6406) (
COLOROBJ.COPYFN 6408 . 6601) (COLOROBJ.WHENOPERATEDONFN 6603 . 6810)))))
(FILEMAP (NIL (1964 7057 (COLOROBJ.CREATE 1974 . 2380) (COLOROBJ.DISPLAYFN 2382 . 5080) (
COLOROBJ.GETFN 5082 . 5411) (COLOROBJ.IMAGEBOXFN 5413 . 6375) (COLOROBJ.PUTFN 6377 . 6659) (
COLOROBJ.COPYFN 6661 . 6850) (COLOROBJ.WHENOPERATEDONFN 6852 . 7055)))))
STOP

BIN
lispusers/COLOROBJ.TEDIT Normal file
View File

Binary file not shown.

399
lispusers/DORADOCOLOR
View File

@@ -1,49 +1,53 @@
(FILECREATED "24-Feb-86 12:32:26" {ERIS}<LISPCORE>LIBRARY>DORADOCOLOR.;27 15311
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 13:56:37" {DSK}<usr>local>lde>lispcore>internal>library>DORADOCOLOR.;2 16864
changes to: (VARS DORADOCOLORCOMS)
changes to%: (VARS DORADOCOLORCOMS)
previous date: "15-Feb-86 16:46:20" {ERIS}<LISPCORE>LIBRARY>DORADOCOLOR.;26)
previous date%: "24-Feb-86 12:32:26"
{DSK}<usr>local>lde>lispcore>internal>library>DORADOCOLOR.;1)
(* Copyright (c) 1985, 1900, 1986 by Xerox Corporation. All rights reserved.)
(* ; "
Copyright (c) 1985, 1900, 1986, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT DORADOCOLORCOMS)
(RPAQQ DORADOCOLORCOMS ((* * DORADOCOLOR -- Dorado machine dependent color display fns -- By
Richard Burton, Herb Jellinek, and Kelly Roach.)
(DECLARE: DONTCOPY (RECORDS MonitorCB ChannelCB ColorCB ColorEntry)
(CONSTANTS (DORADO\COLORSCREENWIDTH 640)
(DORADO\COLORSCREENHEIGHT 480)
(DORADOCOLORPAGES 602)
(pplOffset 255)
(MCBPtr 268)
(MCBSeal 65326)
(MCBLow 160)
(MCBSize 8)
(AFlagsMask 4)
(ChCBLow 168)
(ChCBSize 8)
(ColCBLow 176)
(ColCBSize 16)
(CMapPages 8)))
(* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56
for large CONRACs, and 40 for most other monitors. *)
(INITVARS (\DORADOCOLOR.LEFTMARGIN 80)
(\DORADOCOLOR.ATABLEIMAGE NIL)
(DORADOCOLOR.BITSPERPIXEL 8))
(GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN
DORADOCOLOR.BITSPERPIXEL)
(FNS \RGB.TO.DORADO.RGB \DORADOCOLOR.LOOKATA)
(FNS \DORADOCOLOR.INIT \DORADOCOLOR.STARTCOLOR \DORADOCOLOR.STOPCOLOR
\DORADOCOLOR.EVENTFN \DORADOCOLOR.SENDCOLORMAPENTRY)
(FNS \DORADOCOLOR.COLORLEVEL \DORADOCOLOR.SETONECOLOR)
(FILES COLOR)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\DORADOCOLOR.INIT)))))
(* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb
Jellinek, and Kelly Roach.)
(RPAQQ DORADOCOLORCOMS
[(* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb
Jellinek, and Kelly Roach.)
(DECLARE%: DONTCOPY (RECORDS MonitorCB ChannelCB ColorCB ColorEntry)
(CONSTANTS (DORADO\COLORSCREENWIDTH 640)
(DORADO\COLORSCREENHEIGHT 480)
(DORADOCOLORPAGES 602)
(pplOffset 255)
(MCBPtr 268)
(MCBSeal 65326)
(MCBLow 160)
(MCBSize 8)
(AFlagsMask 4)
(ChCBLow 168)
(ChCBSize 8)
(ColCBLow 176)
(ColCBSize 16)
(CMapPages 8)))
(* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and
40 for most other monitors. *)
(INITVARS (\DORADOCOLOR.LEFTMARGIN 80)
(\DORADOCOLOR.ATABLEIMAGE NIL)
(DORADOCOLOR.BITSPERPIXEL 8))
(GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL)
(FNS \RGB.TO.DORADO.RGB \DORADOCOLOR.LOOKATA)
(FNS \DORADOCOLOR.INIT \DORADOCOLOR.STARTCOLOR \DORADOCOLOR.STOPCOLOR \DORADOCOLOR.EVENTFN
\DORADOCOLOR.SENDCOLORMAPENTRY)
(FNS \DORADOCOLOR.COLORLEVEL \DORADOCOLOR.SETONECOLOR)
(FILES COLOR)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DORADOCOLOR.INIT])
(* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb Jellinek,
and Kelly Roach.)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(BLOCKRECORD MonitorCB ((Seal WORD)
(Flags WORD)
@@ -81,9 +85,9 @@ Jellinek, and Kelly Roach.)
(NIL BITS 4)
(Green BITS 8)
(RedHi BITS 4)))
]
)
(DECLARE: EVAL@COMPILE
(DECLARE%: EVAL@COMPILE
(RPAQQ DORADO\COLORSCREENWIDTH 640)
@@ -113,6 +117,7 @@ Jellinek, and Kelly Roach.)
(RPAQQ CMapPages 8)
(CONSTANTS (DORADO\COLORSCREENWIDTH 640)
(DORADO\COLORSCREENHEIGHT 480)
(DORADOCOLORPAGES 602)
@@ -129,8 +134,8 @@ Jellinek, and Kelly Roach.)
(CMapPages 8))
)
)
(* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and
40 for most other monitors. *)
(* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and 40 for
most other monitors. *)
(RPAQ? \DORADOCOLOR.LEFTMARGIN 80)
@@ -138,191 +143,207 @@ Jellinek, and Kelly Roach.)
(RPAQ? \DORADOCOLOR.ATABLEIMAGE NIL)
(RPAQ? DORADOCOLOR.BITSPERPIXEL 8)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL)
)
(DEFINEQ
(\RGB.TO.DORADO.RGB
(LAMBDA (RGB ColorEntryBox) (* kbr: " 5-Jul-85 15:08")
(PROG (ColorEntry)
(SETQ ColorEntry (OR ColorEntryBox (\ALLOCBLOCK 1)))
(replace (ColorEntry Blue) of ColorEntry with (fetch (RGB BLUE) of RGB))
(replace (ColorEntry Green) of ColorEntry with (fetch (RGB GREEN) of RGB))
(replace (ColorEntry RedLo) of ColorEntry with (LOGAND (fetch (RGB RED) of RGB)
15))
(replace (ColorEntry RedHi) of ColorEntry with (LRSH (fetch (RGB RED) of RGB)
4))
(RETURN ColorEntry))))
[LAMBDA (RGB ColorEntryBox) (* kbr%: " 5-Jul-85 15:08")
(PROG (ColorEntry)
(SETQ ColorEntry (OR ColorEntryBox (\ALLOCBLOCK 1)))
(replace (ColorEntry Blue) of ColorEntry with (fetch (RGB BLUE)
of RGB))
(replace (ColorEntry Green) of ColorEntry with (fetch (RGB GREEN)
of RGB))
(replace (ColorEntry RedLo) of ColorEntry with (LOGAND (fetch (RGB RED)
of RGB)
15))
(replace (ColorEntry RedHi) of ColorEntry with (LRSH (fetch (RGB RED)
of RGB)
4))
(RETURN ColorEntry])
(\DORADOCOLOR.LOOKATA
(LAMBDA (MCB) (* kbr: " 5-Jul-85 16:04")
(replace (MonitorCB Flags) of MCB with (LOGOR AFlagsMask (fetch (MonitorCB Flags) of MCB)))
(while (EQ AFlagsMask (LOGAND AFlagsMask (fetch (MonitorCB Flags) of MCB)))
do (* wait for microcode to notice)
(BLOCK))))
[LAMBDA (MCB) (* kbr%: " 5-Jul-85 16:04")
(replace (MonitorCB Flags) of MCB with (LOGOR AFlagsMask (fetch (MonitorCB Flags)
of MCB)))
(while (EQ AFlagsMask (LOGAND AFlagsMask (fetch (MonitorCB Flags) of MCB)))
do (* wait for microcode to notice)
(BLOCK])
)
(DEFINEQ
(\DORADOCOLOR.INIT
(LAMBDA NIL (* kbr:
"15-Feb-86 13:01")
[LAMBDA NIL (* kbr%: "15-Feb-86 13:01")
(DECLARE (GLOBALVARS \DORADOCOLORWSOPS \DORADOCOLORINFO))
(SETQ \DORADOCOLORWSOPS (create WSOPS
STARTBOARD _(FUNCTION NILL)
STARTCOLOR _(FUNCTION \DORADOCOLOR.STARTCOLOR)
STOPCOLOR _(FUNCTION \DORADOCOLOR.STOPCOLOR)
EVENTFN _(FUNCTION \DORADOCOLOR.EVENTFN)
SENDCOLORMAPENTRY _(FUNCTION \DORADOCOLOR.SENDCOLORMAPENTRY)
SENDPAGE _(FUNCTION NILL)
PILOTBITBLT _(FUNCTION \DISPLAY.PILOTBITBLT)))
STARTBOARD _ (FUNCTION NILL)
STARTCOLOR _ (FUNCTION \DORADOCOLOR.STARTCOLOR)
STOPCOLOR _ (FUNCTION \DORADOCOLOR.STOPCOLOR)
EVENTFN _ (FUNCTION \DORADOCOLOR.EVENTFN)
SENDCOLORMAPENTRY _ (FUNCTION \DORADOCOLOR.SENDCOLORMAPENTRY)
SENDPAGE _ (FUNCTION NILL)
PILOTBITBLT _ (FUNCTION \DISPLAY.PILOTBITBLT)))
(SETQ \DORADOCOLORINFO (create DISPLAYINFO
DITYPE _(QUOTE DORADOCOLOR)
DITYPE _ 'DORADOCOLOR
DIWIDTH _ DORADO\COLORSCREENWIDTH
DIHEIGHT _ DORADO\COLORSCREENHEIGHT
DIBITSPERPIXEL _ 8
DIWSOPS _ \DORADOCOLORWSOPS))
(\DEFINEDISPLAYINFO \DORADOCOLORINFO)))
(\DEFINEDISPLAYINFO \DORADOCOLORINFO])
(\DORADOCOLOR.STARTCOLOR
(LAMBDA (FDEV) (* kbr: "21-Aug-85 15:55")
(DECLARE (GLOBALVARS \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL))
(PROG (DISPLAYSTATE MCB AC CB)
(COND
((EQ (MACHINETYPE)
(QUOTE DORADO))
(SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE STARTCOLOR))
(MOVD (QUOTE \DISPLAY.PILOTBITBLT)
(QUOTE \SOFTCURSORPILOTBITBLT))
(\LOCKFN (QUOTE \SOFTCURSORPILOTBITBLT))
(SETQ MCB (EMADDRESS MCBLow))
(SETQ AC (EMADDRESS ChCBLow))
(SETQ CB (EMADDRESS ColCBLow))
(\ZEROWORDS MCB (\ADDBASE MCB MCBSize))
(\ZEROWORDS AC (\ADDBASE AC ChCBSize))
(\ZEROWORDS CB (\ADDBASE CB ColCBSize)) (* Set up color control block)
(OR \DORADOCOLOR.ATABLEIMAGE (SETQ \DORADOCOLOR.ATABLEIMAGE (\ALLOCBLOCK (ITIMES
CMapPages 128)
NIL 128)))
(\TEMPLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages)
(replace (ColorCB ATableHi) of CB with (\HILOC \DORADOCOLOR.ATABLEIMAGE))
(* Reverse pointer)
(replace (ColorCB ATableLo) of CB with (\LOLOC \DORADOCOLOR.ATABLEIMAGE))
(replace (ColorCB VBtoVS) of CB with 3)
(replace (ColorCB VStoVS) of CB with 3)
(replace (ColorCB VStoVB) of CB with 16)
(replace (ColorCB VisibleLines) of CB with 240)
(replace (ColorCB X) of CB with 379)
(replace (ColorCB W) of CB with 6)
(replace (ColorCB A) of CB with 35)
(replace (ColorCB BtoA) of CB with 18)
(replace (ColorCB clockm) of CB with 88)
(replace (ColorCB clockd) of CB with 12) (* set up channel control block)
(replace (ChannelCB wordsPerLine) of AC with (FOLDHI (ITIMES DORADO\COLORSCREENWIDTH
DORADOCOLOR.BITSPERPIXEL)
BITSPERWORD))
(SETQ ColorScreenBitMapBase (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap))
(\TEMPLOCKPAGES ColorScreenBitMapBase DORADOCOLORPAGES)
(replace (ChannelCB bitmapHi) of AC with (\HILOC ColorScreenBitMapBase))
(replace (ChannelCB bitmapLo) of AC with (\LOLOC ColorScreenBitMapBase))
(replace (ChannelCB linesPerField) of AC with (IQUOTIENT DORADO\COLORSCREENHEIGHT 2))
(replace (ChannelCB pixelsPerLine) of AC with (IPLUS DORADO\COLORSCREENWIDTH pplOffset))
(replace (ChannelCB leftMargin) of AC with \DORADOCOLOR.LEFTMARGIN)
(replace (ChannelCB scan) of AC with (SELECTQ DORADOCOLOR.BITSPERPIXEL
(4
(* Magic constants = 164B)
116)
(8
(* Magic constants = 170B)
120)
(\ILLEGAL.ARG DORADOCOLOR.BITSPERPIXEL)))
(replace (MonitorCB Seal) of MCB with MCBSeal)
(replace (MonitorCB Flags) of MCB with 60)
(replace (MonitorCB ACB) of MCB with ChCBLow)
(* Wyatt used an empty A bitmap to establish scan mode.
Why? We dont)
(replace (MonitorCB colorCB) of MCB with ColCBLow)
(EMPUTBASE MCBPtr MCBLow)
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE ON)))))))
[LAMBDA (FDEV) (* kbr%: "21-Aug-85 15:55")
(DECLARE (GLOBALVARS \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL))
(PROG (DISPLAYSTATE MCB AC CB)
(COND
((EQ (MACHINETYPE)
'DORADO)
(SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STARTCOLOR)
(MOVD '\DISPLAY.PILOTBITBLT '\SOFTCURSORPILOTBITBLT)
(\LOCKFN '\SOFTCURSORPILOTBITBLT)
(SETQ MCB (EMADDRESS MCBLow))
(SETQ AC (EMADDRESS ChCBLow))
(SETQ CB (EMADDRESS ColCBLow))
(\ZEROWORDS MCB (\ADDBASE MCB MCBSize))
(\ZEROWORDS AC (\ADDBASE AC ChCBSize))
(\ZEROWORDS CB (\ADDBASE CB ColCBSize)) (* Set up color control block)
(OR \DORADOCOLOR.ATABLEIMAGE (SETQ \DORADOCOLOR.ATABLEIMAGE (\ALLOCBLOCK (ITIMES
CMapPages
128)
NIL 128)))
(\TEMPLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages)
(replace (ColorCB ATableHi) of CB with (\HILOC \DORADOCOLOR.ATABLEIMAGE))
(* Reverse pointer)
(replace (ColorCB ATableLo) of CB with (\LOLOC \DORADOCOLOR.ATABLEIMAGE))
(replace (ColorCB VBtoVS) of CB with 3)
(replace (ColorCB VStoVS) of CB with 3)
(replace (ColorCB VStoVB) of CB with 16)
(replace (ColorCB VisibleLines) of CB with 240)
(replace (ColorCB X) of CB with 379)
(replace (ColorCB W) of CB with 6)
(replace (ColorCB A) of CB with 35)
(replace (ColorCB BtoA) of CB with 18)
(replace (ColorCB clockm) of CB with 88)
(replace (ColorCB clockd) of CB with 12)
(* set up channel control block)
(replace (ChannelCB wordsPerLine) of AC with (FOLDHI (ITIMES
DORADO\COLORSCREENWIDTH
DORADOCOLOR.BITSPERPIXEL
)
BITSPERWORD))
(SETQ ColorScreenBitMapBase (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap))
(\TEMPLOCKPAGES ColorScreenBitMapBase DORADOCOLORPAGES)
(replace (ChannelCB bitmapHi) of AC with (\HILOC ColorScreenBitMapBase))
(replace (ChannelCB bitmapLo) of AC with (\LOLOC ColorScreenBitMapBase))
(replace (ChannelCB linesPerField) of AC with (IQUOTIENT
DORADO\COLORSCREENHEIGHT
2))
(replace (ChannelCB pixelsPerLine) of AC with (IPLUS
DORADO\COLORSCREENWIDTH
pplOffset))
(replace (ChannelCB leftMargin) of AC with \DORADOCOLOR.LEFTMARGIN)
(replace (ChannelCB scan) of AC with (SELECTQ DORADOCOLOR.BITSPERPIXEL
(4
(* Magic constants = |164B|)
116)
(8
(* Magic constants = |170B|)
120)
(\ILLEGAL.ARG
DORADOCOLOR.BITSPERPIXEL)))
(replace (MonitorCB Seal) of MCB with MCBSeal)
(replace (MonitorCB Flags) of MCB with 60)
(replace (MonitorCB ACB) of MCB with ChCBLow)
(* Wyatt used an empty A bitmap to
 establish scan mode.
 Why? We dont)
(replace (MonitorCB colorCB) of MCB with ColCBLow)
(EMPUTBASE MCBPtr MCBLow)
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'ON])
(\DORADOCOLOR.STOPCOLOR
(LAMBDA (FDEV) (* kbr: "21-Aug-85 15:56")
(PROG (DISPLAYSTATE MCB)
(SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE STOPCOLOR))
(SETQ MCB (EMADDRESS MCBLow))
[LAMBDA (FDEV) (* kbr%: "21-Aug-85 15:56")
(PROG (DISPLAYSTATE MCB)
(SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STOPCOLOR)
(SETQ MCB (EMADDRESS MCBLow))
(replace (MonitorCB ACB) of MCB with 0)
(\ZEROWORDS \DORADOCOLOR.ATABLEIMAGE (\ADDBASE \DORADOCOLOR.ATABLEIMAGE 32))
(* Black)
(\ZEROWORDS \DORADOCOLOR.ATABLEIMAGE (\ADDBASE \DORADOCOLOR.ATABLEIMAGE 32))
(* Black)
(\DORADOCOLOR.LOOKATA MCB)
(EMPUTBASE MCBPtr 0)
(\TEMPUNLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages)
(\TEMPUNLOCKPAGES (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap)
DORADOCOLORPAGES)
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with (QUOTE OFF)))))
(\TEMPUNLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages)
(\TEMPUNLOCKPAGES (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap)
DORADOCOLORPAGES)
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'OFF])
(\DORADOCOLOR.EVENTFN
(LAMBDA (FDEV EVENT) (* kbr: "24-Aug-85 16:55")
(COND
((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV))
(QUOTE ON))
(SELECTQ EVENT
((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS)
(* turn off display since we may awake on different 
machine)
(COLORDISPLAY (QUOTE OFF)))
(AFTERSAVEVM (* Rekick the color microcode.
*)
(\DORADOCOLOR.STARTCOLOR \COLORDISPLAYFDEV)
(SCREENCOLORMAP (SCREENCOLORMAP)))
NIL)))))
[LAMBDA (FDEV EVENT) (* kbr%: "24-Aug-85 16:55")
(COND
((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV))
'ON)
(SELECTQ EVENT
((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS) (* turn off display since we may
 awake on different machine)
(COLORDISPLAY 'OFF))
(AFTERSAVEVM (* Rekick the color microcode.
 *)
(\DORADOCOLOR.STARTCOLOR \COLORDISPLAYFDEV)
(SCREENCOLORMAP (SCREENCOLORMAP)))
NIL])
(\DORADOCOLOR.SENDCOLORMAPENTRY
(LAMBDA (FDEV COLOR# RGB) (* kbr: " 5-Jul-85 15:06")
(PROG (ScratchColorEntry J)
(SETQ ScratchColorEntry (\RGB.TO.DORADO.RGB (LIST 0 0 0)))
(OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT))
(SETQ J (ITIMES COLOR# 8))
[LAMBDA (FDEV COLOR# RGB) (* kbr%: " 5-Jul-85 15:06")
(PROG (ScratchColorEntry J)
(SETQ ScratchColorEntry (\RGB.TO.DORADO.RGB (LIST 0 0 0)))
(OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT))
(SETQ J (ITIMES COLOR# 8))
(\RGB.TO.DORADO.RGB RGB ScratchColorEntry)
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE ScratchColorEntry 0))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J)
(\GETBASE ScratchColorEntry 1))
(\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow)))))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE ScratchColorEntry 0))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J)
(\GETBASE ScratchColorEntry 1))
(\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow])
)
(DEFINEQ
(\DORADOCOLOR.COLORLEVEL
(LAMBDA (DISPLAY COLOR# PRIMARYCOLOR NEWLEVEL) (* kbr: " 5-Jul-85 15:23")
(PROG (REALCOLOR# COLORMAP ColorEntry)
(SETQ REALCOLOR# (COLORNUMBERP COLOR#))
(SETQ COLORMAP (SCREENCOLORMAP NIL DISPLAY))
(SETQ ColorEntry (COLORMAPENTRY COLORMAP REALCOLOR#))
(PROG1 (\GENERIC.COLORLEVEL COLORMAP REALCOLOR# PRIMARYCOLOR NEWLEVEL)
(* destructively modifies ColorEntry entry of COLORMAP 
to have correct level of PRIMARYCOLOR)
(\DORADOCOLOR.SETONECOLOR ColorEntry REALCOLOR#)))))
[LAMBDA (DISPLAY COLOR# PRIMARYCOLOR NEWLEVEL) (* kbr%: " 5-Jul-85 15:23")
(PROG (REALCOLOR# COLORMAP ColorEntry)
(SETQ REALCOLOR# (COLORNUMBERP COLOR#))
(SETQ COLORMAP (SCREENCOLORMAP NIL DISPLAY))
(SETQ ColorEntry (COLORMAPENTRY COLORMAP REALCOLOR#))
(PROG1 (\GENERIC.COLORLEVEL COLORMAP REALCOLOR# PRIMARYCOLOR NEWLEVEL)
(* destructively modifies ColorEntry
 entry of COLORMAP to have correct
 level of PRIMARYCOLOR)
(\DORADOCOLOR.SETONECOLOR ColorEntry REALCOLOR#))])
(\DORADOCOLOR.SETONECOLOR
(LAMBDA (RGBTRIPLE COLOR#) (* kbr: " 5-Jul-85 15:24")
(PROG (DORADOFORMATCOLORCELL J)
(OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT))
(SETQ DORADOFORMATCOLORCELL (\RGB.TO.DORADO.RGB RGBTRIPLE))
(SETQ J (LLSH COLOR# (IDIFFERENCE 11 DORADOCOLOR.BITSPERPIXEL)))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE DORADOFORMATCOLORCELL 0))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J)
(\GETBASE DORADOFORMATCOLORCELL 1))
(\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow)))))
[LAMBDA (RGBTRIPLE COLOR#) (* kbr%: " 5-Jul-85 15:24")
(PROG (DORADOFORMATCOLORCELL J)
(OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT))
(SETQ DORADOFORMATCOLORCELL (\RGB.TO.DORADO.RGB RGBTRIPLE))
(SETQ J (LLSH COLOR# (IDIFFERENCE 11 DORADOCOLOR.BITSPERPIXEL)))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE DORADOFORMATCOLORCELL 0))
(\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J)
(\GETBASE DORADOFORMATCOLORCELL 1))
(\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow])
)
(FILESLOAD COLOR)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\DORADOCOLOR.INIT)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(\DORADOCOLOR.INIT)
)
(PUTPROPS DORADOCOLOR COPYRIGHT ("Xerox Corporation" 1985 1900 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5142 6333 (\RGB.TO.DORADO.RGB 5152 . 5872) (\DORADOCOLOR.LOOKATA 5874 . 6331)) (6334
13812 (\DORADOCOLOR.INIT 6344 . 7610) (\DORADOCOLOR.STARTCOLOR 7612 . 11482) (\DORADOCOLOR.STOPCOLOR
11484 . 12431) (\DORADOCOLOR.EVENTFN 12433 . 13153) (\DORADOCOLOR.SENDCOLORMAPENTRY 13155 . 13810)) (
13813 15147 (\DORADOCOLOR.COLORLEVEL 13823 . 14500) (\DORADOCOLOR.SETONECOLOR 14502 . 15145)))))
(PUTPROPS DORADOCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1900 1986 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4684 6340 (\RGB.TO.DORADO.RGB 4694 . 5814) (\DORADOCOLOR.LOOKATA 5816 . 6338)) (6341
15289 (\DORADOCOLOR.INIT 6351 . 7530) (\DORADOCOLOR.STARTCOLOR 7532 . 12956) (\DORADOCOLOR.STOPCOLOR
12958 . 13864) (\DORADOCOLOR.EVENTFN 13866 . 14669) (\DORADOCOLOR.SENDCOLORMAPENTRY 14671 . 15287)) (
15290 16679 (\DORADOCOLOR.COLORLEVEL 15300 . 16071) (\DORADOCOLOR.SETONECOLOR 16073 . 16677)))))
STOP

BIN
lispusers/DORADOCOLOR.TEDIT Normal file
View File

Binary file not shown.