From 25e791de4f65a3089f5b23bae62c4aa4b6618b25 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Sun, 3 Jul 2022 21:24:36 -0700 Subject: [PATCH] pull more newer library lispusers internal(/library) files from envos (#813) --- internal/COPRFIX | 57 + internal/envos/AR-11348-PATCH | 59 + internal/envos/AR-PIECETREE-PATCH | 119 ++ internal/envos/ARADMIN | 727 ++++++++ internal/envos/AREDIT.STATUS | 1 + internal/envos/CLMAIL | 365 ++++ internal/envos/CMLHELP | 209 +++ internal/envos/COLORFONTHACK | 48 + internal/envos/COMMON-LISP-PACKAGE | 32 + internal/envos/DSKTEST | 1144 ++++++++++++ internal/envos/DSKTEST.TEDIT | Bin 0 -> 2351 bytes internal/envos/FILEBANGER | 305 +++ internal/envos/FLOPPYTESTER | 105 ++ internal/envos/FLOPPYWORK | 70 + internal/envos/GIVE-AND-TAKE.STATUS | 1 + internal/envos/GRAPEVINE | 1362 ++++++++++++++ internal/envos/LARGESKETCHPATCH | 71 + internal/envos/LFHACKS | 506 +++++ internal/envos/LISPDIAGNOSTICS | 815 ++++++++ internal/envos/LISPDIAGNOSTICS.TEDIT | Bin 0 -> 2428 bytes internal/envos/NSMAIL | 1741 ++++++++++++++++++ internal/envos/NSMAIL.TEDIT | Bin 0 -> 7187 bytes internal/envos/READINTERPRESS | 96 + internal/envos/RS232TEST | 242 +++ internal/envos/SKETCHCOLOR | 105 ++ internal/envos/SOURCELOOKUP | 109 ++ internal/envos/SOURCELOOKUP.TEDIT | Bin 0 -> 2486 bytes internal/envos/STACKHACK | 54 + internal/envos/TEDITCOLOR | 401 ++++ internal/envos/USPS | 194 ++ internal/envos/datepatch | 97 + internal/envos/datepatch.tedit | Bin 0 -> 6691 bytes internal/envos/filebanger.tedit | Bin 0 -> 4686 bytes internal/envos/internal-library-readme.tedit | 3 + internal/envos/unixmail.tedit | Bin 0 -> 7709 bytes internal/envos/vpcdisk-setup.tedit | Bin 0 -> 4192 bytes library/COLOR-BRAINSTORMING.TXT | Bin 0 -> 3220 bytes library/COLOR.TEDIT | 236 +++ library/MAIKOCOLOR | 1243 ++++--------- library/MAIKOCOLOR.TEDIT | Bin 0 -> 5288 bytes lispusers/COLORDEMO | 1118 ++++++----- lispusers/COLORDEMO.TEDIT | Bin 0 -> 5671 bytes lispusers/COLORNNCC.TEDIT | Bin 0 -> 6245 bytes lispusers/COLOROBJ | 138 +- lispusers/COLOROBJ.TEDIT | Bin 0 -> 2501 bytes lispusers/DORADOCOLOR | 399 ++-- lispusers/DORADOCOLOR.TEDIT | Bin 0 -> 7134 bytes 47 files changed, 10448 insertions(+), 1724 deletions(-) create mode 100644 internal/COPRFIX create mode 100644 internal/envos/AR-11348-PATCH create mode 100644 internal/envos/AR-PIECETREE-PATCH create mode 100644 internal/envos/ARADMIN create mode 100644 internal/envos/AREDIT.STATUS create mode 100644 internal/envos/CLMAIL create mode 100644 internal/envos/CMLHELP create mode 100644 internal/envos/COLORFONTHACK create mode 100644 internal/envos/COMMON-LISP-PACKAGE create mode 100644 internal/envos/DSKTEST create mode 100644 internal/envos/DSKTEST.TEDIT create mode 100644 internal/envos/FILEBANGER create mode 100644 internal/envos/FLOPPYTESTER create mode 100644 internal/envos/FLOPPYWORK create mode 100644 internal/envos/GIVE-AND-TAKE.STATUS create mode 100644 internal/envos/GRAPEVINE create mode 100644 internal/envos/LARGESKETCHPATCH create mode 100644 internal/envos/LFHACKS create mode 100644 internal/envos/LISPDIAGNOSTICS create mode 100644 internal/envos/LISPDIAGNOSTICS.TEDIT create mode 100644 internal/envos/NSMAIL create mode 100644 internal/envos/NSMAIL.TEDIT create mode 100644 internal/envos/READINTERPRESS create mode 100644 internal/envos/RS232TEST create mode 100644 internal/envos/SKETCHCOLOR create mode 100644 internal/envos/SOURCELOOKUP create mode 100644 internal/envos/SOURCELOOKUP.TEDIT create mode 100644 internal/envos/STACKHACK create mode 100644 internal/envos/TEDITCOLOR create mode 100644 internal/envos/USPS create mode 100644 internal/envos/datepatch create mode 100644 internal/envos/datepatch.tedit create mode 100644 internal/envos/filebanger.tedit create mode 100644 internal/envos/internal-library-readme.tedit create mode 100644 internal/envos/unixmail.tedit create mode 100644 internal/envos/vpcdisk-setup.tedit create mode 100644 library/COLOR-BRAINSTORMING.TXT create mode 100644 library/COLOR.TEDIT create mode 100644 library/MAIKOCOLOR.TEDIT create mode 100644 lispusers/COLORDEMO.TEDIT create mode 100644 lispusers/COLORNNCC.TEDIT create mode 100644 lispusers/COLOROBJ.TEDIT create mode 100644 lispusers/DORADOCOLOR.TEDIT diff --git a/internal/COPRFIX b/internal/COPRFIX new file mode 100644 index 00000000..ffc32691 --- /dev/null +++ b/internal/COPRFIX @@ -0,0 +1,57 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "12-Jun-90 18:10:37" |{DSK}local>lde>lispcore>internal>COPRFIX.;1| 1909 + + |changes| |to:| (FNS FIX-FILE) + + |previous| |date:| "11-Jun-90 13:13:14" |{DSK}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 diff --git a/internal/envos/AR-11348-PATCH b/internal/envos/AR-11348-PATCH new file mode 100644 index 00000000..ead9947d --- /dev/null +++ b/internal/envos/AR-11348-PATCH @@ -0,0 +1,59 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "22-Mar-91 18:37:25" {DSK}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 diff --git a/internal/envos/AR-PIECETREE-PATCH b/internal/envos/AR-PIECETREE-PATCH new file mode 100644 index 00000000..919fba31 --- /dev/null +++ b/internal/envos/AR-PIECETREE-PATCH @@ -0,0 +1,119 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 10:42:39"  +{DSK}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}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 diff --git a/internal/envos/ARADMIN b/internal/envos/ARADMIN new file mode 100644 index 00000000..83459ff8 --- /dev/null +++ b/internal/envos/ARADMIN @@ -0,0 +1,727 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "27-Nov-90 10:25:47" |{PALLAS:MV:ENVOS}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}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}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}local>lde>rooms>sources>" "{DSK}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}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}local>lde>rooms>sources>" "{DSK}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}SUMMARIES>*.TXT;L" '(DELETE)) + (DIRECTORY "{AR:MV:ENVOS}SUMMARIES>*.IP;L" '(DELETE)) + (AND (> (LENGTH (DIRECTORY "{AR:MV:ENVOS}AR.INDEX")) + 2) + (PRINTOUT T ";;; Deleting AR.INDEX ... " (DELFILE "{AR:MV:ENVOS}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}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}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}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}maiko>working>src>*" "{Fuusen:KSPA:Fuji Xerox}Emul>working>src>*" "{DSK}medley-trickles/emulator/src-" ,*FUJI-TRICKLE-MAIL-ADDRESS* "06:00" NIL NIL) + (TIMES 60 (RAND 10 60))) + (SETREMINDER NIL NIL `(|Smart-Trickle| "{DSK}maiko>working>inc>*" "{Fuusen:KSPA:Fuji Xerox}Emul>working>inc>*" "{DSK}medley-trickles/emulator/inc-" ,*FUJI-TRICKLE-MAIL-ADDRESS* "07:00" NIL NIL) + (TIMES 60 (RAND 10 60))) + (SETREMINDER NIL NIL `(|Smart-Trickle| "{DSK}maiko>working>bin>*" "{Fuusen:KSPA:Fuji Xerox}Emul>working>bin>*" "{DSK}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}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}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}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}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}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}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}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}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}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}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 --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}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 diff --git a/internal/envos/AREDIT.STATUS b/internal/envos/AREDIT.STATUS new file mode 100644 index 00000000..888770e0 --- /dev/null +++ b/internal/envos/AREDIT.STATUS @@ -0,0 +1 @@ +"SYBALSKY.ENVOS" "25-Jun-90 17:42:20" diff --git a/internal/envos/CLMAIL b/internal/envos/CLMAIL new file mode 100644 index 00000000..2bf56a92 --- /dev/null +++ b/internal/envos/CLMAIL @@ -0,0 +1,365 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "14-Jun-90 20:54:42" {DSK}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}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}CLMAIL>MSGHASH) + +(RPAQQ CLM.HEADHASHNAME {ERIS}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}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 diff --git a/internal/envos/CMLHELP b/internal/envos/CMLHELP new file mode 100644 index 00000000..36d2db44 --- /dev/null +++ b/internal/envos/CMLHELP @@ -0,0 +1,209 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") +(IL:FILECREATED "15-Jun-90 11:50:26" IL:|{DSK}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}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}PCL>| + IL:{ERIS}CODE> + IL:{ERIS}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}PCL>| IL:{ERIS}CODE> + IL:{ERIS}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}manual>cml.hash + 'il:input) + 'il:{eris}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 diff --git a/internal/envos/COLORFONTHACK b/internal/envos/COLORFONTHACK new file mode 100644 index 00000000..3ad2cab3 --- /dev/null +++ b/internal/envos/COLORFONTHACK @@ -0,0 +1,48 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 12:33:48" |{DSK}local>lde>lispcore>internal>library>COLORFONTHACK.;2| 2214 + + |changes| |to:| (VARS COLORFONTHACKCOMS) + + |previous| |date:| " 6-Dec-88 21:52:32" +|{DSK}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 diff --git a/internal/envos/COMMON-LISP-PACKAGE b/internal/envos/COMMON-LISP-PACKAGE new file mode 100644 index 00000000..22bcb61e --- /dev/null +++ b/internal/envos/COMMON-LISP-PACKAGE @@ -0,0 +1,32 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED " 2-Feb-91 14:33:36" |{DSK}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}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 diff --git a/internal/envos/DSKTEST b/internal/envos/DSKTEST new file mode 100644 index 00000000..700adcc1 --- /dev/null +++ b/internal/envos/DSKTEST @@ -0,0 +1,1144 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "15-Jun-90 14:09:54" {DSK}local>lde>lispcore>internal>library>DSKTEST.;2 62325 + + changes to%: (VARS DSKTESTCOMS) + (FNS TESTEOFOP) + + previous date%: " 7-Dec-88 11:51:36" {DSK}local>lde>lispcore>internal>library>DSKTEST.;1 +) + + +(* ; " +Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DSKTESTCOMS) + +(RPAQQ DSKTESTCOMS + ( + (* ;; "This program is a file system tester. It is suitable for testing any random-access filing device. It is NOT intended for customer release. DSKTEST is the entry function.") + + (FNS DSKTEST DELETETESTFILES) + (FNS CHECKCONSISTENCY CHECKLENGTHANDCONTENTS CHOOSERANDOMFILEOPERATION DEFAULT.DSKFREEPAGESFN + DEFAULT.DSKMINALLOCFN DEFAULT.DSKPAGESOVERHEADFN DOTESTFILEOP DSKFREEPAGES DSKMINALLOC + DSKPAGESOVERHEAD EXTENDTESTFILE FILEINFOFROMFILE GENERATEADDFILEOP GENERATECHANGEFILEOP + GENERATEDELETEFILEOP GENERATEEOFPFILEOP GENERATEPEEKBINFILEOP GENERATEDELETEALLFILEOP + RANDOMELT RANDOMFILELENGTH RANDOMFILENAME RANDOMSTR RANDOMTESTFILE SORTBYCAR TESTFILEP + TESTEOFP TESTEOFOP TESTFILEPTR TESTPEEKBIN TRUNCATETESTFILE WORDIN WORDOUT DOUBLEWORDIN + DOUBLEWORDOUT WRITETESTFILE WRITETESTFILELENGTH) + (VARS (DSKFREEPAGESFN (FUNCTION DEFAULT.DSKFREEPAGESFN)) + (DSKPAGESOVERHEADFN (FUNCTION DEFAULT.DSKPAGESOVERHEADFN)) + (DSKMINALLOCFN (FUNCTION DEFAULT.DSKMINALLOCFN))) + [VARS (MINTESTFILELENGTH 10) + (FIRSTTESTWORD 48094) + (SECONDTESTWORD 56187) + (NUMBEROFTESTBYTES 5) + (EXHAUSTIVETESTFLG) + (DEFAULTREPLAYFILE '{PHYLUM}DLIONFS>REPLAY.LOG) + (DONTCLOSEFILESFLG) + (LEGALFILENAMECHARS '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g + h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9)) + (LEGALFIRSTFILENAMECHARS '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d + e f g h i j k l m n o p q r s t u v w x y z] + (VARS (MINFILENAMELENGTH 1) + (MAXFILENAMELENGTH 15) + (MINFILEEXTENSIONLENGTH 0) + (MAXFILEEXTENSIONLENGTH 6) + (MAXVERSION 64000) + TESTFILEPAGELENGTHS) + (GLOBALVARS FIRSTTESTWORD SECONDTESTWORD MINTESTFILELENGTH NUMBEROFTESTBYTES + EXHAUSTIVETESTFLG DSKFREEPAGESFN DSKPAGESOVERHEADFN TESTFILEPAGELENGTHS) + (RECORDS TESTFILEINFO TESTFILEOP))) + + + +(* ;; +"This program is a file system tester. It is suitable for testing any random-access filing device. It is NOT intended for customer release. DSKTEST is the entry function." +) + +(DEFINEQ + +(DSKTEST + [LAMBDA (HOST/DIR KEEPREPLAYFILEFLG NUMOPERATIONS CURRENTFILES? DSKTESTBACKUP LOGFILE REPLAYFILE) + (* ; "Edited 6-Dec-88 19:31 by jds") + (* ; + "note: SOME OF THIS MAY NOT BE IMPLEMENTED") + + (* ;; "this is a tester for file systems. Basically it adds, deletes, extends and truncates files of various names and versions checking the consistency of the file system after each operation. A log is kept of the operations so that it can be replayed to duplicate problems that may arise.") + + (* ;; "the two variables DSKFREEPAGESFN and DSKPAGESOVERHEADFN should be set to functions that return the number of free pages available and the overhead for a file with a given number of pages.") + + (* ;; "CURRENTFILES? controls what the tester does with current files. NIL means that their existance will be checked each time but not their contents. T means that the files will be copied into directory DSKTESTBACKUP {defaults is CORE} and their contents will be checked. DELETE will delete all of the test files before the test starts but will leave non test files on the directory. Files written by DSKTEST have a two word key plus length which marks them as DSKTEST files. The rest of them is all the same byte.") + + (* ;; "EXHAUSTIVEFLG if non-NIL indicates that every pass through, the entire contents of each file is checked. Otherwise NUMBEROFTESTBYTES random bytes are examined each time.") + + (* ;; "LOGFILE is where print of progress is put {default to T}. If KEEPREPLAYFILEFLG is T, REPLAYFILE is where the log of event suitable for replaying is kept {default is DEFAULTREPLAYFILE }. If KEEPREPLAYFILEFLG is a file name, events are taken from that file until the last one. Before the last event, BREAK1 is called.") + + (* ;; "DONTCLOSEFILESFLG if non-NIL indicates that files should be left open. This should be faster as it avoids opening and closing files.") + (* ; + "TESTFILEPAGELENGTHS is a list of page lengths that the files will be near.") + (COND + ((NOT (DIRECTORYNAME HOST/DIR)) + (CL:ERROR "Can't connect to directory ~A." HOST/DIR))) + (SETQ HOST/DIR (DIRECTORYNAME HOST/DIR)) + (RESETLST + (PROG ((NUMBEROFOPERATIONSDONE 0) + FILESINFO FILEOP X FROMREPLAYFILE STARTINGTIME) + [COND + [LOGFILE (SETQ LOGFILE (OPENSTREAM LOGFILE 'OUTPUT] + (T (SETQ LOGFILE T) + (COND + ([SETQ X (WFROMDS (GETSTREAM T 'OUTPUT] + (* ; "stop page holding") + (RESETSAVE (WINDOWPROP X 'PAGEFULLFN (FUNCTION NILL)) + (LIST 'WINDOWPROP X 'PAGEFULLFN NIL] + (COND + ((EQ KEEPREPLAYFILEFLG T) + (COND + [REPLAYFILE (SETQ REPLAYFILE (OPENSTREAM REPLAYFILE 'OUTPUT] + (T (SETQ REPLAYFILE DEFAULTREPLAYFILE)))(* ; + "create a replay file and save its full name.") + (SETQ REPLAYFILE (OPENSTREAM REPLAYFILE 'OUTPUT)) + (CLOSEF REPLAYFILE)) + (KEEPREPLAYFILEFLG (* ; "use replay file") + (COND + ((SETQ FROMREPLAYFILE (OPENSTREAM KEEPREPLAYFILEFLG 'INPUT)) + (SETFILEPTR FROMREPLAYFILE 0)) + (T (ERROR KEEPREPLAYFILEFLG "replay file not found"))) + (* ; + "set so that no replay will be made of this run.") + (SETQ KEEPREPLAYFILEFLG))) (* ; + "connect to the tested directory.") + (* ; + "RESETSAVE (CNDIR HOST/DIR) (LIST (QUOTE CNDIR) (DIRECTORYNAME T T))") + (COND + ((EQ CURRENTFILES? 'DELETE) + (printout LOGFILE "Deleting any test files ...." T) + (DELETETESTFILES HOST/DIR) + (printout LOGFILE T))) + [COND + [(AND CURRENTFILES? (NEQ CURRENTFILES? 'DELETE)) + (* ; + "check their contents after every sweep") + (printout T "Not implemented to check old file contents yet.") + + (* ;; "this should copy each file into the backup directory and set the copy as the contents of the file information for the non-test files.") + + (SETQ FILESINFO (for FILE in (SORT (DIRECTORY HOST/DIR)) + collect (FILEINFOFROMFILE FILE] + (T (SETQ FILESINFO (for FILE in (SORT (DIRECTORY HOST/DIR)) + collect (FILEINFOFROMFILE FILE] + (SETQ STARTINGTIME (DATE)) + (printout LOGFILE "Beginning initial check at " STARTINGTIME " ......") + (CHECKCONSISTENCY FILESINFO HOST/DIR) + (BLOCK) + (printout LOGFILE " done." T) + LP (SETQ NUMBEROFOPERATIONSDONE (ADD1 NUMBEROFOPERATIONSDONE)) + [COND + ((AND (NUMBERP NUMOPERATIONS) + (GREATERP NUMBEROFOPERATIONSDONE NUMOPERATIONS)) + (RETURN (LIST (SUB1 NUMBEROFOPERATIONSDONE) + 'operations% done.] (* ; "choose a new file operation") + [COND + [FROMREPLAYFILE (* ; + "getting events from the replay file") + (SETQ FILEOP (READ FROMREPLAYFILE)) + (SKIPSEPRS FROMREPLAYFILE) + (COND + ((EOFP FROMREPLAYFILE) + (CLOSEF FROMREPLAYFILE) + (SETQ FROMREPLAYFILE) + (BREAK1 T T "Before last event on replay file"] + (T (SETQ FILEOP (CHOOSERANDOMFILEOPERATION FILESINFO HOST/DIR] + [COND + (KEEPREPLAYFILEFLG (* ; + "put op on REPLAYFILE and make sure it gets there.") + (PROG [(STRM (OPENSTREAM REPLAYFILE 'APPEND] + (PRINT FILEOP STRM) + (CLOSEF STRM] + (printout LOGFILE ".......... start=" STARTINGTIME " time=" (DATE) + T) + (PRINT FILEOP LOGFILE) + (SETQ FILESINFO (DOTESTFILEOP FILEOP FILESINFO HOST/DIR LOGFILE)) + (printout LOGFILE "Consistency check after operation " NUMBEROFOPERATIONSDONE " .....") + (BLOCK) + [COND + ((NOT DONTCLOSEFILESFLG) + + (* ;; "All files dshould be closed at this point:") + + (for FILE in FILESINFO when (for OPENFILE in (OPENP) + thereis (EQ (FULLNAME OPENFILE) + (fetch (TESTFILEINFO + + TESTFILEFULLNAME + ) + of FILE))) + do (HELP "File open that shouldn't be:" (fetch (TESTFILEINFO + TESTFILEFULLNAME) + of FILE] + (CHECKCONSISTENCY FILESINFO HOST/DIR) + (printout LOGFILE " done." T) + (GO LP)))]) + +(DELETETESTFILES + [LAMBDA (HOST/DIR CHECKENTIRECONTENTSFLG) (* hts%: "22-Oct-84 16:27") + (* deletes any TEST files from + directory HOST/DIR) + (for FILE in (DIRECTORY HOST/DIR) when (TESTFILEP FILE (NOT CHECKENTIRECONTENTSFLG)) + do (if (OPENP FILE) + then (CLOSEF FILE)) + (PRINT (DELFILE FILE) + T]) +) +(DEFINEQ + +(CHECKCONSISTENCY + [LAMBDA (FILESINFO HOST/DIR) (* ; "Edited 2-Nov-87 13:55 by jds") + + (* ;; "checks that the state of the currently connected directory (or HOST/DIR, if given) is exactly the same as FILESINFO.") + + (PROG [(DIRFILES (SORT (DIRECTORY HOST/DIR] + (for DIRFILE in DIRFILES as FILEINFO in FILESINFO + do (BLOCK) + [COND + ((NEQ (U-CASE DIRFILE) + (U-CASE (fetch (TESTFILEINFO TESTFILEFULLNAME) of FILEINFO))) + (* ; + "something is wrong with the directory. Find out what") + + (COND + ((FASSOC (U-CASE DIRFILE) + (MEMB FILEINFO FILESINFO)) (* ; "this file shows up later") + + (ERROR "FILE MISSING .. " (fetch (TESTFILEINFO TESTFILEFULLNAME) of FILEINFO) + )) + (T (ERROR "NEW FILE HAS APPEARED .. " DIRFILE] + (CHECKLENGTHANDCONTENTS FILEINFO]) + +(CHECKLENGTHANDCONTENTS + [LAMBDA (FILEINFO) (* ; "Edited 4-Nov-87 11:24 by jds") + + (* ;; "checks the length and contents of a file from its in core representation.") + + (PROG ((STRM (OPENSTREAM (fetch (TESTFILEINFO TESTFILEFULLNAME) of FILEINFO) + 'INPUT)) + (FILELENGTH (fetch (TESTFILEINFO FILELENGTH) of FILEINFO)) + (STARTBYTE (fetch (TESTFILEINFO STARTBYTE) of FILEINFO)) + (PERIOD (fetch (TESTFILEINFO PERIOD) of FILEINFO))) + (COND + ([NOT (EQP FILELENGTH (GETFILEINFO STRM 'LENGTH] + (ERROR "FILE has wrong length ... " FILEINFO))) + [COND + ((AND STARTBYTE PERIOD (IGEQ FILELENGTH MINTESTFILELENGTH)) + + (* ;; "test files contain at least enough bytes to hold keys and stuff. Maybe should have a special test for zero length files.") + + (COND + ((OR (NEQ (WORDIN STRM) + FIRSTTESTWORD) + (NEQ (WORDIN STRM) + SECONDTESTWORD) + (NOT (EQP FILELENGTH (DOUBLEWORDIN STRM))) + (NEQ (BIN STRM) + STARTBYTE) + (NEQ (BIN STRM) + PERIOD)) + (ERROR "FIRST 10 bytes of file is wrong .. " FILEINFO))) + [COND + ((IGREATERP FILELENGTH MINTESTFILELENGTH) (* ; + "only bother checking if we have data bytes") + + (COND + ((EQ 1 (RAND 1 7)) + + (* ;; "SCAN ENTIRE FILE once in about every seven tests.") + + (bind READBYTE (CURVALUE _ STARTBYTE) + (BLOCKCOUNT _ 0) for COMPUTEDBYTE from STARTBYTE + to (IPLUS STARTBYTE FILELENGTH (IMINUS MINTESTFILELENGTH) + -1) by 1 when [PROGN (COND + ((ZEROP (SETQ BLOCKCOUNT + (IMOD (ADD1 BLOCKCOUNT) + 100))) + (BLOCK))) + (PROG1 (NEQ (SETQ READBYTE (\BIN STRM)) + CURVALUE) + (SETQ CURVALUE (IMOD (ADD1 CURVALUE) + PERIOD] + do (printout LOGFILE "FILE HAS WRONG BYTE .. " T "should have " + (IMOD COMPUTEDBYTE PERIOD) + " but read " READBYTE " from file" T "at location " + (SUB1 (GETFILEPTR STRM)) + T) + (ERROR "FILE HAS WRONG BYTE .. " FILEINFO))) + (T + +(* ;;; "SPOT CHECK FILE") + + [bind SPOT COMPUTEDBYTE READBYTE to 7 + do (BLOCK) + (SETQ SPOT (RAND MINTESTFILELENGTH (SUB1 FILELENGTH))) + (SETQ COMPUTEDBYTE (PLUS (MINUS MINTESTFILELENGTH) + SPOT STARTBYTE)) + (SETFILEPTR STRM SPOT) + (COND + ((NEQ (SETQ READBYTE (\BIN STRM)) + (IMOD COMPUTEDBYTE PERIOD)) + (printout LOGFILE "FILE HAS WRONG BYTE .. " T "should have " + (IMOD COMPUTEDBYTE PERIOD) + " but read " READBYTE " from file" T "at location " + (SUB1 (GETFILEPTR STRM)) + T) + (ERROR "FILE HAS WRONG BYTE .. " FILEINFO] + (SETFILEPTR STRM FILELENGTH] + (OR (EOFP STRM) + (ERROR "FILE doesn't get EOFP ... " FILEINFO] + (OR DONTCLOSEFILESFLG (CLOSEF STRM]) + +(CHOOSERANDOMFILEOPERATION + [LAMBDA (FILESINFO HOST/DIR) (* ; "Edited 2-Nov-87 12:25 by jds") + + (* ;; "chooses a random file operation add delete setlength on a random file and return a TESTFILEOP record for it.") + + (COND + [FILESINFO (PROG ((RANDNUM (RAND 1 300))) + (RETURN (COND + ((ILEQ RANDNUM 75) (* ; "add a file") + + (GENERATEADDFILEOP FILESINFO NIL HOST/DIR)) + ((ILEQ RANDNUM 125) (* ; "Change the length of a file") + + (GENERATECHANGEFILEOP FILESINFO HOST/DIR)) + ((ILEQ RANDNUM 175) (* ; "delete a file") + + (GENERATEDELETEFILEOP FILESINFO NIL HOST/DIR)) + ((ILEQ RANDNUM 225) (* ; "do EOFP test") + + (GENERATEEOFPFILEOP FILESINFO HOST/DIR)) + ((ILEQ RANDNUM 295) (* ; "do PEEKBIN test") + + (GENERATEPEEKBINFILEOP FILESINFO HOST/DIR)) + (T (* ; "delete all files once in a while") + + (GENERATEDELETEALLFILEOP] + (T (* ; "add a file") + + (GENERATEADDFILEOP FILESINFO NIL HOST/DIR]) + +(DEFAULT.DSKFREEPAGESFN + [LAMBDA (HOST/DIR) (* mjs "17-Apr-86 14:59") + (SELECTQ (FILENAMEFIELD HOST/DIR 'HOST) + (DSK (SELECTQ (MACHINETYPE) + ((DORADO) + (DISKFREEPAGES HOST)) + ((DANDELION DOVE) + (DISKFREEPAGES HOST/DIR)) + (MAIKO 500) + (SHOULDNT))) + (FLOPPY (FLOPPY.FREE.PAGES)) + (PCDISK (* remember to strip trailing colon + off of device name!!) + (VPCDISK.FREEPAGES (SUBATOM (FILENAMEFIELD HOST/DIR 'DEVICE) + 1 -2))) + MAX.SMALLP]) + +(DEFAULT.DSKMINALLOCFN + [LAMBDA (HOST/DIR) (* mjs "22-Jan-86 12:18") + (* Default minimum-allocation unit + function) + (SELECTQ (FILENAMEFIELD HOST/DIR 'HOST) + (DSK (SELECTQ (MACHINETYPE) + ((DANDELION DOVE) (* DLIONFS allocates 25 at a crackj.) + 25) + ((DOLPHIN DORADO) + 1) + (MAIKO 1) + (SHOULDNT))) + (FLOPPY 1) + 1]) + +(DEFAULT.DSKPAGESOVERHEADFN + [LAMBDA (HOST/DIR NEWFILELENGTH) (* mjs "22-Jan-86 12:18") + (* default overhead function) + (SELECTQ (FILENAMEFIELD HOST/DIR 'HOST) + (DSK (SELECTQ (MACHINETYPE) + ((DANDELION DOVE) + + (* * 11 is 5 for worst-case btree split on file, 5 for split on directory, 1 + for leaderpage; NEWFILELENGTH and \LFrunSize for maximum length file will + attain during allocation; and \LFrunSize for possible directory extension.) + + (PLUS 11 NEWFILELENGTH \LFrunSize \LFrunSize)) + ((DOLPHIN DORADO) + (IPLUS NEWFILELENGTH 5)) + (MAIKO (IPLUS NEWFILELENGTH 5)) + (SHOULDNT))) + (FLOPPY (IPLUS NEWFILELENGTH 5)) + (IPLUS NEWFILELENGTH 5]) + +(DOTESTFILEOP + [LAMBDA (FILEOP FILEINFOLST HOST/DIR LOGFILE) (* ; "Edited 7-Dec-88 06:03 by jds") + + (* ;; "performs a TESTFILEOPERATION and updates the incore idea about what the directory should now look like. Returns the changed FILEINFOLST.") + (* ; + "operation can be add, delete or changelength") + (SELECTQ (fetch (TESTFILEOP TESTOPERATION) of FILEOP) + (ADD [PROG ((FULLFILE (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP)) + (BYTELEN (fetch (TESTFILEOP TESTOPFILELENGTH) of FILEOP)) + (STARTBYTE (fetch (TESTFILEOP STARTBYTE) of FILEOP)) + (PERIOD (fetch (TESTFILEOP PERIOD) of FILEOP)) + (OLDDISKFREEPAGES (DSKFREEPAGES HOST/DIR))) + (COND + ((SETQ FULLFILE (WRITETESTFILE FULLFILE BYTELEN STARTBYTE PERIOD)) + (BLOCK)) + (T (ERROR "file wasn't written. " FILEOP))) + (COND + ((EQ FULLFILE T) + (HELP))) + (RETURN (SORTBYCAR (CONS (create TESTFILEINFO + TESTFILEFULLNAME _ FULLFILE + FILELENGTH _ BYTELEN + STARTBYTE _ STARTBYTE + PERIOD _ PERIOD + TESTFILEORIGNAME _ (fetch (TESTFILEOP + TESTOPFILENAME) + of FILEOP)) + FILEINFOLST]) + (DELETE (PROG ((DELFILEINFO (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP))) + (COND + ((DELFILE (fetch (TESTFILEINFO TESTFILEFULLNAME) of DELFILEINFO)) + (BLOCK)) + (T (ERROR "file won't delete" DELFILEINFO))) + (RETURN (REMOVE DELFILEINFO FILEINFOLST)))) + (DELETEALL (for F in FILEINFOLST unless (PROGN (BLOCK) + (DELFILE (fetch (TESTFILEINFO + + TESTFILEFULLNAME + ) + of F))) + do (ERROR "file won't delete" F)) + NIL) + (CHANGELENGTH (PROG ((TESTFILE (fetch (TESTFILEINFO TESTFILEFULLNAME) + of (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP + ))) + (NEWLENGTH (fetch (TESTFILEOP TESTOPFILELENGTH) of FILEOP)) + (OLDDISKFREEPAGES (DSKFREEPAGES HOST/DIR)) + NOWLENGTH CHANGEFILEINFO XFILEINFO) + (COND + ((SETQ CHANGEFILEINFO (for FILEINFO in FILEINFOLST + thereis (EQ (fetch (TESTFILEINFO + TESTFILEFULLNAME) + of FILEINFO) + TESTFILE))) + + (* ;; "look for the one on FILEINFOLST that has the same name as this one may have been read in from the replay file and not be EQ.") + + NIL) + (T (ERROR "changing a file that is not on file information list." + CHANGEFILEINFO) + (RETURN))) + (COND + ((IGREATERP NEWLENGTH (SETQ NOWLENGTH (fetch (TESTFILEINFO + FILELENGTH) + of CHANGEFILEINFO))) + (* ; "extend the file") + (EXTENDTESTFILE TESTFILE (fetch (TESTFILEINFO STARTBYTE) + of CHANGEFILEINFO) + (fetch (TESTFILEINFO PERIOD) of CHANGEFILEINFO) + NOWLENGTH NEWLENGTH) + (BLOCK)) + (T (* ; "truncate the file.") + (TRUNCATETESTFILE TESTFILE NEWLENGTH))) + (replace (TESTFILEINFO FILELENGTH) of CHANGEFILEINFO with + NEWLENGTH) + (RETURN FILEINFOLST))) + (EOFP (PROG ((TESTFILE (fetch (TESTFILEINFO TESTFILEFULLNAME) of (fetch + (TESTFILEOP + TESTOPFILENAME + ) + of FILEOP))) + (NEWLENGTH (fetch (TESTFILEOP TESTOPFILELENGTH) of FILEOP)) + (OLDDISKFREEPAGES (DSKFREEPAGES HOST/DIR)) + NOWLENGTH CHANGEFILEINFO XFILEINFO) + (COND + ((SETQ CHANGEFILEINFO (for FILEINFO in FILEINFOLST + thereis (EQ (fetch (TESTFILEINFO + TESTFILEFULLNAME) + of FILEINFO) + TESTFILE))) + + (* ;; "look for the one on FILEINFOLST that has the same name as this one may have been read in from the replay file and not be EQ.") + + NIL) + (T (ERROR "changing a file that is not on file information list." + CHANGEFILEINFO) + (RETURN))) + (TESTEOFP TESTFILE (fetch (TESTFILEINFO STARTBYTE) of CHANGEFILEINFO) + (fetch (TESTFILEINFO PERIOD) of CHANGEFILEINFO) + NEWLENGTH LOGFILE) + (replace (TESTFILEINFO FILELENGTH) of CHANGEFILEINFO with NEWLENGTH) + (RETURN FILEINFOLST))) + (PEEKBIN (PROG ((TESTFILE (fetch (TESTFILEINFO TESTFILEFULLNAME) + of (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP))) + CHANGEFILEINFO) + (COND + ((SETQ CHANGEFILEINFO (for FILEINFO in FILEINFOLST + thereis (EQ (fetch (TESTFILEINFO + TESTFILEFULLNAME + ) of + FILEINFO + ) + TESTFILE))) + + (* ;; "look for the one on FILEINFOLST that has the same name as this one may have been read in from the replay file and not be EQ.") + + NIL) + (T (ERROR "changing a file that is not on file information list." + CHANGEFILEINFO) + (RETURN))) + (TESTPEEKBIN TESTFILE NIL LOGFILE) + (RETURN FILEINFOLST))) + (ERROR "unknown file operation" FILEOP]) + +(DSKFREEPAGES + [LAMBDA (HOST/DIR) (* hts%: "29-Apr-84 16:23") + + (* returns the number of free pages in the connected directory if it knows how.) + + (APPLY* DSKFREEPAGESFN HOST/DIR]) + +(DSKMINALLOC + [LAMBDA (HOST/DIR) (* mjs "22-Jan-86 12:18") + + (* Calls the device dependent function that gives the minimum %# of pages the + file system will allocate at a crack.) + + (APPLY* DSKMINALLOCFN HOST/DIR]) + +(DSKPAGESOVERHEAD + [LAMBDA (HOST/DIR NEWFILELENGTH) (* mjs "22-Jan-86 12:18") + + (* calls the device dependent function that gives the overhead per file) + + (APPLY* DSKPAGESOVERHEADFN HOST/DIR NEWFILELENGTH]) + +(EXTENDTESTFILE + [LAMBDA (FILENAME STARTBYTE PERIOD OLDLENGTH NEWLENGTH)(* ; "Edited 7-Dec-88 05:59 by jds") + + (* ;; "extends a file by writing CONTENTS byte to it until it has length LONGERLENGTH.") + + (COND + ((OPENP FILENAME) (* ; + "file may be open already for read.") + (CLOSEF FILENAME))) + (PROG [(STRM (OPENSTREAM FILENAME 'BOTH] + (COND + ((NULL STRM) + (ERROR "file that it supposed to exist won't open for extending." FILENAME))) + (* ; + "update the length count stored in the file.") + (WRITETESTFILELENGTH STRM NEWLENGTH) + (SETFILEPTR STRM OLDLENGTH) + [for BYTE from (IPLUS STARTBYTE OLDLENGTH (IMINUS MINTESTFILELENGTH)) + to (IPLUS STARTBYTE NEWLENGTH (IMINUS MINTESTFILELENGTH) + -1) do (BOUT STRM (IMOD BYTE PERIOD)) + (COND + ((ZEROP (IMOD BYTE 100)) + (BLOCK] + (OR DONTCLOSEFILESFLG (CLOSEF STRM]) + +(FILEINFOFROMFILE + [LAMBDA (FILE) (* hts%: "22-Oct-84 15:44") + (* returns a TESTFILEINFO record of + information about FILE.) + + (* keep track of test files differently because contents can be represented as + a single byte.) + + (if (EQ FILE T) + then (HELP "FILE IS T!!?")) + (PROG ((CONTENTS (TESTFILEP FILE NIL T))) + (RETURN (create TESTFILEINFO + TESTFILEFULLNAME _ FILE + FILELENGTH _ (GETFILEINFO FILE 'LENGTH) + STARTBYTE _ (CAR CONTENTS) + PERIOD _ (CDR CONTENTS]) + +(GENERATEADDFILEOP + [LAMBDA (FILEINFOLST STOPIFCANTFLG HOST/DIR) (* edited%: "13-Aug-85 11:28") + (PROG ((LENGTH (RANDOMFILELENGTH HOST/DIR)) + (PERIOD (RAND 1 255))) + (RETURN (COND + (LENGTH (create TESTFILEOP + TESTOPERATION _ 'ADD + TESTOPFILENAME _ (RANDOMFILENAME HOST/DIR) + TESTOPFILELENGTH _ LENGTH + STARTBYTE _ (RAND 0 PERIOD) + PERIOD _ PERIOD)) + (STOPIFCANTFLG (ERROR "probably out of disk space.")) + (T (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR]) + +(GENERATECHANGEFILEOP + [LAMBDA (FILEINFOLST HOST/DIR) (* hts%: "29-Apr-84 16:29") + (PROG ((FILETOCHANGE (RANDOMTESTFILE FILEINFOLST)) + (LENGTH (RANDOMFILELENGTH HOST/DIR))) + (RETURN (COND + ((NULL FILETOCHANGE) (* create a file instead) + (GENERATEADDFILEOP FILEINFOLST T HOST/DIR)) + ((NULL LENGTH) (* if can't change the length, try + deleting a file.) + (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR)) + (T (create TESTFILEOP + TESTOPERATION _ 'CHANGELENGTH + TESTOPFILENAME _ FILETOCHANGE + TESTOPFILELENGTH _ LENGTH]) + +(GENERATEDELETEFILEOP + [LAMBDA (FILEINFOLST STOPIFNONEFLG HOST/DIR) (* hts%: "22-Oct-84 16:54") + (* generates a delete file operation.) + + (* if it can't, it generates an file operation to ADD unless STOPIFNONEFLG is T) + + (PROG ((FILETODEL (RANDOMTESTFILE FILEINFOLST))) + (RETURN (COND + (FILETODEL (create TESTFILEOP + TESTOPERATION _ 'DELETE + TESTOPFILENAME _ FILETODEL)) + (STOPIFNONEFLG (ERROR "No file to delete")) + (T (GENERATEADDFILEOP FILEINFOLST T HOST/DIR]) + +(GENERATEEOFPFILEOP + [LAMBDA (FILEINFOLST HOST/DIR) (* AJB "31-Jul-86 15:46") + (PROG ((FILETOCHANGE (RANDOMTESTFILE FILEINFOLST)) + (LENGTH (RANDOMFILELENGTH HOST/DIR))) + (RETURN (COND + ((NULL FILETOCHANGE) (* create a file instead) + (GENERATEADDFILEOP FILEINFOLST T HOST/DIR)) + ((NULL LENGTH) (* if can't change the length, try + deleting a file.) + (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR)) + (T (create TESTFILEOP + TESTOPERATION _ 'EOFP + TESTOPFILENAME _ FILETOCHANGE + TESTOPFILELENGTH _ LENGTH]) + +(GENERATEPEEKBINFILEOP + [LAMBDA (FILEINFOLST HOST/DIR) (* AJB " 1-Aug-86 10:14") + (PROG ((FILETOCHANGE (RANDOMTESTFILE FILEINFOLST))) + (RETURN (COND + ((NULL FILETOCHANGE) (* create a file instead) + (GENERATEADDFILEOP FILEINFOLST T HOST/DIR)) + ((NULL LENGTH) (* if can't change the length, try + deleting a file.) + (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR)) + (T (create TESTFILEOP + TESTOPERATION _ 'PEEKBIN + TESTOPFILENAME _ FILETOCHANGE]) + +(GENERATEDELETEALLFILEOP + [LAMBDA NIL (* hts%: " 5-Jun-84 08:58") + (create TESTFILEOP + TESTOPERATION _ 'DELETEALL]) + +(RANDOMELT + [LAMBDA (LST) (* rrb "27-Mar-84 09:59") + (* returns a random element of a list.) + (CAR (NTH LST (RAND 1 (LENGTH LST]) + +(RANDOMFILELENGTH + [LAMBDA (HOST/DIR) (* ; "Edited 2-Nov-87 12:27 by jds") + + (* ;; "returns a random file length. (In bytes) that's guaranteed to fit in the file system in its current state.") + + (PROG ((NPAGES (RANDOMELT TESTFILEPAGELENGTHS)) + (DSKPAGES (DSKFREEPAGES HOST/DIR)) + (MINALLOC (DSKMINALLOC HOST/DIR)) + FILEOVERHEAD) (* ; + "checks that there are enough free pages to store the file.") + + [COND + ((ILEQ DSKPAGES (IPLUS MINALLOC (DSKPAGESOVERHEAD HOST/DIR MINALLOC))) + + (* ;; "There is no room for this file under any conditions -- there aren't enough pages to allocate a minimum-sized file") + + (RETURN NIL)) + ((IGREATERP (IPLUS NPAGES (SETQ FILEOVERHEAD (DSKPAGESOVERHEAD HOST/DIR NPAGES))) + DSKPAGES) + + (* ;; "There is room for A file. Now pick a file size that will fit. FILEOVERHEAD should be a high estimate of the overhead for the file, since the new NPAGES will be lower than the prior number.") + + (SETQ NPAGES (IDIFFERENCE DSKPAGES FILEOVERHEAD] + (* ; + "weight to return a length around an even number of pages.") + + (RETURN (IMAX MINTESTFILELENGTH (IPLUS (ITIMES NPAGES BYTESPERPAGE) + (SELECTQ (RAND 0 3) + (0 0) + (1 1) + (2 -1) + (RAND -511 512]) + +(RANDOMFILENAME + [LAMBDA (HOST/DIR) (* mjs "18-Apr-86 08:27") + (* generates a random file name.) + (U-CASE (PACK* HOST/DIR (COND + [(EQ 'PCDISK (FILENAMEFIELD HOST/DIR 'HOST)) + (PACKFILENAME 'NAME (RANDOMSTR (RAND 1 6)) + 'EXTENSION + (RANDOMSTR (RAND 0 3] + (T (PACKFILENAME 'NAME (RANDOMSTR (RAND MINFILENAMELENGTH + MAXFILENAMELENGTH)) + 'EXTENSION + (RANDOMSTR (RAND MINFILEEXTENSIONLENGTH + MAXFILEEXTENSIONLENGTH)) + 'VERSION + (SELECTQ (RAND 0 1) + (0 (* give an explicit extension) + (RAND 1 MAXVERSION)) + NIL]) + +(RANDOMSTR + [LAMBDA (NCHARS) (* rrb "27-Mar-84 09:38") + (* returns a random string NCHARS + long.) + (PACK (CONS [CAR (NTH LEGALFIRSTFILENAMECHARS (RAND 1 (LENGTH LEGALFIRSTFILENAMECHARS] + (bind (%#LEGALFILENAMECHARS _ (LENGTH LEGALFILENAMECHARS)) for I from 1 + to (SUB1 NCHARS) collect (CAR (NTH LEGALFILENAMECHARS (RAND 1 %#LEGALFILENAMECHARS + ]) + +(RANDOMTESTFILE + [LAMBDA (FILEINFOLST) (* hts%: "22-Oct-84 16:10") + + (* chooses a random test file from FILEINFOLST. + This avoids deleting not test files.) + + (PROG ((NTESTFILES (for FILE in FILEINFOLST when (SMALLP (fetch (TESTFILEINFO STARTBYTE) + of FILE)) sum 1)) + NFILE) + (RETURN (if (NEQ NTESTFILES 0) + then (SETQ NFILE (RAND 1 NTESTFILES)) + (for FILE in FILEINFOLST when (SMALLP (fetch (TESTFILEINFO STARTBYTE) + of FILE)) + do (if (ZEROP (SETQ NFILE (SUB1 NFILE))) + then (RETURN FILE]) + +(SORTBYCAR + [LAMBDA (LST) (* ; "Edited 6-Dec-88 22:54 by jds") + (* sorts a list by its CARs) + (SORT LST (FUNCTION (LAMBDA (A B) + (ALPHORDER (U-CASE (CAR A)) + (U-CASE (CAR B]) + +(TESTFILEP + [LAMBDA (FILE HINTONLYFLG RETURNCONTENTSFLG) (* ; "Edited 3-Nov-87 16:26 by jds") + + (* ;; "determines if a file is a test file.") + + (PROG ((STRM (OPENSTREAM FILE 'INPUT)) + FILELENGTH STARTBYTE PERIOD) + (SETQ FILELENGTH (GETFILEINFO STRM 'LENGTH)) + (RETURN (PROG1 [COND + ((ILESSP FILELENGTH MINTESTFILELENGTH) + + (* ;; "test files contain at least enough bytes to hold keys and stuff. Maybe should have a special test for zero length files.") + + NIL) + ((AND (EQ (WORDIN STRM) + FIRSTTESTWORD) + (EQ (WORDIN STRM) + SECONDTESTWORD) + (EQP FILELENGTH (DOUBLEWORDIN STRM))) + (COND + (HINTONLYFLG (* ; + "if asking about hint only, don't check contents.") + + (COND + (RETURNCONTENTSFLG (CONS (BIN STRM) + (BIN STRM))) + (T FILE))) + (T (SETQ STARTBYTE (BIN STRM)) + (SETQ PERIOD (BIN STRM)) + (bind (RUNNINGVALUE _ STARTBYTE) for COMPUTEDBYTE from STARTBYTE + to (IPLUS STARTBYTE FILELENGTH -1 (IMINUS MINTESTFILELENGTH)) + when (PROG1 (NEQ (BIN STRM) + RUNNINGVALUE) + (SETQ RUNNINGVALUE (IMOD (ADD1 RUNNINGVALUE) + PERIOD))) + do (RETURN NIL) finally (RETURN (COND + (RETURNCONTENTSFLG + (CONS STARTBYTE PERIOD)) + (T FILE] + (CLOSEF STRM]) + +(TESTEOFP + [LAMBDA (FILENAME STARTBYTE PERIOD NEWLENGTH LOGFILE) (* ; "Edited 7-Dec-88 06:04 by jds") + + (* ;; "Test the EOFP method for this file device.") + + (COND + ((OPENP FILENAME) (* ; + "file may be open already for read.") + (CLOSEF FILENAME))) + (LET* [(STRM (OPENSTREAM FILENAME 'BOTH)) + (OLDLENGTH (GETFILEINFO STRM 'LENGTH] + (COND + ((NULL STRM) + (CL:WARN "file ~A won't open for end of file tests." FILENAME))) + [COND + [(SETFILEINFO STRM 'LENGTH NEWLENGTH) + (COND + ((NOT (= (\GETEOFPTR STRM) + NEWLENGTH)) + (CL:FORMAT LOGFILE "Changing file ~A to NEWLENGTH ~D didn't change EOFPTR. +" FILENAME NEWLENGTH) + (CL:WARN "Changing file ~A to NEWLENGTH ~D didn't change EOFPTR. +" FILENAME NEWLENGTH))) + (SETFILEPTR STRM NEWLENGTH) + (WRITETESTFILELENGTH STRM NEWLENGTH) + (CLOSEF STRM) + [COND + ((NOT (EQP (GETFILEINFO FILENAME 'LENGTH) + NEWLENGTH)) + (CL:FORMAT LOGFILE "Changing file ~A to NEWLENGTH ~D didn't take; length still ~D" + FILENAME NEWLENGTH (GETFILEINFO FILENAME 'LENGTH)) + (CL:WARN "Changing file ~A to NEWLENGTH ~D didn't take; length still ~D" FILENAME + NEWLENGTH (GETFILEINFO FILENAME 'LENGTH] + (SETQ STRM (OPENSTREAM FILENAME 'BOTH)) + (COND + ((NOT (EQP (GETFILEINFO FILENAME 'LENGTH) + NEWLENGTH)) + (CL:FORMAT LOGFILE + "Re-opening file ~A after changing to NEWLENGTH ~D lost new length. +" FILENAME NEWLENGTH) + (CL:WARN "Re-opening file ~A after changing to NEWLENGTH ~D lost new length. +" FILENAME NEWLENGTH))) + (TESTFILEPTR STRM NEWLENGTH LOGFILE) + (SETFILEINFO STRM 'LENGTH NEWLENGTH) + (CLOSEF STRM) + (COND + ((NOT (EQP (GETFILEINFO FILENAME 'LENGTH) + NEWLENGTH)) + (CL:WARN "Changing file ~A to NEWLENGTH ~D the second time didn't take either. +" FILENAME NEWLENGTH] + (T (SETQ NEWLENGTH (GETFILEINFO STRM 'LENGTH] + (SETQ STRM (OPENSTREAM FILENAME 'INPUT)) + [for I from 0 to (SUB1 NEWLENGTH) do (COND + ((EOFP STRM) + (ERROR "EARLY EOF" I))) + (BIN STRM) + finally (COND + ((NOT (EOFP STRM)) + (ERROR "EOFP not true at end of file"] + (TESTEOFOP STRM NEWLENGTH (FUNCTION ZERO) + 0 LOGFILE) + (TESTEOFOP STRM NEWLENGTH (FUNCTION NILL) + NIL LOGFILE) + (CLOSEF STRM) + (EXTENDTESTFILE FILENAME STARTBYTE PERIOD OLDLENGTH NEWLENGTH]) + +(TESTEOFOP + [LAMBDA (STREAM FILESIZE FN EOFVALUE LOGFILE) (* ; "Edited 15-Jun-90 14:04 by jds") + + (* ;; + "Test ENDOFSTREAMOP, using FN as the function to call (THAT FUNCTION SHOULD RETURN EOFVALUE)") + + (PRINTOUT LOGFILE %,, %,, "Testing with ENDOFSTREAMOP set to " FN T) + (SETFILEPTR STREAM 0) + (replace (STREAM ENDOFSTREAMOP) of STREAM with FN) + (for I from 0 to (SUB1 FILESIZE) do (COND + ((EOFP STREAM) + (ERROR "Early EOF at" I))) + (BIN STREAM) + finally (COND + ((NOT (EOFP STREAM)) + (ERROR "EOFP NIL at EOF."))) + (OR (EQ EOFVALUE (BIN STREAM)) + (ERROR "End-of-stream value not returned right from function " FN)) + (OR (EOFP STREAM) + (ERROR "EOFP is NIL after a BIN at EOF"]) + +(TESTFILEPTR + [LAMBDA (STRM FILESIZE LOGFILE) (* ; "Edited 7-Dec-88 11:42 by jds") + +(* ;;; "Test setting fileptr past EOF") + + (PRINTOUT LOGFILE .TAB 5 "Testing FILEPTR" T) + (PRINTOUT LOGFILE .TAB 10 "FILESIZE = " FILESIZE T) + (bind BYTE for FILEPTR in '(8192 512 4096 8191 513 4097 8193 511 4095) + do (PRINTOUT LOGFILE .TAB 10 "Setting EOF and FILEPTR to " FILESIZE T) + (SETFILEINFO STRM 'LENGTH FILESIZE) + (SETFILEPTR STRM FILESIZE) + (COND + ((NOT (EOFP STRM)) + (CL:WARN "EOFP not set at ~D " FILESIZE))) + (PRINTOUT LOGFILE .TAB 10 "FILESIZE extended by " FILEPTR T) + (SETFILEPTR STRM (IPLUS FILESIZE FILEPTR)) + [COND + ((CL:/= (IPLUS FILESIZE FILEPTR) + (GETFILEPTR STRM)) + (CL:WARN "FILEPOS wrong after SETFILEPTR; is ~D, should be ~D. +" (GETFILEPTR STRM) + (IPLUS FILESIZE FILEPTR] + (BOUT STRM 6) + [COND + ((CL:/= (IPLUS FILESIZE FILEPTR 1) + (GETFILEPTR STRM)) + (CL:WARN "FILEPOS wrong after BOUT; is ~D, should be ~D. +" (GETFILEPTR STRM) + (IPLUS FILESIZE FILEPTR 1] + (SETFILEPTR STRM FILESIZE) + (PRINTOUT LOGFILE .TAB 10 "Testing new allocated area = zero" T) + [for I from FILESIZE to (IPLUS FILESIZE FILEPTR -1) + do (COND + ((NEQ (BIN STRM) + 0) + (CL:WARN "Newly-allocated area not zeroed.") + (RETURN] + (PRINTOUT LOGFILE .TAB 10 "Testing new EOF and last byte written" T) + (COND + ((EOFP STRM) + (CL:WARN "Early EOF; before BINning file's last byte. +"))) + (COND + ((NEQ (SETQ BYTE (BIN STRM)) + 6) + (CL:WARN "BIN didn't return what was just BOUTed; was ~D, should be 6. +" BYTE))) + (COND + ((EOFP STRM)) + (T (CL:WARN "EOFP false after BINning file's final byte."))) + finally (SETFILEINFO STRM 'LENGTH FILESIZE) + (SETFILEPTR STRM FILESIZE]) + +(TESTPEEKBIN + [LAMBDA (FILE DONT.TRY.HARD.FLG LOGFILE) (* ; "Edited 3-Nov-88 11:23 by jds") + + (* ;; "Test the various cases of PEEKBIN") + + (PROG ((STRM (OPENSTREAM FILE 'INPUT 'OLD)) + STRMLEN) + (RESETLST + (RESETSAVE NIL (LIST 'CLOSEF? STRM)) + (SETQ STRMLEN (GETEOFPTR STRM)) + [for PTR in (APPEND [LIST 0 STRMLEN (IMAX (SUB1 STRMLEN) + 0) + (ADD1 STRMLEN) + (IPLUS (RAND 1 10) + (IMIN 16777200 (ITIMES (RAND 2 5) + STRMLEN] + (for X from -1 to STRMLEN by 512 + when (IGREATERP X 0) collect X) + (for X from 0 to STRMLEN by 512 collect + X) + (for X from 1 to STRMLEN by 512 collect + X) + (for X from 1 to 5 collect (RAND 0 STRMLEN)) + ) bind C.PEEK.NIL C.PEEK.T C.BIN PTR2 PTR3 + do (SETFILEPTR STRM PTR) + (SETQ C.PEEK.NIL (NLSETQ (\PEEKBIN STRM))) + (SETQ PTR2 (GETFILEPTR STRM)) + [COND + ((NOT DONT.TRY.HARD.FLG) + (COND + ((NOT (EQUAL PTR PTR2)) + (PRINTOUT LOGFILE "\PEEKBIN moving file ptr!" T] + (SETQ C.PEEK.T (NLSETQ (\PEEKBIN STRM T))) + (SETQ PTR3 (GETFILEPTR STRM)) + [COND + ((NOT DONT.TRY.HARD.FLG) + (COND + ((NOT (EQUAL PTR PTR3)) + (PRINTOUT LOGFILE "\PEEKBIN moving file ptr!" T] + (SETQ C.BIN (NLSETQ (BIN STRM))) + (COND + [(IGEQ PTR STRMLEN) (* ; "at EOS") + [COND + ((NOT DONT.TRY.HARD.FLG) + (COND + ((NOT (AND (EQUAL C.PEEK.NIL NIL) + (EQUAL C.PEEK.T '(NIL)) + (EQUAL C.BIN NIL))) + (PRINTOUT LOGFILE "\PEEKBIN or BIN not working correctly at EOS" T + ] + (COND + ((NOT DONT.TRY.HARD.FLG) + (COND + ((NOT (EQUAL (GETFILEPTR STRM) + PTR)) + (PRINTOUT LOGFILE "BIN moving fileptr at eos" T] + (T (* ; "before EOS") + (COND + ((NOT (AND (EQUAL C.PEEK.NIL C.PEEK.T) + (EQUAL C.PEEK.T C.BIN))) + (PRINTOUT LOGFILE "\PEEKBIN and BIN not returning same value!" T))) + (COND + ((NOT (EQUAL (GETFILEPTR STRM) + (ADD1 PTR))) + (PRINTOUT LOGFILE "BIN not moving ptr correctly!" T] + (CLOSEF? STRM))]) + +(TRUNCATETESTFILE + [LAMBDA (FILENAME NEWLENGTH) (* ; "Edited 3-Nov-87 13:43 by jds") + (* ; "truncates a test file") + [COND + ((OPENP FILENAME) (* ; + "file may be open already for read.") + (CLOSEF (OPENP FILENAME] + (PROG [(STRM (OPENSTREAM FILENAME 'BOTH] + (COND + ((NULL STRM) + (ERROR "file that it supposed to exist won't open for truncation." FILENAME))) + (WRITETESTFILELENGTH STRM NEWLENGTH) + (SETFILEPTR STRM NEWLENGTH) + (SETFILEINFO STRM 'LENGTH NEWLENGTH) + (CLOSEF STRM) + (COND + ((CL:/= (GETFILEINFO FILENAME 'LENGTH) + NEWLENGTH) + (CL:WARN "changing file ~A to NEWLENGTH ~D didn't take" FILENAME NEWLENGTH]) + +(WORDIN + [LAMBDA (STRM) (* rrb "27-Mar-84 14:37") + (* read two bytes from a stream) + (LOGOR (LLSH (\BIN STRM) + 8) + (\BIN STRM]) + +(WORDOUT + [LAMBDA (STRM WORD) (* bouts two bytes onto stream) + (\BOUT STRM (LRSH WORD 8)) + (\BOUT STRM (LOGAND WORD 255]) + +(DOUBLEWORDIN + [LAMBDA (FILE) (* jds " 3-JAN-83 16:08") + (IPLUS (LLSH (\BIN FILE) + 24) + (LLSH (\BIN FILE) + 16) + (LLSH (\BIN FILE) + 8) + (\BIN FILE]) + +(DOUBLEWORDOUT + [LAMBDA (FILE NUMBER) (* jds " 3-JAN-83 15:30") + (\BOUT FILE (LOGAND 255 (LRSH NUMBER 24))) + (\BOUT FILE (LOGAND 255 (LRSH NUMBER 16))) + (\BOUT FILE (LOGAND 255 (LRSH NUMBER 8))) + (\BOUT FILE (LOGAND 255 NUMBER]) + +(WRITETESTFILE + [LAMBDA (NAME LENGTH STARTBYTE PERIOD) (* ; "Edited 4-Nov-87 11:21 by jds") + + (* ;; "writes a test file of length LENGTH with contents CONTENTBYTE") + + (PROG [(STRM (OPENSTREAM NAME 'OUTPUT] + (OR STRM (RETURN NIL)) + (COND + ((ILESSP LENGTH MINTESTFILELENGTH) + (ERROR "test files must have a minimum length " MINTESTFILELENGTH))) + (WORDOUT STRM FIRSTTESTWORD) + (WORDOUT STRM SECONDTESTWORD) + (DOUBLEWORDOUT STRM LENGTH) + (BOUT STRM STARTBYTE) + (BOUT STRM PERIOD) + [bind (CURRENTBYTE _ STARTBYTE) + BLOCKCOUNT _ 0 for COMPUTEDBYTE from STARTBYTE to (IPLUS STARTBYTE LENGTH + (IMINUS MINTESTFILELENGTH) + -1) + do (BOUT STRM CURRENTBYTE) + (SETQ CURRENTBYTE (IMOD (ADD1 CURRENTBYTE) + PERIOD)) + (COND + ((ZEROP (SETQ BLOCKCOUNT (IMOD (ADD1 BLOCKCOUNT) + 100))) + (BLOCK] + (CLOSEF STRM) + (RETURN (FULLNAME STRM]) + +(WRITETESTFILELENGTH + [LAMBDA (STRM NEWLENGTH) (* ; "Edited 3-Nov-88 10:45 by jds") + (* ; + "update the length count stored in the file.") + (SETFILEPTR STRM 4) + (DOUBLEWORDOUT STRM NEWLENGTH]) +) + +(RPAQ DSKFREEPAGESFN (FUNCTION DEFAULT.DSKFREEPAGESFN)) + +(RPAQ DSKPAGESOVERHEADFN (FUNCTION DEFAULT.DSKPAGESOVERHEADFN)) + +(RPAQ DSKMINALLOCFN (FUNCTION DEFAULT.DSKMINALLOCFN)) + +(RPAQQ MINTESTFILELENGTH 10) + +(RPAQQ FIRSTTESTWORD 48094) + +(RPAQQ SECONDTESTWORD 56187) + +(RPAQQ NUMBEROFTESTBYTES 5) + +(RPAQQ EXHAUSTIVETESTFLG NIL) + +(RPAQQ DEFAULTREPLAYFILE {PHYLUM}DLIONFS>REPLAY.LOG) + +(RPAQQ DONTCLOSEFILESFLG NIL) + +(RPAQQ LEGALFILENAMECHARS + (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u + v w x y z 0 1 2 3 4 5 6 7 8 9)) + +(RPAQQ LEGALFIRSTFILENAMECHARS + (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u + v w x y z)) + +(RPAQQ MINFILENAMELENGTH 1) + +(RPAQQ MAXFILENAMELENGTH 15) + +(RPAQQ MINFILEEXTENSIONLENGTH 0) + +(RPAQQ MAXFILEEXTENSIONLENGTH 6) + +(RPAQQ MAXVERSION 64000) + +(RPAQQ TESTFILEPAGELENGTHS + (1 2 3 5 7 8 11 13 16 17 19 21 23 24 29 31 34 37 41 43 47 64 55 78 89 128 129 255 256 257 333 + 512 837 1024 1997 2048 3333 4096 5432 8192 11321 16384 19997 32768 43210 65535)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS FIRSTTESTWORD SECONDTESTWORD MINTESTFILELENGTH NUMBEROFTESTBYTES EXHAUSTIVETESTFLG + DSKFREEPAGESFN DSKPAGESOVERHEADFN TESTFILEPAGELENGTHS) +) +(DECLARE%: EVAL@COMPILE + +(RECORD TESTFILEINFO (TESTFILEFULLNAME FILELENGTH STARTBYTE PERIOD TESTFILEORIGNAME)) + +(RECORD TESTFILEOP ( + (* ;; "Describes one DSKTEST file operation, for the log and for replay.") + + TESTOPERATION (* ; + "Operation to be performed. One of: ADD DELETE CHANGELENGTH DELETEALL") + TESTOPFILENAME (* ; + "File name of the file operated on") + TESTOPFILELENGTH (* ; "New length for the file") + STARTBYTE (* ; "%"Random%" data start < PERIOD") + PERIOD (* ; "%"Random%" data period < 256") + )) +) +(PUTPROPS DSKTEST COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2943 12078 (DSKTEST 2953 . 11544) (DELETETESTFILES 11546 . 12076)) (12079 59900 ( +CHECKCONSISTENCY 12089 . 13302) (CHECKLENGTHANDCONTENTS 13304 . 17796) (CHOOSERANDOMFILEOPERATION +17798 . 19365) (DEFAULT.DSKFREEPAGESFN 19367 . 20152) (DEFAULT.DSKMINALLOCFN 20154 . 20803) ( +DEFAULT.DSKPAGESOVERHEADFN 20805 . 21709) (DOTESTFILEOP 21711 . 30611) (DSKFREEPAGES 30613 . 30872) ( +DSKMINALLOC 30874 . 31180) (DSKPAGESOVERHEAD 31182 . 31453) (EXTENDTESTFILE 31455 . 32765) ( +FILEINFOFROMFILE 32767 . 33586) (GENERATEADDFILEOP 33588 . 34342) (GENERATECHANGEFILEOP 34344 . 35248) + (GENERATEDELETEFILEOP 35250 . 35987) (GENERATEEOFPFILEOP 35989 . 36881) (GENERATEPEEKBINFILEOP 36883 + . 37672) (GENERATEDELETEALLFILEOP 37674 . 37866) (RANDOMELT 37868 . 38122) (RANDOMFILELENGTH 38124 . +40003) (RANDOMFILENAME 40005 . 41255) (RANDOMSTR 41257 . 41921) (RANDOMTESTFILE 41923 . 42826) ( +SORTBYCAR 42828 . 43181) (TESTFILEP 43183 . 45623) (TESTEOFP 45625 . 48865) (TESTEOFOP 48867 . 49898) +(TESTFILEPTR 49900 . 52243) (TESTPEEKBIN 52245 . 56179) (TRUNCATETESTFILE 56181 . 57146) (WORDIN 57148 + . 57425) (WORDOUT 57427 . 57602) (DOUBLEWORDIN 57604 . 57889) (DOUBLEWORDOUT 57891 . 58181) ( +WRITETESTFILE 58183 . 59529) (WRITETESTFILELENGTH 59531 . 59898))))) +STOP diff --git a/internal/envos/DSKTEST.TEDIT b/internal/envos/DSKTEST.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..33b0ae3742a58916177bd3b9ae273d912e1e403c GIT binary patch literal 2351 zcmd5*!EO^V5Z$z(Qp9rLMo)8s(uUr+p-Lf5+lZ(K62XOwvpdPRnpD&4wW2RVXMQ` zO+7n*uos^hPZMJ)DV;Y3Te7TJIF66l$xH_fozjJs-m|80MIU663!Bor(t4xgPtxa9 zm{d+=BD^%(g+n7zDZ@1MLc4Kkt2mC28fGLN37UyyDl(>YQN$YxgvjR{7)UXeO8Sb- zgeFizu5z9WcR+L^&p|{q;grv1!Zgorlk_!Jc5Of_24uVD56U`YS0@FK1(|^DC;@AU z;wa|e0p%=GI3YERDQZ!$NGWpxHy}=s<1Zy^6h=mHLnNN9ql+BgP$J+H1GJcx9vKsB zidt6#i|U;TjuQ(UHZ!($h4zwDl5;Y3b%tV{!QRjTa6|*V3nhh8Pc__C}){O z_$p^0qG>!17h=kx3mB#uiCU+igsm4+lP-%fghK&<8rkU2m8>ZkTTBBa~f)GO)d$KYOtitfsQ&^8h z`_ix8pf|#2I6CeRdP7?2TQhHDw1WFM!OgHyVp)VS0E0QxgD5;3VQKveEBK0sdn3y_7tjbL4PRyFNrTbn%e{q7LU(RnZjTfw6B8GE;J7x({(XSl zZ0c<*9w;n`m2L;z|z&&{P3_Mmy`JcUu-u%J4 L%^%VJ*Pp)uy+5DR literal 0 HcmV?d00001 diff --git a/internal/envos/FILEBANGER b/internal/envos/FILEBANGER new file mode 100644 index 00000000..d1122734 --- /dev/null +++ b/internal/envos/FILEBANGER @@ -0,0 +1,305 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "14-Jun-90 21:20:39" {DSK}local>lde>lispcore>internal>library>FILEBANGER.;2 16050 + + chnges to%: (VARS FILEBANGERCOMS) + (FNS CHECKFORZEROS) + + previous date%: " 1-Oct-87 18:36:57" {DSK}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 diff --git a/internal/envos/FLOPPYTESTER b/internal/envos/FLOPPYTESTER new file mode 100644 index 00000000..6e481381 --- /dev/null +++ b/internal/envos/FLOPPYTESTER @@ -0,0 +1,105 @@ +(FILECREATED "24-Mar-86 15:18:14" {ERIS}SOURCES>FLOPPYTESTER.;9 4308 + + changes to: (FNS STARTTEST STOPTEST KILLTEST) + (VARS FLOPPYTESTERCOMS) + + previous date: "20-Mar-86 21:06:46" {ERIS}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}TOOLS>FILEBANGER.DCOM))) + (INITVARS (ALLOCATIONSW NIL)) + (FNS STARTTEST STOPTEST KILLTEST BLTALLOCS BLTALLOC))) + (* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *) + +(LOAD? (QUOTE {ERINYES}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 diff --git a/internal/envos/FLOPPYWORK b/internal/envos/FLOPPYWORK new file mode 100644 index 00000000..21a70752 --- /dev/null +++ b/internal/envos/FLOPPYWORK @@ -0,0 +1,70 @@ +(FILECREATED "19-Jun-86 12:32:16" {ERIS}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 diff --git a/internal/envos/GIVE-AND-TAKE.STATUS b/internal/envos/GIVE-AND-TAKE.STATUS new file mode 100644 index 00000000..8ab02cf0 --- /dev/null +++ b/internal/envos/GIVE-AND-TAKE.STATUS @@ -0,0 +1 @@ +"GADENER.ENVOS" "13-Apr-90 12:31:11" diff --git a/internal/envos/GRAPEVINE b/internal/envos/GRAPEVINE new file mode 100644 index 00000000..575b2161 --- /dev/null +++ b/internal/envos/GRAPEVINE @@ -0,0 +1,1362 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 14:49:16" {DSK}local>lde>lispcore>internal>library>GRAPEVINE.;2 50497 + + changes to%: (VARS GRAPEVINECOMS) + (FNS \ENQUIRE \PERFORMGVOP FINDREGSERVER GV.KILLSOCKET \GV.WHENCLOSED) + + previous date%: "21-May-86 10:53:33" {DSK}local>lde>lispcore>internal>library>GRAPEVINE.;1 +) + + +(* ; " +Copyright (c) 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT GRAPEVINECOMS) + +(RPAQQ GRAPEVINECOMS + [(COMS (* Functions for interrogating the database) + (FNS GV.AUTHENTICATE GV.CHECKSTAMP GV.EXPAND GV.IDENTIFYCALLER GV.IDENTIFYME + GV.ISINLIST GV.ISMEMBERCLOSURE GV.ISMEMBERDIRECT GV.READCONNECT GV.READENTRY + GV.READFRIENDS GV.READMEMBERS GV.READOWNERS GV.READREMARK) + (* Functions which update the database) + (FNS GV.ADDFORWARD GV.ADDFRIEND GV.ADDLISTOFMEMBERS GV.ADDMAILBOX GV.ADDMEMBER + GV.ADDOWNER GV.CHANGECONNECT GV.CHANGEPASSWORD GV.CHANGEREMARK GV.CREATEGROUP + GV.CREATEINDIVIDUAL GV.DELETEGROUP GV.DELETEINDIVIDUAL GV.NEWNAME GV.REMOVEFORWARD + GV.REMOVEFRIEND GV.REMOVEMAILBOX GV.REMOVEMEMBER GV.REMOVEOWNER)) + (COMS (* Talking to Reg Servers) + (FNS \GVOP \ENQUIRE \PERFORMGVOP FINDREGSERVER LOCATESOCKETS) + (ADDVARS (\GVCONNECTIONS)) + (VARS (REGROOT '(GV . GV)) + (REGROOTNLSNAME "GrapevineRServer") + (\REG.IOTIMEOUT 30000)) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (COMS * GVPROTOCOLDEFS))) + (COMS (* Making server connections) + (FNS OPENCLOSESTSOCKET \OPENGVCONNECTION GV.KILLSOCKET \GV.WHENCLOSED) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS GVCONNECTION) + (CONSTANTS (\DEFAULTPOLLINGSOC 5)) + (GLOBALVARS \BETWEENPROBEDELAY \CONNECTTIMEOUT)) + (VARS (\BETWEENPROBEDELAY 1000) + (\CONNECTTIMEOUT 30000))) + (COMS (* Checking arguments) + (FNS \CHECKNAME \CHECKSTRING \NONAMEERR \UNPACKREG) + (INITVARS (DEFAULTREGISTRY)) + (GLOBALVARS DEFAULTREGISTRY)) + (COMS (* GVKEY) + (FNS \CHECKKEY GV.MAKEKEY) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS GVKEY) + (CONSTANTS \#BYTES.GVKEY) + (MACROS KEYP CREATEKEY GETKEYBYTE SETKEYBYTE)) + (INITRECORDS GVKEY)) + [COMS (* TIMESTAMP) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS TIMESTAMP) + (CONSTANTS \#BYTES.TIMESTAMP)) + (INITRECORDS TIMESTAMP) + (FNS \TIMESTAMP.DEFPRINT \CHECKSTAMP) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'TIMESTAMP '\TIMESTAMP.DEFPRINT] + (COMS (* I/O primitives) + (FNS \SENDITEM \SENDSTRING) + (FNS \RECEIVEBOOL \RECEIVECLIST \RECEIVECOMPONENT \RECEIVERLIST \RECEIVERNAME + \RECEIVESTAMP \RECEIVESTRING) + (VARS (\3BYTEKLUDGEKEY '$$3byte$$)) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (MACROS \RECEIVEWORD \SKIPWORD \SENDWORD) + (CONSTANTS (\MAXGVSTRING 64)) + (GLOBALVARS \3BYTEKLUDGEKEY))) + (DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (P (SELECTQ (COMPILEMODE) + (D (FILESLOAD (LOADCOMP) + PUP BSP)) + (PDP-10 (FILESLOAD (LOADCOMP) + PUP10 BSPAUX)) + NIL]) + + + +(* Functions for interrogating the database) + +(DEFINEQ + +(GV.AUTHENTICATE + [LAMBDA (NAME KEY) (* ht%: "14-JAN-82 10:24") + (\GVOP \OP.AUTHENTICATE (\CHECKNAME NAME) + (LIST (\CHECKKEY KEY]) + +(GV.CHECKSTAMP + [LAMBDA (NAME OLDSTAMP) (* ht%: "22-JAN-82 10:07") + (\GVOP \OP.CHECKSTAMP (\CHECKNAME NAME) + (LIST (\CHECKSTAMP OLDSTAMP)) + (FUNCTION \RECEIVESTAMP]) + +(GV.EXPAND + [LAMBDA (NAME OLDSTAMP) (* M.Yonke "10-AUG-83 11:10") + + (* Does the database Expand operation - + named to avoid conflict with the mail server version + (MSExpand)) + + (\GVOP \OP.GVEXPAND (\CHECKNAME NAME) + (LIST (\CHECKSTAMP OLDSTAMP)) + (FUNCTION \RECEIVERLIST]) + +(GV.IDENTIFYCALLER + [LAMBDA (NAME KEY) (* ht%: "14-JAN-82 10:27") + (\GVOP \OP.IDENTIFYCALLER (\CHECKNAME NAME) + (LIST (\CHECKKEY KEY]) + +(GV.IDENTIFYME + [LAMBDA NIL (* bvm%: "17-SEP-83 14:14") + (* Calls GV.IDENTIFYCALLER with info + provided by LOGIN) + (PROG ((npw (\INTERNAL/GETPASSWORD NIL))) + (RETURN (GV.IDENTIFYCALLER (CAR npw) + (CDR npw]) + +(GV.ISINLIST + [LAMBDA (GROUP MEMBER WHAT WHICH WHERE) (* bvm%: "21-May-86 10:34") + (\GVOP \OP.ISINLIST (\CHECKNAME GROUP) + (LIST (\CHECKSTRING MEMBER) + (LIST \3BYTEKLUDGEKEY (OR WHAT OP.ITSELF) + (OR WHICH OP.MEMBERS) + (OR WHERE OP.DIRECT))) + (FUNCTION \RECEIVEBOOL]) + +(GV.ISMEMBERCLOSURE + [LAMBDA (GROUP MEMBER) (* bvm%: "21-May-86 10:34") + (\GVOP \OP.ISMEMBERCLOSURE (\CHECKNAME GROUP) + (LIST (\CHECKSTRING MEMBER)) + (FUNCTION \RECEIVEBOOL]) + +(GV.ISMEMBERDIRECT + [LAMBDA (GROUP MEMBER) (* bvm%: "21-May-86 10:34") + (\GVOP \OP.ISMEMBERDIRECT (\CHECKNAME GROUP) + (LIST (\CHECKSTRING MEMBER)) + (FUNCTION \RECEIVEBOOL]) + +(GV.READCONNECT + [LAMBDA (NAME) (* ht%: "14-JAN-82 10:20") + (\GVOP \OP.READCONNECT (\CHECKNAME NAME) + NIL + (FUNCTION \RECEIVERNAME]) + +(GV.READENTRY + [LAMBDA (NAME OLDSTAMP READFN) (* bvm%: "22-Mar-84 14:05") + (\GVOP \OP.READENTRY (\CHECKNAME NAME) + (LIST (\CHECKSTAMP OLDSTAMP)) + (OR READFN (FUNCTION \RECEIVECLIST]) + +(GV.READFRIENDS + [LAMBDA (NAME OLDSTAMP READFN) (* bvm%: "22-Mar-84 14:03") + (\GVOP \OP.READFRIENDS (\CHECKNAME NAME) + (LIST (\CHECKSTAMP OLDSTAMP)) + (OR READFN (FUNCTION \RECEIVERLIST]) + +(GV.READMEMBERS + [LAMBDA (NAME OLDSTAMP READFN) (* bvm%: "22-Mar-84 14:03") + (\GVOP \OP.READMEMBERS (\CHECKNAME NAME) + (LIST (\CHECKSTAMP OLDSTAMP)) + (OR READFN (FUNCTION \RECEIVERLIST]) + +(GV.READOWNERS + [LAMBDA (NAME OLDSTAMP READFN) (* bvm%: "22-Mar-84 14:04") + (\GVOP \OP.READOWNERS (\CHECKNAME NAME) + (LIST (\CHECKSTAMP OLDSTAMP)) + (OR READFN (FUNCTION \RECEIVERLIST]) + +(GV.READREMARK + [LAMBDA (NAME) (* ht%: "14-JAN-82 10:21") + (\GVOP \OP.READREMARK (\CHECKNAME NAME) + NIL + (FUNCTION \RECEIVERNAME]) +) + + + +(* Functions which update the database) + +(DEFINEQ + +(GV.ADDFORWARD + [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:28") + (\GVOP \OP.ADDFORWARD (\CHECKNAME NAME) + (LIST (\CHECKSTRING STRING)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.ADDFRIEND + [LAMBDA (GROUP FRIEND IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:38") + (\GVOP \OP.ADDFRIEND (\CHECKNAME GROUP) + (LIST (\CHECKSTRING FRIEND)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.ADDLISTOFMEMBERS + [LAMBDA (GROUP MEMBERS IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:39") + (\GVOP \OP.ADDLISTOFMEMBERS (\CHECKNAME GROUP) + [LIST (COND + ([AND (LISTP MEMBERS) + (OR (STRINGP (CAR MEMBERS)) + (LITATOM (CAR MEMBERS))) + (for p on MEMBERS when (CDR p) + always (AND (OR (STRINGP (CADR p)) + (LITATOM (CADR p))) + (ALPHORDER (CAR p) + (CADR p] + MEMBERS) + (T (ERROR "must have ordered list of strings" MEMBERS] + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.ADDMAILBOX + [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:20") + (\GVOP \OP.ADDMAILBOX (\CHECKNAME NAME) + (LIST (\CHECKSTRING STRING)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.ADDMEMBER + [LAMBDA (GROUP MEMBER IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:39") + (\GVOP \OP.ADDMEMBER (\CHECKNAME GROUP) + (LIST (\CHECKSTRING MEMBER)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.ADDOWNER + [LAMBDA (GROUP OWNER IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:39") + (\GVOP \OP.ADDOWNER (\CHECKNAME GROUP) + (LIST (\CHECKSTRING OWNER)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.CHANGECONNECT + [LAMBDA (NAME SITE IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:27") + (\GVOP \OP.CHANGECONNECT (\CHECKNAME NAME) + [LIST (OR (STRINGP SITE) + (AND (LITATOM SITE) + SITE) + (COND + ((AND [OR (LISTP SITE) + (NUMBERP SITE) + (AND (NOT SITE) + (SETQ SITE (\LOCALPUPADDRESS] + (PORTSTRING SITE))) + (T (ERROR "Invalid Site" SITE] + NIL IDENTIFYUSER PASSWORD]) + +(GV.CHANGEPASSWORD + [LAMBDA (NAME KEY IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:21") + (\GVOP \OP.CHANGEPASSWORD (\CHECKNAME NAME) + (LIST (\CHECKKEY KEY)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.CHANGEREMARK + [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:22") + (\GVOP \OP.CHANGEREMARK (\CHECKNAME NAME) + (LIST (\CHECKSTRING STRING)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.CREATEGROUP + [LAMBDA (NAME IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:22") + (\GVOP \OP.CREATEGROUP (\CHECKNAME NAME) + NIL NIL (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.CREATEINDIVIDUAL + [LAMBDA (NAME KEY IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:23") + (\GVOP \OP.CREATEINDIVIDUAL (\CHECKNAME NAME) + (LIST (\CHECKKEY KEY)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.DELETEGROUP + [LAMBDA (NAME IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:23") + (\GVOP \OP.DELETEGROUP (\CHECKNAME NAME) + NIL NIL (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.DELETEINDIVIDUAL + [LAMBDA (NAME IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:23") + (\GVOP \OP.DELETEINDIVIDUAL (\CHECKNAME NAME) + NIL NIL (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.NEWNAME + [LAMBDA (NAME GV.NEWNAME IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:24") + (\GVOP \OP.NEWNAME (\CHECKNAME NAME) + (LIST (\CHECKNAME GV.NEWNAME)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.REMOVEFORWARD + [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:24") + (\GVOP \OP.REMOVEFORWARD (\CHECKNAME NAME) + (LIST (\CHECKSTRING STRING)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.REMOVEFRIEND + [LAMBDA (GROUP FRIEND IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:40") + (\GVOP \OP.REMOVEFRIEND (\CHECKNAME GROUP) + (LIST (\CHECKSTRING FRIEND)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.REMOVEMAILBOX + [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD) (* bvm%: "16-SEP-83 18:25") + (\GVOP \OP.REMOVEMAILBOX (\CHECKNAME NAME) + (LIST (\CHECKSTRING STRING)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.REMOVEMEMBER + [LAMBDA (GROUP MEMBER IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:40") + (\GVOP \OP.REMOVEMEMBER (\CHECKNAME GROUP) + (LIST (\CHECKSTRING MEMBER)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) + +(GV.REMOVEOWNER + [LAMBDA (GROUP OWNER IDENTIFYUSER PASSWORD) (* bvm%: "21-May-86 10:40") + (\GVOP \OP.REMOVEOWNER (\CHECKNAME GROUP) + (LIST (\CHECKSTRING OWNER)) + NIL + (OR IDENTIFYUSER T) + PASSWORD]) +) + + + +(* Talking to Reg Servers) + +(DEFINEQ + +(\GVOP + [LAMBDA (OP name itemList READFN IDENTIFYUSER PASSWORD)(* bvm%: "22-Mar-84 14:55") + + (* Supervises a registration database operation. + Does the initial interaction, applies READFN to the input side of the + connection to collect results, and interprets same if necessary) + + (\ENQUIRE name (CONS OP (CONS name itemList)) + READFN IDENTIFYUSER PASSWORD]) + +(\ENQUIRE + [LAMBDA (NAME ARGS READFN IDENTIFYUSER PASSWORD) (* ; "Edited 15-Jun-90 14:27 by jds") + + (* Attempt to accomplish some interaction with a reg. + server. Implements the Taft/Birrell approach of first trying anybody we're + connected to, failing that trying the closest reg. + server we can find, and only if that fails as well do we get down to basics and + actually go thru the lookup procedure to find someone who knows what we need) + + (PROG ((REGISTRY REGROOT) + RESULT CONN INFO) + LP (COND + ((NOT (SETQ CONN (FINDREGSERVER REGISTRY))) + (RETURN EC.ALLDOWN))) + [COND + (IDENTIFYUSER [COND + ((EQ IDENTIFYUSER T) + (SETQ INFO (\INTERNAL/GETPASSWORD)) + (SETQ IDENTIFYUSER (CAR INFO] + (COND + ((AND (NEQ (fetch (GVCONNECTION GVIDENTIFIED) of CONN) + IDENTIFYUSER) + (NOT (EQUAL (fetch (GVCONNECTION GVIDENTIFIED) of CONN) + IDENTIFYUSER))) + (COND + ([NOT (SETQ RESULT (\PERFORMGVOP CONN + (LIST \OP.IDENTIFYCALLER (\CHECKNAME + IDENTIFYUSER) + (\CHECKKEY (OR PASSWORD (CDR INFO] + (BLOCK) + (replace (GVCONNECTION GVBUSY) of CONN with NIL) + (GO LP)) + ((SETQ RESULT (SELECTC (fetch HIBYTE of RESULT) + (\RC.BADRNAME EC.BADRNAME) + (\RC.BADPASSWORD + EC.BADPASSWORD) + (\RC.ALLDOWN EC.ALLDOWN) + (\RC.DONE NIL) + (SHOULDNT))) + (RETURN RESULT)) + (T (replace (GVCONNECTION GVIDENTIFIED) of CONN with + IDENTIFYUSER + ] + (SETQ RESULT (SELECTC (COND + ((SETQ RESULT (\PERFORMGVOP CONN ARGS)) + (* we ignore the name type and + return the code part of the return + code) + (SETQ GVNAMETYPE (fetch LOBYTE of RESULT)) + (SETQ RESULT (fetch HIBYTE of RESULT))) + (T + + (* The usual causes for this are the stream is not in fact open despite our + efforts to insure that it is, or that the other end has gone to sleep and the + BSPIOTIMEOUT occurs. If this happens too often, \REG.IOTIMEOUT should be + lengthened) + + (BLOCK) (* Let RTP run and clean this guy + out) + (replace (GVCONNECTION GVBUSY) of CONN with NIL) + (GO LP))) + (\RC.NOCHANGE (* For use with timestamps, says + entry has not changed, so no values + to return) + EC.NOCHANGE) + (\RC.DONE (COND + (READFN (APPLY* READFN (fetch (GVCONNECTION GVINSTREAM) + of CONN))) + (T T))) + (\RC.WRONGSERVER (* so we have to do it right after + all) + (COND + ((NEQ REGISTRY REGROOT) + EC.BADRNAME) + (T (replace (GVCONNECTION GVBUSY) of CONN with NIL) + (SETQ REGISTRY (CONS (CDR NAME) + 'GV)) + (GO LP)))) + (\RC.BADRNAME EC.BADRNAME) + (\RC.NOTALLOWED + EC.NOTALLOWED) + (\RC.BADPASSWORD + EC.BADPASSWORD) + (\RC.ALLDOWN EC.ALLDOWN) + RESULT)) + (replace (GVCONNECTION GVBUSY) of CONN with NIL) + (RETURN RESULT]) + +(\PERFORMGVOP + [LAMBDA (CONN ARGS) (* ; "Edited 15-Jun-90 14:27 by jds") + (CAR (NLSETQ (LET ((STREAM (fetch (GVCONNECTION GVOUTSTREAM) of CONN))) + (for e in ARGS do (\SENDITEM STREAM e)) + (FORCEOUTPUT STREAM) + (\RECEIVEWORD (fetch (GVCONNECTION GVINSTREAM) of CONN]) + +(FINDREGSERVER + [LAMBDA (REGISTRY ERRORFLG) (* ; "Edited 15-Jun-90 14:27 by jds") + (* Find a registration server for + REGISTRY - + the closest one available) + (PROG (NEWSOC) + [COND + ((NLISTP REGISTRY) + (SETQ REGISTRY (\UNPACKREG REGISTRY] + (RETURN (COND + [(UNINTERRUPTABLY + (for CONN in \GVCONNECTIONS + when [AND (NULL (fetch (GVCONNECTION GVBUSY) of CONN)) + (OR (EQ REGISTRY REGROOT) + (EQUAL REGISTRY (fetch (GVCONNECTION GVREGISTRY) + of CONN] + do (replace (GVCONNECTION GVBUSY) of CONN with T) + (RETURN CONN)))] + ((SETQ NEWSOC (OPENCLOSESTSOCKET (LOCATESOCKETS REGISTRY ERRORFLG) + \REG.SERVERPOLLINGSOC \REG.SERVERENQUIRYSOC \REG.IOTIMEOUT) + ) + (replace (GVCONNECTION GVREGISTRY) of NEWSOC with REGISTRY) + (replace (GVCONNECTION GVBUSY) of NEWSOC with T) + (push \GVCONNECTIONS NEWSOC) + NEWSOC) + (ERRORFLG (ERROR "Couldn't open connection for" REGISTRY]) + +(LOCATESOCKETS + [LAMBDA (SITE ERRORFLG) (* bvm%: "17-SEP-83 14:15") + + (* get a list of sockets for a SITE - + a three step process (except for GV.GV) - + find the members of the site, find the connect sites for each, turn those into + sockets) + + (COND + ((EQUAL SITE REGROOT) (* treat the root - + "GV.GV" - + specially) + (ETHERPORT REGROOTNLSNAME ERRORFLG T)) + (T (bind cn for rName in [CDR (OR (LISTP (GV.READMEMBERS SITE)) + (COND + (ERRORFLG (ERROR "Not a valid site" SITE] + join (OR (AND (SETQ cn (STRINGP (GV.READCONNECT rName))) + (ETHERPORT cn NIL T)) + (ETHERPORT rName NIL T) + (COND + (ERRORFLG (HELP "Can't look up connect name" (CONS rName cn]) +) + +(ADDTOVAR \GVCONNECTIONS ) + +(RPAQQ REGROOT (GV . GV)) + +(RPAQ REGROOTNLSNAME "GrapevineRServer") + +(RPAQQ \REG.IOTIMEOUT 30000) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(RPAQQ GVPROTOCOLDEFS + ((CONSTANTS * \GV.OPS) + (* Grapevine response codes) + (CONSTANTS * \GV.RESPONSES) + (* Response codes the user sees) + (CONSTANTS * \GVU.RESPONSES) + (GLOBALVARS REGROOT REGROOTNLSNAME \REG.IOTIMEOUT \GVCONNECTIONS) + (CONSTANTS (\REG.SERVERENQUIRYSOC 40) + (\REG.SERVERPOLLINGSOC 42)) + (* Constants for calling GV.ISINLIST) + (CONSTANTS * \GVU.MEMBEROPS))) + +(RPAQQ \GV.OPS + ((\OP.GVEXPAND 1) + (\OP.READMEMBERS 2) + (\OP.READOWNERS 3) + (\OP.READFRIENDS 4) + (\OP.READENTRY 5) + (\OP.CHECKSTAMP 6) + (\OP.READCONNECT 7) + (\OP.READREMARK 8) + (\OP.AUTHENTICATE 9) + (\OP.IDENTIFYCALLER 33) + (\OP.ISMEMBERDIRECT 40) + (\OP.ISOWNERDIRECT 41) + (\OP.ISFRIENDDIRECT 42) + (\OP.ISMEMBERCLOSURE 43) + (\OP.ISOWNERCLOSURE 44) + (\OP.ISFRIENDCLOSURE 45) + (\OP.ISINLIST 46) + (\OP.CREATEINDIVIDUAL 12) + (\OP.DELETEINDIVIDUAL 13) + (\OP.CREATEGROUP 14) + (\OP.DELETEGROUP 15) + (\OP.CHANGEPASSWORD 16) + (\OP.CHANGECONNECT 17) + (\OP.CHANGEREMARK 18) + (\OP.ADDMEMBER 19) + (\OP.ADDMAILBOX 20) + (\OP.ADDFORWARD 21) + (\OP.ADDOWNER 22) + (\OP.ADDFRIEND 23) + (\OP.REMOVEMEMBER 24) + (\OP.REMOVEMAILBOX 25) + (\OP.REMOVEFORWARD 26) + (\OP.REMOVEOWNER 27) + (\OP.REMOVEFRIEND 28) + (\OP.ADDSELF 29) + (\OP.REMOVESELF 30) + (\OP.ADDLISTOFMEMBERS 31) + (\OP.NEWNAME 32))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \OP.GVEXPAND 1) + +(RPAQQ \OP.READMEMBERS 2) + +(RPAQQ \OP.READOWNERS 3) + +(RPAQQ \OP.READFRIENDS 4) + +(RPAQQ \OP.READENTRY 5) + +(RPAQQ \OP.CHECKSTAMP 6) + +(RPAQQ \OP.READCONNECT 7) + +(RPAQQ \OP.READREMARK 8) + +(RPAQQ \OP.AUTHENTICATE 9) + +(RPAQQ \OP.IDENTIFYCALLER 33) + +(RPAQQ \OP.ISMEMBERDIRECT 40) + +(RPAQQ \OP.ISOWNERDIRECT 41) + +(RPAQQ \OP.ISFRIENDDIRECT 42) + +(RPAQQ \OP.ISMEMBERCLOSURE 43) + +(RPAQQ \OP.ISOWNERCLOSURE 44) + +(RPAQQ \OP.ISFRIENDCLOSURE 45) + +(RPAQQ \OP.ISINLIST 46) + +(RPAQQ \OP.CREATEINDIVIDUAL 12) + +(RPAQQ \OP.DELETEINDIVIDUAL 13) + +(RPAQQ \OP.CREATEGROUP 14) + +(RPAQQ \OP.DELETEGROUP 15) + +(RPAQQ \OP.CHANGEPASSWORD 16) + +(RPAQQ \OP.CHANGECONNECT 17) + +(RPAQQ \OP.CHANGEREMARK 18) + +(RPAQQ \OP.ADDMEMBER 19) + +(RPAQQ \OP.ADDMAILBOX 20) + +(RPAQQ \OP.ADDFORWARD 21) + +(RPAQQ \OP.ADDOWNER 22) + +(RPAQQ \OP.ADDFRIEND 23) + +(RPAQQ \OP.REMOVEMEMBER 24) + +(RPAQQ \OP.REMOVEMAILBOX 25) + +(RPAQQ \OP.REMOVEFORWARD 26) + +(RPAQQ \OP.REMOVEOWNER 27) + +(RPAQQ \OP.REMOVEFRIEND 28) + +(RPAQQ \OP.ADDSELF 29) + +(RPAQQ \OP.REMOVESELF 30) + +(RPAQQ \OP.ADDLISTOFMEMBERS 31) + +(RPAQQ \OP.NEWNAME 32) + + +(CONSTANTS (\OP.GVEXPAND 1) + (\OP.READMEMBERS 2) + (\OP.READOWNERS 3) + (\OP.READFRIENDS 4) + (\OP.READENTRY 5) + (\OP.CHECKSTAMP 6) + (\OP.READCONNECT 7) + (\OP.READREMARK 8) + (\OP.AUTHENTICATE 9) + (\OP.IDENTIFYCALLER 33) + (\OP.ISMEMBERDIRECT 40) + (\OP.ISOWNERDIRECT 41) + (\OP.ISFRIENDDIRECT 42) + (\OP.ISMEMBERCLOSURE 43) + (\OP.ISOWNERCLOSURE 44) + (\OP.ISFRIENDCLOSURE 45) + (\OP.ISINLIST 46) + (\OP.CREATEINDIVIDUAL 12) + (\OP.DELETEINDIVIDUAL 13) + (\OP.CREATEGROUP 14) + (\OP.DELETEGROUP 15) + (\OP.CHANGEPASSWORD 16) + (\OP.CHANGECONNECT 17) + (\OP.CHANGEREMARK 18) + (\OP.ADDMEMBER 19) + (\OP.ADDMAILBOX 20) + (\OP.ADDFORWARD 21) + (\OP.ADDOWNER 22) + (\OP.ADDFRIEND 23) + (\OP.REMOVEMEMBER 24) + (\OP.REMOVEMAILBOX 25) + (\OP.REMOVEFORWARD 26) + (\OP.REMOVEOWNER 27) + (\OP.REMOVEFRIEND 28) + (\OP.ADDSELF 29) + (\OP.REMOVESELF 30) + (\OP.ADDLISTOFMEMBERS 31) + (\OP.NEWNAME 32)) +) + + + +(* Grapevine response codes) + + +(RPAQQ \GV.RESPONSES + ((\RC.DONE 0) + (\RC.NOCHANGE 1) + (\RC.OUTOFDATE 2) + (\RC.NOTALLOWED 3) + (\RC.BADOPERATION 4) + (\RC.BADPROTOCOL 5) + (\RC.BADRNAME 6) + (\RC.BADPASSWORD 7) + (\RC.WRONGSERVER 8) + (\RC.ALLDOWN 9))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \RC.DONE 0) + +(RPAQQ \RC.NOCHANGE 1) + +(RPAQQ \RC.OUTOFDATE 2) + +(RPAQQ \RC.NOTALLOWED 3) + +(RPAQQ \RC.BADOPERATION 4) + +(RPAQQ \RC.BADPROTOCOL 5) + +(RPAQQ \RC.BADRNAME 6) + +(RPAQQ \RC.BADPASSWORD 7) + +(RPAQQ \RC.WRONGSERVER 8) + +(RPAQQ \RC.ALLDOWN 9) + + +(CONSTANTS (\RC.DONE 0) + (\RC.NOCHANGE 1) + (\RC.OUTOFDATE 2) + (\RC.NOTALLOWED 3) + (\RC.BADOPERATION 4) + (\RC.BADPROTOCOL 5) + (\RC.BADRNAME 6) + (\RC.BADPASSWORD 7) + (\RC.WRONGSERVER 8) + (\RC.ALLDOWN 9)) +) + + + +(* Response codes the user sees) + + +(RPAQQ \GVU.RESPONSES + ((EC.STREAMLOST 'StreamLost) + (EC.ALLDOWN 'AllDown) + (EC.NOCHANGE 'NoChange) + (EC.BADRNAME 'BadRName) + (EC.BADPASSWORD 'BadPassword) + (EC.NOTALLOWED 'NotAllowed))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ EC.STREAMLOST StreamLost) + +(RPAQQ EC.ALLDOWN AllDown) + +(RPAQQ EC.NOCHANGE NoChange) + +(RPAQQ EC.BADRNAME BadRName) + +(RPAQQ EC.BADPASSWORD BadPassword) + +(RPAQQ EC.NOTALLOWED NotAllowed) + + +(CONSTANTS (EC.STREAMLOST 'StreamLost) + (EC.ALLDOWN 'AllDown) + (EC.NOCHANGE 'NoChange) + (EC.BADRNAME 'BadRName) + (EC.BADPASSWORD 'BadPassword) + (EC.NOTALLOWED 'NotAllowed)) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS REGROOT REGROOTNLSNAME \REG.IOTIMEOUT \GVCONNECTIONS) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \REG.SERVERENQUIRYSOC 40) + +(RPAQQ \REG.SERVERPOLLINGSOC 42) + + +(CONSTANTS (\REG.SERVERENQUIRYSOC 40) + (\REG.SERVERPOLLINGSOC 42)) +) + + + +(* Constants for calling GV.ISINLIST) + + +(RPAQQ \GVU.MEMBEROPS ((OP.ITSELF 0) + (OP.ITSREGISTRY 1) + (OP.MEMBERS 0) + (OP.OWNERS 1) + (OP.FRIENDS 2) + (OP.DIRECT 0) + (OP.CLOSURE 1) + (OP.UPARROW 2))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ OP.ITSELF 0) + +(RPAQQ OP.ITSREGISTRY 1) + +(RPAQQ OP.MEMBERS 0) + +(RPAQQ OP.OWNERS 1) + +(RPAQQ OP.FRIENDS 2) + +(RPAQQ OP.DIRECT 0) + +(RPAQQ OP.CLOSURE 1) + +(RPAQQ OP.UPARROW 2) + + +(CONSTANTS (OP.ITSELF 0) + (OP.ITSREGISTRY 1) + (OP.MEMBERS 0) + (OP.OWNERS 1) + (OP.FRIENDS 2) + (OP.DIRECT 0) + (OP.CLOSURE 1) + (OP.UPARROW 2)) +) +) + + + +(* Making server connections) + +(DEFINEQ + +(OPENCLOSESTSOCKET + [LAMBDA (PORTLIST POLLSOC CONNSOC TIMEOUT) (* bvm%: "19-Jul-85 12:42") + + (* Open a BSP connection with the "closest" respondant on portList. + EchoMe polling to determine responsiveness is to pollSoc, connection will go to + connSoc. We poll in order from nearest to farest by hop order, use broadcast on + local net if appropriate, and hope not to engage too many folks before the real + thing comes along. The basic structure of this is owed to Taft) + + (RESETLST + [PROG ((MYNET (\LOCALPUPNETNUMBER)) + (BETWEENPROBE (SETUPTIMER 0)) + (PROBECOUNT 1) + LOCALPORTS ALLPORTS SOC CNTIME REMAININGPORTS PORT VAL PUP) + [for PORT in PORTLIST do (COND + ((AND POLLSOC (EQ (fetch PUPNET# + of (CAR PORT)) + MYNET)) + (push LOCALPORTS PORT)) + (T (push ALLPORTS PORT] + [COND + (ALLPORTS (SETQ ALLPORTS (SORT.PUPHOSTS.BY.DISTANCE ALLPORTS] + (COND + [LOCALPORTS + + (* if there is more than one local host on the list, remove them and add a + broadcast port for cheaper poll) + + (SETQ ALLPORTS (COND + ((CDR LOCALPORTS) + (CONS (LIST (create PUPADDRESS + PUPNET# _ MYNET + PUPHOST# _ 0)) + ALLPORTS)) + (T (APPEND LOCALPORTS ALLPORTS] + ((NULL ALLPORTS) + (RETURN))) + [RESETSAVE NIL (LIST 'CLOSEPUPSOCKET (SETQ SOC (OPENPUPSOCKET] + (SETQ CNTIME (SETUPTIMER \CONNECTTIMEOUT)) + (SETQ REMAININGPORTS ALLPORTS) + (RETURN (do [COND + ((TIMEREXPIRED? BETWEENPROBE) + [COND + ((EQ (SETQ PROBECOUNT (SUB1 PROBECOUNT)) + 0) + (SETQ PORT (CAR REMAININGPORTS)) + (SETQ PROBECOUNT (COND + ((EQ (fetch PUPNET# of (CAR PORT)) + MYNET) + 1) + (T (* Try twice for hosts not on local + net) + 2))) + (SETQ REMAININGPORTS (OR (CDR REMAININGPORTS) + ALLPORTS] + (SETQ PUP (ALLOCATE.PUP)) + (SETUPPUP PUP (CAR PORT) + (OR POLLSOC (CDR PORT) + \DEFAULTPOLLINGSOC) + \PT.ECHOME NIL SOC 'FREE) + (SENDPUP SOC PUP) + (SETQ BETWEENPROBE (SETUPTIMER \BETWEENPROBEDELAY BETWEENPROBE] + (BLOCK) + (COND + ((AND (SETQ PUP (GETPUP SOC)) + (EQ (fetch PUPTYPE of PUP) + \PT.IAMECHO) + (OR (NEQ (fetch PUPSOURCENET of PUP) + MYNET) + (ASSOC (fetch PUPSOURCE of PUP) + LOCALPORTS)) + (SETQ VAL (\OPENGVCONNECTION (CONS (fetch PUPSOURCE + of PUP) + (OR CONNSOC + (fetch + PUPSOURCESOCKET + of PUP))) + TIMEOUT))) + + (* We got back an echo and succeeded in opening a connection. + ASSOC test assures that we don't pay attention to broadcast replies from hosts + that we weren't planning to talk to in the first place) + + (RETURN VAL))) repeatuntil (TIMEREXPIRED? CNTIME])]) + +(\OPENGVCONNECTION + [LAMBDA (FRNSOCKET TIMEOUT ERRORHANDLER FAILURESTRING) (* bvm%: " 4-Feb-86 12:38") + (LET ((INSTREAM (OPENBSPSTREAM FRNSOCKET NIL ERRORHANDLER TIMEOUT NIL (FUNCTION \GV.WHENCLOSED) + FAILURESTRING))) + (AND INSTREAM (COND + ((STREAMP INSTREAM) + (create GVCONNECTION + GVINSTREAM _ INSTREAM + GVOUTSTREAM _ (BSPOUTPUTSTREAM INSTREAM))) + (T (* Failed) + INSTREAM]) + +(GV.KILLSOCKET + [LAMBDA (SOCKET TIMEOUT) (* ; "Edited 15-Jun-90 14:27 by jds") + (CLOSEBSPSTREAM (fetch (GVCONNECTION GVINSTREAM) of SOCKET) + TIMEOUT) + (BLOCK]) + +(\GV.WHENCLOSED + [LAMBDA (BSPSTREAM) (* ; "Edited 15-Jun-90 14:27 by jds") + (* Called when BSPSTREAM is killed) + (for CONN in \GVCONNECTIONS when (EQ (fetch (GVCONNECTION GVINSTREAM) + of CONN) + BSPSTREAM) + do (replace (GVCONNECTION GVIDENTIFIED) of CONN with NIL) + (SETQ \GVCONNECTIONS (DREMOVE CONN \GVCONNECTIONS]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD GVCONNECTION (GVINSTREAM GVOUTSTREAM GVBUSY GVREGISTRY GVHOPS GVIDENTIFIED)) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DEFAULTPOLLINGSOC 5) + + +(CONSTANTS (\DEFAULTPOLLINGSOC 5)) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \BETWEENPROBEDELAY \CONNECTTIMEOUT) +) +) + +(RPAQQ \BETWEENPROBEDELAY 1000) + +(RPAQQ \CONNECTTIMEOUT 30000) + + + +(* Checking arguments) + +(DEFINEQ + +(\CHECKNAME + [LAMBDA (NAME) (* bvm%: "17-SEP-83 14:37") + [COND + ((NLISTP NAME) + (SETQ NAME (\UNPACKREG (OR NAME (\NONAMEERR] + (COND + ((ILESSP (IPLUS (NCHARS (CAR NAME)) + (NCHARS (CDR NAME))) + \MAXGVSTRING) (* less than because the dot takes 1 + more) + NAME) + (T (ERROR "name too long - must be < 65 chars" NAME]) + +(\CHECKSTRING + [LAMBDA (STRING) (* Beau " 7-SEP-82 13:43") + (SELECTQ (TYPENAME STRING) + (STRINGP) + (LISTP (COND + [(AND (CAR STRING) + (LITATOM (CAR STRING)) + (CDR STRING) + (LITATOM (CDR STRING))) + (SETQ STRING (CONCAT (CAR STRING) + '%. + (CDR STRING] + (T (ERROR "bad string arg" STRING)))) + (LITATOM (SETQ STRING (MKSTRING STRING))) + (ERROR "bad string arg" STRING)) + (COND + ((IGREATERP (NCHARS STRING) + \MAXGVSTRING) + (ERROR "string too long" STRING)) + (T STRING]) + +(\NONAMEERR + [LAMBDA NIL (* ht%: "13-JAN-82 12:05") + (ERROR "must have name for GV user op"]) + +(\UNPACKREG + [LAMBDA (REG) (* bvm%: "20-Jul-85 17:11") + (LET ((PPOS (STRPOS "." REG))) + (COND + [PPOS (CONS (SUBATOM REG 1 (SUB1 PPOS)) + (SUBATOM REG (ADD1 PPOS] + (T (CONS (MKATOM REG) + DEFAULTREGISTRY]) +) + +(RPAQ? DEFAULTREGISTRY ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DEFAULTREGISTRY) +) + + + +(* GVKEY) + +(DEFINEQ + +(\CHECKKEY + [LAMBDA (KEY) (* bvm%: "17-SEP-83 14:18") + (COND + ((KEYP KEY) + KEY) + (T (GV.MAKEKEY KEY]) + +(GV.MAKEKEY + [LAMBDA (STRING ISCLEAR) (* bvm%: "19-Jul-85 16:42") + (* As per section 2 of the Grapevine + Interface document) + (for I from 0 bind J C (KEY _ (CREATEKEY)) while (SETQ C (NTHCHARCODE + STRING + (ADD1 I))) + do (SETKEYBYTE KEY (SETQ J (IMOD I 8)) + (LOGXOR (GETKEYBYTE KEY J) + (LOGAND (LLSH (PROGN (OR ISCLEAR (SETQ C (\DECRYPT.PWD.CHAR C))) + (COND + [(AND (IGEQ C (CHARCODE A)) + (ILEQ C (CHARCODE Z))) + (* Coerce alphabetics to lowercase) + (IPLUS C (IDIFFERENCE (CHARCODE a) + (CHARCODE A] + (T C))) + 1) + 255))) finally (RETURN KEY]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(DATATYPE GVKEY ((GVKEY0 8 BYTE))) +) + +(/DECLAREDATATYPE 'GVKEY '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE) + '((GVKEY 0 (BITS . 7)) + (GVKEY 0 (BITS . 135)) + (GVKEY 1 (BITS . 7)) + (GVKEY 1 (BITS . 135)) + (GVKEY 2 (BITS . 7)) + (GVKEY 2 (BITS . 135)) + (GVKEY 3 (BITS . 7)) + (GVKEY 3 (BITS . 135))) + '4) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \#BYTES.GVKEY 8) + + +(CONSTANTS \#BYTES.GVKEY) +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS KEYP MACRO ((X) + (type? GVKEY X))) + +(PUTPROPS CREATEKEY MACRO (NIL (create GVKEY))) + +(PUTPROPS GETKEYBYTE MACRO (= . \GETBASEBYTE)) + +(PUTPROPS SETKEYBYTE MACRO (= . \PUTBASEBYTE)) +) +) + +(/DECLAREDATATYPE 'GVKEY '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE) + '((GVKEY 0 (BITS . 7)) + (GVKEY 0 (BITS . 135)) + (GVKEY 1 (BITS . 7)) + (GVKEY 1 (BITS . 135)) + (GVKEY 2 (BITS . 7)) + (GVKEY 2 (BITS . 135)) + (GVKEY 3 (BITS . 7)) + (GVKEY 3 (BITS . 135))) + '4) + + + +(* TIMESTAMP) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(DATATYPE TIMESTAMP ((TIMEHOST BITS 16) + (TIMETIMELO WORD) (* Mesa numbers backwards) + (TIMETIMEHI WORD)) + [ACCESSFNS TIMESTAMP ((TIMETIME (\MAKENUMBER (fetch (TIMESTAMP TIMETIMEHI + ) of + DATUM) + (fetch (TIMESTAMP TIMETIMELO) + of DATUM]) +) + +(/DECLAREDATATYPE 'TIMESTAMP '((BITS 16) + WORD WORD) + '((TIMESTAMP 0 (BITS . 15)) + (TIMESTAMP 1 (BITS . 15)) + (TIMESTAMP 2 (BITS . 15))) + '4) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \#BYTES.TIMESTAMP 6) + + +(CONSTANTS \#BYTES.TIMESTAMP) +) +) + +(/DECLAREDATATYPE 'TIMESTAMP '((BITS 16) + WORD WORD) + '((TIMESTAMP 0 (BITS . 15)) + (TIMESTAMP 1 (BITS . 15)) + (TIMESTAMP 2 (BITS . 15))) + '4) +(DEFINEQ + +(\TIMESTAMP.DEFPRINT + [LAMBDA (STAMP STREAM) (* bvm%: "21-May-86 10:44") + (.SPACECHECK. STREAM 6) + (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) + (printout STREAM "") + T]) + +(\CHECKSTAMP + [LAMBDA (STAMP) (* bvm%: "19-Jul-85 16:54") + (COND + (STAMP (\DTEST STAMP 'TIMESTAMP)) + (T (create TIMESTAMP]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(DEFPRINT 'TIMESTAMP '\TIMESTAMP.DEFPRINT) +) + + + +(* I/O primitives) + +(DEFINEQ + +(\SENDITEM + [LAMBDA (OUTSTREAM ITEM) (* bvm%: "20-Jul-85 17:30") + + (* send out ITEM as determined by its type as per the specs in section 4.0 of + the Grapevine Interface document) + + (COND + ((FIXP ITEM) + (\SENDWORD OUTSTREAM ITEM)) + [(OR (LITATOM ITEM) + (STRINGP ITEM)) + (COND + (ITEM (\SENDSTRING OUTSTREAM ITEM)) + (T (* not a string at all but an empty + string list) + (\SENDWORD OUTSTREAM 0] + ((KEYP ITEM) + (\BOUTS OUTSTREAM ITEM 0 \#BYTES.GVKEY)) + ((type? TIMESTAMP ITEM) + (\BOUTS OUTSTREAM ITEM 0 \#BYTES.TIMESTAMP)) + [(LISTP ITEM) (* may be a name pair, a string + list, or a byte kludge) + (COND + [(LITATOM (CDR ITEM)) (* an RName - + cons pair of two atoms) + (LET [(length (IPLUS 1 (NCHARS (CAR ITEM)) + (NCHARS (CDR ITEM] + (\SENDWORD OUTSTREAM length) + (\SENDWORD OUTSTREAM 0) + (PRIN3 (CAR ITEM) + OUTSTREAM) + (BOUT OUTSTREAM (CHARCODE %.)) + (PRIN3 (CDR ITEM) + OUTSTREAM) + (COND + ((ODDP length) (* padding needed) + (BOUT OUTSTREAM 0] + [(EQ (CAR ITEM) + \3BYTEKLUDGEKEY) + + (* somewhat miss-named now, this gives a way of sending small numbers as bytes + instead of words) + + (for b in (CDR ITEM) do (BOUT OUTSTREAM (LOGAND b 255] + (T (* string list) + [\SENDWORD OUTSTREAM (for e in ITEM sum (IPLUS 2 (FOLDHI (NCHARS e) + BYTESPERWORD] + (for e in ITEM do (\SENDSTRING OUTSTREAM e] + (T (SHOULDNT]) + +(\SENDSTRING + [LAMBDA (STREAM STRING) (* bvm%: "19-Jul-85 16:55") + (PROG ((L (NCHARS STRING))) + (COND + ((IGREATERP L \MAXGVSTRING) + (ERROR "string too long" STRING) + (RETURN))) + (\SENDWORD STREAM L) + (\SENDWORD STREAM \MAXGVSTRING) (* This word is ignored) + (PRIN3 STRING STREAM) + (COND + ((ODDP L) (* pad) + (BOUT STREAM 0]) +) +(DEFINEQ + +(\RECEIVEBOOL + [LAMBDA (STREAM) (* bvm%: "11-MAY-83 14:51") + (SELECTQ (BIN STREAM) + (1 T) + (0 NIL) + (SHOULDNT]) + +(\RECEIVECLIST + [LAMBDA (STREAM) (* bvm%: "11-MAY-83 14:57") + (* receive a list of components) + (\RECEIVESTAMP STREAM T) + (to (\RECEIVEWORD STREAM) collect (\RECEIVECOMPONENT STREAM]) + +(\RECEIVECOMPONENT + [LAMBDA (STREAM) (* bvm%: "11-MAY-83 14:57") + (* receive a component - + just a list of words) + (to (\RECEIVEWORD STREAM) collect (\RECEIVEWORD STREAM]) + +(\RECEIVERLIST + [LAMBDA (INSTREAM) (* bvm%: "11-MAY-83 15:58") + (* receive a list of RNames - + prefix the result with the time + STAMP) + (bind STRLEN (STAMP _ (\RECEIVESTAMP INSTREAM)) + (NWORDS _ (\RECEIVEWORD INSTREAM)) while (IGREATERP NWORDS 0) + collect (PROG1 (\RECEIVESTRING INSTREAM (SETQ STRLEN (\RECEIVEWORD INSTREAM))) + (* mind the possible odd length, and + add 2 NWORDS for STRLEN and max) + (SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (FOLDHI STRLEN BYTESPERWORD) + 2)))) + finally (RETURN (CONS STAMP $$VAL]) + +(\RECEIVERNAME + [LAMBDA (INSTREAM) (* bvm%: "11-MAY-83 15:59") + (\RECEIVESTRING INSTREAM (\RECEIVEWORD INSTREAM]) + +(\RECEIVESTAMP + [LAMBDA (STREAM OLDSTAMP) (* bvm%: "20-Jul-85 17:16") + (COND + ((EQ OLDSTAMP T) + (RPTQ \#BYTES.TIMESTAMP (BIN STREAM)) + T) + (T [COND + ((NOT (type? TIMESTAMP OLDSTAMP)) + (SETQ OLDSTAMP (create TIMESTAMP] + (\BINS STREAM OLDSTAMP 0 \#BYTES.TIMESTAMP))) + OLDSTAMP]) + +(\RECEIVESTRING + [LAMBDA (STREAM LENGTH) (* bvm%: "21-May-86 10:45") + (\SKIPWORD STREAM) (* ignore maxLength) + (LET ((STRING (ALLOCSTRING LENGTH))) + (\BINS STREAM (fetch (STRINGP BASE) of STRING) + (fetch (STRINGP OFFST) of STRING) + LENGTH) + (COND + ((ODDP LENGTH) + (BIN STREAM))) + STRING]) +) + +(RPAQQ \3BYTEKLUDGEKEY $$3byte$$) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \RECEIVEWORD MACRO (= . \WIN)) + +(PUTPROPS \SKIPWORD MACRO (OPENLAMBDA (STREAM) + (PROGN (BIN STREAM) + (BIN STREAM)))) + +(PUTPROPS \SENDWORD MACRO (= . \WOUT)) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \MAXGVSTRING 64) + + +(CONSTANTS (\MAXGVSTRING 64)) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \3BYTEKLUDGEKEY) +) +) +(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY + +(SELECTQ (COMPILEMODE) + (D (FILESLOAD (LOADCOMP) + PUP BSP)) + (PDP-10 (FILESLOAD (LOADCOMP) + PUP10 BSPAUX)) + NIL) +) +(PUTPROPS GRAPEVINE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3957 7826 (GV.AUTHENTICATE 3967 . 4171) (GV.CHECKSTAMP 4173 . 4417) (GV.EXPAND 4419 . +4802) (GV.IDENTIFYCALLER 4804 . 5012) (GV.IDENTIFYME 5014 . 5443) (GV.ISINLIST 5445 . 5838) ( +GV.ISMEMBERCLOSURE 5840 . 6098) (GV.ISMEMBERDIRECT 6100 . 6356) (GV.READCONNECT 6358 . 6574) ( +GV.READENTRY 6576 . 6830) (GV.READFRIENDS 6832 . 7090) (GV.READMEMBERS 7092 . 7350) (GV.READOWNERS +7352 . 7608) (GV.READREMARK 7610 . 7824)) (7875 14013 (GV.ADDFORWARD 7885 . 8160) (GV.ADDFRIEND 8162 + . 8436) (GV.ADDLISTOFMEMBERS 8438 . 9292) (GV.ADDMAILBOX 9294 . 9569) (GV.ADDMEMBER 9571 . 9849) ( +GV.ADDOWNER 9851 . 10122) (GV.CHANGECONNECT 10124 . 10788) (GV.CHANGEPASSWORD 10790 . 11067) ( +GV.CHANGEREMARK 11069 . 11348) (GV.CREATEGROUP 11350 . 11576) (GV.CREATEINDIVIDUAL 11578 . 11859) ( +GV.DELETEGROUP 11861 . 12087) (GV.DELETEINDIVIDUAL 12089 . 12325) (GV.NEWNAME 12327 . 12598) ( +GV.REMOVEFORWARD 12600 . 12881) (GV.REMOVEFRIEND 12883 . 13163) (GV.REMOVEMAILBOX 13165 . 13446) ( +GV.REMOVEMEMBER 13448 . 13732) (GV.REMOVEOWNER 13734 . 14011)) (14049 23102 (\GVOP 14059 . 14480) ( +\ENQUIRE 14482 . 19829) (\PERFORMGVOP 19831 . 20243) (FINDREGSERVER 20245 . 21933) (LOCATESOCKETS +21935 . 23100)) (29964 36668 (OPENCLOSESTSOCKET 29974 . 35207) (\OPENGVCONNECTION 35209 . 35844) ( +GV.KILLSOCKET 35846 . 36072) (\GV.WHENCLOSED 36074 . 36666)) (37112 38937 (\CHECKNAME 37122 . 37667) ( +\CHECKSTRING 37669 . 38447) (\NONAMEERR 38449 . 38601) (\UNPACKREG 38603 . 38935)) (39053 40657 ( +\CHECKKEY 39063 . 39244) (GV.MAKEKEY 39246 . 40655)) (43027 43717 (\TIMESTAMP.DEFPRINT 43037 . 43519) +(\CHECKSTAMP 43521 . 43715)) (43824 46710 (\SENDITEM 43834 . 46163) (\SENDSTRING 46165 . 46708)) ( +46711 49644 (\RECEIVEBOOL 46721 . 46907) (\RECEIVECLIST 46909 . 47229) (\RECEIVECOMPONENT 47231 . +47590) (\RECEIVERLIST 47592 . 48602) (\RECEIVERNAME 48604 . 48773) (\RECEIVESTAMP 48775 . 49167) ( +\RECEIVESTRING 49169 . 49642))))) +STOP diff --git a/internal/envos/LARGESKETCHPATCH b/internal/envos/LARGESKETCHPATCH new file mode 100644 index 00000000..ff1bb52b --- /dev/null +++ b/internal/envos/LARGESKETCHPATCH @@ -0,0 +1,71 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 17:09:55"  +|{DSK}local>lde>lispcore>internal>library>LARGESKETCHPATCH.;2| 3370 + + |changes| |to:| (VARS LARGESKETCHPATCHCOMS) + + |previous| |date:| "27-Feb-87 18:22:14" +|{DSK}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 diff --git a/internal/envos/LFHACKS b/internal/envos/LFHACKS new file mode 100644 index 00000000..9f8076e2 --- /dev/null +++ b/internal/envos/LFHACKS @@ -0,0 +1,506 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(filecreated " 4-Jun-87 18:33:02" {eris}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}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 " " + *error-output*)) + (return)) + ((igeq fp last-boot-file-page) + (cl:when verbose (cl:princ " " *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* "" 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 + \ No newline at end of file diff --git a/internal/envos/LISPDIAGNOSTICS b/internal/envos/LISPDIAGNOSTICS new file mode 100644 index 00000000..413357e8 --- /dev/null +++ b/internal/envos/LISPDIAGNOSTICS @@ -0,0 +1,815 @@ +(FILECREATED "19-Dec-84 19:20:52" {ERIS}LIBRARY>LISPDIAGNOSTICS.;37 31535 + + changes to: (FNS DSKPROC.DO1COPY) + + previous date: "16-Dec-84 18:48:51" {ERIS}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 diff --git a/internal/envos/LISPDIAGNOSTICS.TEDIT b/internal/envos/LISPDIAGNOSTICS.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..dc181eb81f7fef472969f6f5261f549fa7b0fe67 GIT binary patch literal 2428 zcmb7EQE%f!5Y83u!G~4|@qok&Qyo$pDYcp&2kjvp_!74bBu&-0IuPPvV{hVBHePFY z-84nK@u&EA%s5F&>_f-pAzpv}cIKOJW|uM6?~SgZ+Y2tPhNGz088P~KUG4ZF&CMGMA+EKv9QpWHixd{(@a|@V+*;_Q^V&l(FT4IM&Cob zeS8W$OPKfgeg+F|X4Y{hb!L4`5NW_y<3PF=D9sZffm{0gZf7`viP3X#saWOh%dz2R zN&5o}R_hG7#RxEwnY1a&qewEFmRlxLi576c3JO?ArGV$T;Km2${i@ec%I^f6K%8nB z3)=$e3m**`mD<94VPa_oRfCYuVT1V0V_t9am5 zt~2~l=5rd{GDqW?cQ^=s4!6o4gjcssK*F5QL>a!6zgEt?w3LXA(v>YSWAZx^_xsM<{c5aul0;<9v3(W9Gjkye>f8L2+aHK{{H@V+7%gz#1|)E zgu~?>S9UdRoy)S_Q|$n`WyHb=%e+7E_0N_3oc7XCB-jOVgqX2L*pekQuw7|qC_fb z9rTBy9F{j-j%Abw1&^^Ua$zPimRw;FCoENqe)TdZ%v?M?=-20kQodbUDo1C`+r2-@ znhPwLXHHw*q6^VZ0Og zVms(N8Ru2TmsOya<%bVvbgEm*j%|vgmu{7DTm^or0$){un$l0+%Q&bqo>zhWDsWT< zPO8B7Rp6`&d{+g&tpc@L231Ba3#&3}t*nj1=hZErR)Lz1@WUDJZ&WQyZ9X=@)4v*% Hhrj;;l3Cw! literal 0 HcmV?d00001 diff --git a/internal/envos/NSMAIL b/internal/envos/NSMAIL new file mode 100644 index 00000000..ed96c852 --- /dev/null +++ b/internal/envos/NSMAIL @@ -0,0 +1,1741 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "26-Jun-90 18:42:52" {DSK}local>lde>lispcore>internal>library>NSMAIL.;3 132387 + + changes to%: (VARS NSMAILCOMS) + (FNS NS.POLLNEWMAIL NS.OPENMAILBOX \NSMAIL.CHECK \NSMAIL.FIX.MAILBOX.LOCATIONS + NS.NEXTMESSAGE \NSMAIL.READ.ENVELOPES INBASKET.CALL NS.RETRIEVEMESSAGE + \NSMAIL.RETRIEVE \NSMAIL.SIGNAL.ERROR NS.CLOSEMAILBOX \NSMAIL.LOGOFF + \NSMAIL.CHANGE.STATUS \MAILOBJ.DISPLAY \MAILOBJ.IMAGEBOX \MAILOBJ.PUT + \MAILOBJ.BUTTONEVENTFN \MAILOBJ.HARDCOPY \MAILOBJ.FB \MAILOBJ.PUT.FILE + \MAILOBJ.VIEW \MAILOBJ.EXPAND \NSMAIL.SEND) + + previous date%: "14-Feb-90 17:23:04" {DSK}local>lde>lispcore>internal>library>NSMAIL.;2) + + +(* ; " +Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT NSMAILCOMS) + +(RPAQQ NSMAILCOMS + [(COMS (* ; "Basic mail protocol") + (COURIERPROGRAMS MAILTRANSPORT INBASKET) + (FNS \NSMAIL.AUTHENTICATE \NSMAIL.MAKE.MAILSERVERS \NSMAIL.LOGIN NS.FINDMAILBOXES) + (ALISTS (LAFITEMODELST NS STAR))) + (COMS (* ; "Retrieving mail") + (FNS NS.POLLNEWMAIL NS.OPENMAILBOX \NSMAIL.CHECK \NSMAIL.FIX.MAILBOX.LOCATIONS + NS.NEXTMESSAGE \NSMAIL.READ.ENVELOPES INBASKET.CALL NS.RETRIEVEMESSAGE + \NSMAIL.RETRIEVE \NSMAIL.EOF.ON.RETRIEVE \NSMAIL.READ.SERIALIZED.TREE + \NSMAIL.CHECK.SERIALIZED.VERSION \NSMAIL.READ.SERIALIZED.CONTENT + \NSMAIL.DISCARD.SERIALIZED.CONTENT \NSMAIL.READ.STRING.AS.STREAM + \NSMAIL.PRINT.HEADERFIELDS \NSMAIL.PRINT.NAMES) + (* ; "Error handling") + (FNS \NSMAIL.COURIER.OPEN \NSMAIL.ERRORHANDLER \NSMAIL.SIGNAL.ERROR) + (* ; "Close/flush protocol") + (FNS NS.CLOSEMAILBOX \NSMAIL.LOGOFF \NSMAIL.CHANGE.STATUS) + [INITVARS (NSMAILDEBUGFLG) + (NSMAIL.LEAVE.ATTACHMENTS) + (NSMAIL.HEADER.ORDER '(Date Sender From Subject In-Reply-to To cc Message-ID + Reply-to] + (ADDVARS (\NSMAIL.GOOD.BODYTYPES 2 4))) + [COMS (* ; + "Handling attachments as a special kind of image object") + (FNS \MAILOBJ.CREATE \MAILOBJ.TYPE.NAME \MAILOBJ.NS.TO.LISP.NAME \MAILOBJ.DISPLAY + \MAILOBJ.GET \MAILOBJ.IMAGEBOX \MAILOBJ.PUT \MAILOBJ.INIT) + (FNS \MAILOBJ.BUTTONEVENTFN \MAILOBJ.DO.COMMAND \MAILOBJ.HARDCOPY \MAILOBJ.FB + \MAILOBJ.PUT.FILE \MAILOBJ.VIEW \MAILOBJ.MUNGE.NAME \MAILOBJ.COPY.BODY + \MAILOBJ.EXPAND \MAILOBJ.COPY.CHILD \MAILOBJ.COPY.SEQUENCE \MAILOBJ.EXTRACT.TEXT + \MAILOBJ.PARSE.ATTRIBUTES) + (ADDVARS (FILING.TYPES (VIEWPOINT 4353) + (RES 4428) + (XEROX860 5120) + (REFERENCE 4427) + (MAILFOLDER 4417))) + (VARS MAILOBJ.REFERENCE.FIELD) + (INITVARS (MAILOBJ.WINDOWOFFSET 16) + (MAILOBJ.SKIPCHAR (CHARCODE "."))) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MAILOBJ) + (CONSTANTS \MAILOBJ.REFERENCE.LAST.FILED)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAILOBJ.INIT) + (AND (EQ MAKESYSNAME :LYRIC) + (FILESLOAD (SYSLOAD) + NSRANDOM] + (COMS (* ; "sending mail") + (FNS \NSMAIL.SEND.PARSE \NSMAIL.PARSE.REFERENCE \NSMAIL.EXPAND.DL \NSMAIL.PARSE + \NSMAIL.PARSE1 NS.REMOVEDUPLICATES \NSMAIL.SEND \NSMAIL.PREPARE.ATTACHMENT + \NSMAIL.GUESS.FILE.TYPE \NSMAIL.SEND.MESSAGE.CONTENT + COURIER.WRITE.STREAM.UNSPECIFIED \NSMAIL.SEND.STREAM.AS.STRING + \NSMAIL.WRITE.ATTRIBUTE \NSMAIL.FINDSERVER \NSMAIL.CHECKSERVER) + (FILES LAFITEMAIL) + (* ; "for LAFITE.MAKE.PARSE.TABLE") + (VARS NSMAIL.PARSEFIELDS (\LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS)) + ) + (GLOBALVARS \LAPARSE.NSMAIL) + (INITVARS (\NSMAIL.SERVER.CACHE) + (NSMAIL.NET.HINT) + (*NSMAIL-MAX-NOTE-LENGTH* 8000) + (*NSMAIL-SEND-MAIL-NOTES*) + (*NSMAIL-CACHE-TIMEOUT* 14400000) + (LAFITEDL.EXT "DL")) + [P (CL:PROCLAIM '(GLOBAL NSMAIL.NET.HINT *NSMAIL-MAX-NOTE-LENGTH* + *NSMAIL-SEND-MAIL-NOTES* *NSMAIL-CACHE-TIMEOUT*] + (ADDVARS (\SYSTEMCACHEVARS \NSMAIL.SERVER.CACHE)) + (FNS \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.MAKEANSWERFORM)) + (COMS (* ; + "Utility for handling mail attributes") + (PROP COURIERDEF ENVELOPE.ITEM) + (FNS \NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM) + (VARS \NSMAIL.ENVELOPE.ITEM.TYPES) + (DECLARE%: EVAL@COMPILE DOCOPY (VARS \NSMAIL.ATTRIBUTES))) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NSMAILBOX NSMAILSTATE NSMAILPARSE) + (CONSTANTS \NSMAIL.SOCKET \SERIALIZED.FILE.VERSION \SERIALIZED.FILE.VERSIONS + \NSMAIL.CTSTANDARD.MESSAGE \NSMAIL.TEXT.BODYTYPE \NSMAIL.EMPTY.BODYTYPE + \NSMAIL.REFERENCE.BODYTYPE MAX.BULK.SEGMENT.LENGTH \NULL.CACHE.VERIFIER) + (MACROS \NSMAIL.ATTRIBUTE.TYPE \NSMAIL.WRITE.ATTRIBUTE \NSMAIL.WRITE.ATTRIBUTE.MACRO) + (PROP INFO \NSMAIL.ATTRIBUTE.TYPE) + (GLOBALVARS NSMAIL.NET.HINT \NSMAIL.ENVELOPE.ITEM.TYPES \NSMAIL.ATTRIBUTES + \NSMAIL.SERVER.CACHE NSMAILDEBUGFLG NSWIZARDFLG NSMAIL.LEAVE.ATTACHMENTS + \NSMAIL.GOOD.BODYTYPES MAILOBJ.WINDOWOFFSET MAILOBJ.SKIPCHAR \MAILOBJ.IMAGEFNS + MAILOBJ.REFERENCE.FIELD \NSFILING.ATTRIBUTES DEFAULTICONFONT NSPRINT.WATCHERFLG + NSMAIL.HEADER.ORDER FILING.TYPES) + [P (CL:PROCLAIM '(CL:SPECIAL *RETRIEVAL-ERROR*] + (FILES (SOURCE) + LAFITEDECLS) + (FILES (LOADCOMP) + CLEARINGHOUSE) + (LOCALVARS . T)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA INBASKET.CALL]) + + + +(* ; "Basic mail protocol") + + +(COURIERPROGRAM MAILTRANSPORT (17 4) + TYPES + [(CREDENTIALS (AUTHENTICATION . CREDENTIALS)) + (VERIFIER (AUTHENTICATION . VERIFIER)) + (ENVELOPE.ITEM.TYPE LONGCARDINAL) + (ENVELOPE (SEQUENCE ENVELOPE.ITEM)) + (INVALID.NAME (RECORD (REASON INVALID.NAME.REASON) + (NAME RNAME))) + (INVALID.NAME.LIST (SEQUENCE INVALID.NAME)) + (INVALID.NAME.REASON (ENUMERATION (NoSuchRecipient 0) + (CantValidateNow 1) + (IllegalName 2) + (Refused 3) + (NoAccessToDl 4) + (Timeout 5) + (NoDlsAllowed 6) + (MessageTooLong 7))) + (NAME (CLEARINGHOUSE . NAME)) + (NAME.LIST (SEQUENCE NAME)) + (RNAME NAME) + (RNAME.LIST (SEQUENCE RNAME)) + (WILLINGNESS CARDINAL) + (CONTENTS.TYPE LONGCARDINAL) + (MESSAGEID (ARRAY 5 UNSPECIFIED)) + (POSTMARK (RECORD (POSTED.AT NAME) + (TIME TIME))) + (PROBLEM (RECORD (UNDELIVERABLES INVALID.NAME.LIST) + (RETURNED.ENVELOPE ENVELOPE))) + (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM)) + (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) + (ServiceFull 1) + (ServiceUnavailable 2) + (MediumFull 3))) + (TRANSFER.PROBLEM (ENUMERATION (Aborted 0) + (NoRendezvous 1) + (WrongDirection 4] + PROCEDURES + ((SERVER.POLL 0 (CREDENTIALS VERIFIER) + RETURNS + (WILLINGNESS (CLEARINGHOUSE . NETWORK.ADDRESS.LIST) + VERIFIER NAME)) + (POST 1 (CREDENTIALS VERIFIER RNAME.LIST BOOLEAN BOOLEAN CONTENTS.TYPE ENVELOPE + BULK.DATA.SOURCE) + RETURNS + (INVALID.NAME.LIST MESSAGEID) + REPORTS + (AUTHENTICATION.ERROR CONNECTION.ERROR INVALID.RECIPIENTS SERVICE.ERROR TRANSFER.ERROR + UNDEFINED.ERROR))) + ERRORS + ((AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) + (CONNECTION.ERROR 2 (CONNECTION.PROBLEM)) + (INVALID.RECIPIENTS 3 (INVALID.NAME.LIST)) + (SERVICE.ERROR 4 (SERVICE.PROBLEM)) + (TRANSFER.ERROR 5 (TRANSFER.PROBLEM)) + (UNDEFINED.ERROR 6 (CARDINAL)))) + +(COURIERPROGRAM INBASKET (18 1) + INHERITS + (MAILTRANSPORT) + TYPES + [(CREDENTIALS (AUTHENTICATION . CREDENTIALS)) + (VERIFIER (AUTHENTICATION . VERIFIER)) + (SESSION (RECORD (HANDLE (ARRAY 2 UNSPECIFIED)) + (VERIFIER VERIFIER))) + (ENVELOPE.ITEM.TYPE LONGCARDINAL) + (ENVELOPE (SEQUENCE ENVELOPE.ITEM)) + (INVALID.NAME (RECORD (REASON INVALID.NAME.REASON) + (NAME RNAME))) + (INVALID.NAME.LIST (SEQUENCE INVALID.NAME)) + (INVALID.NAME.REASON (ENUMERATION (NoSuchRecipient 0) + (CantValidateNow 1) + (IllegalName 2) + (Refused 3) + (NoAccessToDl 4) + (Timeout 5) + (NoDlsAllowed 6) + (MessageTooLong 7))) + (NAME (CLEARINGHOUSE . NAME)) + (NAME.LIST (SEQUENCE NAME)) + (RNAME NAME) + (RNAME.LIST (SEQUENCE RNAME)) + (CONTENTS.TYPE LONGCARDINAL) + (INDEX CARDINAL) + (INBASKET.STATE (RECORD (LASTINDEX INDEX) + (NEWCOUNT CARDINAL) + (ISPRIMARY BOOLEAN) + (ISPRIMARYUP BOOLEAN))) + (RANGE (RECORD (FIRST INDEX) + (LAST INDEX))) + (MAIL.ATTRIBUTE.TYPE LONGCARDINAL) + [MAIL.ATTRIBUTE (RECORD (TYPE MAIL.ATTRIBUTE.TYPE) + (VALUE (SEQUENCE UNSPECIFIED] + [SELECTIONS (RECORD (TRANSPORT.ENVELOPE BOOLEAN) + (INBASKET.ENVELOPE BOOLEAN) + (MAIL.ATTRIBUTES (SEQUENCE MAIL.ATTRIBUTE.TYPE] + (CACHE.VERIFIER (ARRAY 4 UNSPECIFIED)) + (MESSAGE.DESCRIPTION (RECORD (MESSAGE.INDEX INDEX) + (TRANSPORT.ENVELOPE ENVELOPE) + (INBASKET.ENVELOPE ENVELOPE) + (CONTENT.ATTRIBUTES ENVELOPE))) + (CACHE.STATUS UNSPECIFIED) + (STATUS (ENUMERATION (NEW 0) + (KNOWN 1) + (RECEIVED 2))) + (ACCESS.PROBLEM (ENUMERATION (AccessRightsInsufficient 0) + (AccessRightsIndeterminate 1) + (InbasketInUse 2) + (NoSuchRecipients 3) + (RecipientNameIndeterminate 4))) + (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM)) + (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) + (ServiceFull 1) + (ServiceUnavailable 2) + (MediumFull 3))) + (TRANSFER.PROBLEM (ENUMERATION (Aborted 0) + (NoRendezvous 1) + (WrongDirection 4))) + (SESSION.PROBLEM (ENUMERATION (TokenInvalid 0) + (SessionInUse 1))) + (CALL.PROBLEM (ENUMERATION (USE.COURIER 0] + PROCEDURES + ((LOGON 5 (CREDENTIALS VERIFIER NAME CACHE.VERIFIER BOOLEAN) + RETURNS + (SESSION CACHE.STATUS) + REPORTS + (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR)) + (LOGOFF 4 (SESSION) + RETURNS + (CACHE.VERIFIER) + REPORTS + (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR)) + (MAILPOLL 7 (CREDENTIALS VERIFIER NAME) + RETURNS + (INBASKET.STATE) + REPORTS + (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR)) + (MAILCHECK 6 (SESSION) + RETURNS + (INBASKET.STATE CARDINAL) + REPORTS + (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR)) + (CHANGE.STATUS 0 (SESSION RANGE STATUS) + RETURNS NIL REPORTS (AUTHENTICATION.ERROR INVALID.INDEX SESSION.ERROR UNDEFINED.ERROR)) + (DELETE 1 (SESSION RANGE) + RETURNS NIL REPORTS (AUTHENTICATION.ERROR INVALID.INDEX SESSION.ERROR UNDEFINED.ERROR)) + (LIST 2 (SESSION RANGE SELECTIONS BULK.DATA.SINK) + RETURNS NIL REPORTS (AUTHENTICATION.ERROR CONNECTION.ERROR INVALID.INDEX SESSION.ERROR + TRANSFER.ERROR UNDEFINED.ERROR)) + (LOCATE 3 (SESSION STATUS) + RETURNS + (INDEX) + REPORTS + (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR)) + (RETRIEVE 8 (SESSION INDEX CONTENTS.TYPE BULK.DATA.SINK) + RETURNS + (ENVELOPE ENVELOPE) + REPORTS + (AUTHENTICATION.ERROR CONNECTION.ERROR CONTENTS.TYPE.MISMATCH INVALID.INDEX + SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR))) + ERRORS + ((ACCESS.ERROR 0 (ACCESS.PROBLEM)) + (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) + (CONNECTION.ERROR 2 (CONNECTION.PROBLEM)) + (CONTENTS.TYPE.MISMATCH 3 (CONTENTS.TYPE)) + (SESSION.ERROR 5 (SESSION.PROBLEM)) + (INVALID.INDEX 4 (INDEX)) + (SERVICE.ERROR 6 (SERVICE.PROBLEM)) + (TRANSFER.ERROR 7 (TRANSFER.PROBLEM)) + (UNDEFINED.ERROR 8 (CALL.PROBLEM)))) +(DEFINEQ + +(\NSMAIL.AUTHENTICATE +(LAMBDA NIL (* ; "Edited 5-Jan-90 18:36 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) NSUSERNAME FULLNAME MSERVERS AUTHENTICATED? CREDENTIALS MSG) (SETQ NSUSERNAME (PARSE.NSNAME (CAR INFO))) (COND ((NEQ (SETQ AUTHENTICATED? (COND ((NULL (SETQ FULLNAME (CH.LOOKUP.OBJECT NSUSERNAME))) (QUOTE NoSuchUser)) (T (NS.AUTHENTICATE (SETQ CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS (CONS FULLNAME (CDR INFO)))))))) T) (printout PROMPTWINDOW T "Cannot authenticate user " (NSNAME.TO.STRING (OR FULLNAME NSUSERNAME) T) " because: " (SELECTQ (SETQ \LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?) (CredentialsInvalid "Login incorrect") (KeysUnavailable (CONCAT "Authentication server unavailable for domain " (fetch NSDOMAIN of FULLNAME))) (NoSuchUser "No such user") AUTHENTICATED?) ".") NIL) (T (create LAFITEMODEDATA FULLUSERNAME _ (NSNAME.TO.STRING FULLNAME T) UNPACKEDUSERNAME _ FULLNAME CREDENTIALS _ CREDENTIALS SHORTUSERNAME _ (CONCAT (fetch NSOBJECT of FULLNAME) (QUOTE %:) (COND ((NOT (STRING-EQUAL (fetch NSDOMAIN of FULLNAME) CH.DEFAULT.DOMAIN)) (fetch NSDOMAIN of FULLNAME)) (T ""))) MAILSERVERS _ (\NSMAIL.MAKE.MAILSERVERS (NS.FINDMAILBOXES FULLNAME) FULLNAME CREDENTIALS)))))) +) + +(\NSMAIL.MAKE.MAILSERVERS +(LAMBDA (SERVERS FULLNAME CREDENTIALS) (* ; "Edited 16-Aug-89 16:05 by bvm") (* ;; "Return a list of mail server info for insertion in the MAILSERVERS slot of NS mode. Each element of SERVERS is of the form (name . addresses)") (if (NULL SERVERS) then (printout PROMPTWINDOW T "There are no mail servers for user " (NSNAME.TO.STRING FULLNAME T)) NIL else (for PAIR in SERVERS bind (FIRSTTIME _ T) collect (create MAILSERVER MAILPORT _ (CADR PAIR) MAILSERVERNAME _ (CAR PAIR) MAILSERVEROPS _ (CONSTANT (LIST (FUNCTION NS.POLLNEWMAIL) (FUNCTION NS.OPENMAILBOX) (FUNCTION NS.NEXTMESSAGE) (FUNCTION NS.RETRIEVEMESSAGE) (FUNCTION NS.CLOSEMAILBOX))) MAILSTATE _ (create NSMAILSTATE STATENAME _ FULLNAME STATEADDRESS _ (CADR PAIR) STATECREDENTIALS _ CREDENTIALS STATETIMER _ (if FIRSTTIME then (* ; "Only need a timer on the first server") (SETQ FIRSTTIME NIL) (SETUPTIMER *NSMAIL-CACHE-TIMEOUT*))))))) +) + +(\NSMAIL.LOGIN +(LAMBDA NIL (* ; "Edited 7-Jun-88 19:37 by bvm") (if (LAFITE.PROMPT.FOR.LOGIN (QUOTE |NS::|)) then (* ; "Got the login, now authenticate") (\LAFITE.GET.USER.DATA (QUOTE NS) NIL T) (\LAFITE.WAKE.WATCHER))) +) + +(NS.FINDMAILBOXES +(LAMBDA (USERNAME) (* ; "Edited 18-Jul-88 12:55 by bvm") (LET ((MAILBOXENTRY (CH.RETRIEVE.ITEM (PARSE.NSNAME USERNAME) (CH.PROPERTY (QUOTE MAILBOXES)) (QUOTE MAILBOX.VALUES)))) (AND MAILBOXENTRY (for MB in (COURIER.FETCH (CLEARINGHOUSE . MAILBOX.VALUES) MAIL.SERVICE of (CADR MAILBOXENTRY)) when (SETQ MB (COND ((LOOKUP.NS.SERVER MB NIL T)) (T (PRINTOUT PROMPTWINDOW T "Cannot find address for mail server " MB) NIL))) collect MB)))) +) +) + +(ADDTOVAR LAFITEMODELST (NS 1 \NSMAIL.SEND.PARSE \NSMAIL.SEND \NSMAIL.MAKEANSWERFORM + \NSMAIL.AUTHENTICATE \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P + \NSMAIL.LOGIN) + (STAR . NS)) + + + +(* ; "Retrieving mail") + +(DEFINEQ + +(NS.POLLNEWMAIL + [LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* ; "Edited 26-Jun-90 18:21 by jds") + (LET (RESULT N) + (COND + ((NOT (SETQ RESULT (\NSMAIL.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER))) + (* ; "Server down") + '?) + ((AND (> (SETQ N (fetch (NSMAILSTATE STATEFIRSTNEW) of (fetch MAILSTATE + of MAILSERVER))) + 0) + (> (SETQ N (ADD1 (- (COURIER.FETCH (INBASKET . INBASKET.STATE) + LASTINDEX of RESULT) + N))) + 0)) (* ; "Return number of messages") + N]) + +(NS.OPENMAILBOX + [LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* ; "Edited 26-Jun-90 18:21 by jds") + (LET ((STREAM (\NSMAIL.COURIER.OPEN ADDRESS)) + NSMAILSTATE INBASKETSTATE FIRSTINDEX LASTINDEX N) + (COND + ((NULL STREAM) + NIL) + ((OR (NULL (SETQ INBASKETSTATE (\NSMAIL.CHECK ADDRESS REGISTEREDNAME CREDENTIALS + MAILSERVER STREAM T))) + (EQ (CAR INBASKETSTATE) + 'ERROR)) + (CLOSEF STREAM) (* ; "Return error msg") + (CONS NIL (CDR INBASKETSTATE))) + ((EQ [SETQ N (COND + ((EQ [SETQ FIRSTINDEX (fetch (NSMAILSTATE STATEFIRSTNEW) + of (SETQ NSMAILSTATE (fetch MAILSTATE + of MAILSERVER] + 0) (* ; "No NEW messages at all") + 0) + (T (* ; "Protocol suggests using (courier.fetch (inbasket . inbasket.state) newcount inbasketstate) but that's always zero.") + (ADD1 (- (SETQ LASTINDEX (COURIER.FETCH (INBASKET . INBASKET.STATE) + LASTINDEX of INBASKETSTATE)) + FIRSTINDEX] + 0) + (\NSMAIL.LOGOFF NSMAILSTATE STREAM) + 'EMPTY) + (T (* ; "Return (MAILBOX . properties)") + (CONS (create NSMAILBOX + NSMAILSTREAM _ STREAM + NSMAILLASTINDEX _ LASTINDEX + NSMAILSTATE _ NSMAILSTATE) + (LIST '%#OFMESSAGES N]) + +(\NSMAIL.CHECK + [LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM RETURNERRORS) + (* ; "Edited 26-Jun-90 18:21 by jds") + +(* ;;; "Performs a mail check for user REGISTEREDNAME at ADDRESS, returning INBASKETSTATE if successful, NIL if not. Updates the MAILSTATE of MAILSERVER as appropriate to reflect current SESSION and STATEFIRSTNEW (first new message)") + + (RESETLST + (PROG ((JUSTCHECKING (NULL STREAM)) + (STATE (fetch (MAILSERVER MAILSTATE) of MAILSERVER)) + SESSION POLLRESULT LASTINDEX FIRSTNEW OLDLAST CONTINUANCE TIMER) + (COND + ((AND JUSTCHECKING (SETQ TIMER (fetch (NSMAILSTATE STATETIMER) of STATE)) + (TIMEREXPIRED? TIMER) + (\NSMAIL.FIX.MAILBOX.LOCATIONS)) (* ; "Some mailboxes moved") + (GO FAILFAST))) + (SETQ SESSION (fetch (NSMAILSTATE STATESESSION) of STATE)) + (SETQ FIRSTNEW (fetch (NSMAILSTATE STATEFIRSTNEW) of STATE)) + (SETQ OLDLAST (fetch (NSMAILSTATE STATEOLDLAST) of STATE)) + RETRY + [COND + ((NULL SESSION) + (if (AND (NOT NSMAIL.LEAVE.ATTACHMENTS) + JUSTCHECKING) + then (* ; + "Just polling, don't need session") + (SETQ POLLRESULT (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET + 'INBASKET + 'MAILPOLL + (CAR CREDENTIALS) + (CDR CREDENTIALS) + (fetch (NSMAILSTATE STATENAME) of STATE) + 'RETURNERRORS)) + (GO GOTRESULT)) + [COND + ((NULL STREAM) (* ; + "Need a real Courier stream for some reason here") + (COND + ((SETQ STREAM (COURIER.OPEN ADDRESS NIL T 'NSMAIL)) + (RESETSAVE NIL (LIST 'CLOSEF STREAM))) + (T (RETURN NIL] + (COND + ((EQ [CAR (SETQ SESSION (COND + ((OR T STREAM) + (* ; + "Would be nice to do this expedited, but this ability was taken out in Services 8.1!") + (COURIER.CALL STREAM 'INBASKET 'LOGON (CAR + CREDENTIALS + ) + (CDR CREDENTIALS) + (fetch (NSMAILSTATE STATENAME) + of STATE) + \NULL.CACHE.VERIFIER T 'RETURNERRORS)) + (T (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET + 'INBASKET + 'LOGON + (CAR CREDENTIALS) + (CDR CREDENTIALS) + (fetch (NSMAILSTATE STATENAME) + of STATE) + \NULL.CACHE.VERIFIER T 'RETURNERRORS] + 'ERROR) + (GO ERROR))) + (replace (NSMAILSTATE STATESESSION) of STATE with (SETQ SESSION + (CAR SESSION] + [SETQ POLLRESULT (COND + ((NULL STREAM) (* ; "Just checking") + (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET 'INBASKET + 'MAILCHECK SESSION 'RETURNERRORS)) + (T (COURIER.CALL STREAM 'INBASKET 'MAILCHECK SESSION 'RETURNERRORS] + GOTRESULT + [COND + ((NULL POLLRESULT) (* ; "Failed somehow") + (RETURN NIL)) + ((EQ (CAR (LISTP POLLRESULT)) + 'ERROR) + (COND + ((EQ (CADR POLLRESULT) + 'SESSION.ERROR) (* ; + "Session timed out, start a new one") + (replace (NSMAILSTATE STATESESSION) of STATE with (SETQ SESSION NIL + )) + (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with (SETQ FIRSTNEW + NIL)) + (replace (NSMAILSTATE STATEOLDLAST) of STATE with (SETQ OLDLAST NIL + )) + (GO RETRY)) + (T (SETQ SESSION POLLRESULT) + (GO ERROR] + (replace (NSMAILSTATE STATELASTERROR) of STATE with NIL) + (if SESSION + then (* ; + "MAILCHECK returned 2 values: state and continuance") + (SETQ CONTINUANCE (CADR POLLRESULT)) + (SETQ POLLRESULT (CAR POLLRESULT))) + (COND + ((EQ (SETQ LASTINDEX (COURIER.FETCH (INBASKET . INBASKET.STATE) + LASTINDEX of POLLRESULT)) + 0) (* ; "Mailbox is empty") + (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with 0)) + ((NOT NSMAIL.LEAVE.ATTACHMENTS) (* ; + "Retrieving all mail, so we don't care about NEW vs OLD") + (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with 1) + (replace (NSMAILSTATE STATEOLDLAST) of STATE with LASTINDEX)) + ((OR (NULL OLDLAST) + (ILESSP OLDLAST LASTINDEX) + (NOT JUSTCHECKING) + (NULL FIRSTNEW)) (* ; + "Need to accurately locate first NEW message") + [replace (NSMAILSTATE STATEFIRSTNEW) of STATE + with (COND + (STREAM (COURIER.CALL STREAM 'INBASKET 'LOCATE SESSION 'NEW + 'NOERROR)) + (T (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET 'INBASKET + 'LOCATE SESSION 'NEW 'RETURNERRORS] + (replace (NSMAILSTATE STATEOLDLAST) of STATE with LASTINDEX))) + [replace (MAILSERVER CONTINUANCE) of MAILSERVER + with (AND (FIXP CONTINUANCE) + (ITIMES 1000 (IQUOTIENT (ITIMES CONTINUANCE 4) + 5] (* ; + "Tell poller to call again soon enough to keep session alive") + (RETURN POLLRESULT) + ERROR + [if [AND [NOT (EQUAL (CDR SESSION) + '(CONNECTION.PROBLEM NoResponse] + (NOT (EQUAL (CDR SESSION) + (fetch (NSMAILSTATE STATELASTERROR) of STATE] + then + + (* ;; "Don't bother mentioning the error if it's just a timeout, since mailwatch will handle our NIL response fine. Also don't repeatedly print the same error message.") + + (replace (NSMAILSTATE STATELASTERROR) of STATE with (CDR SESSION) + ) + (LET [(ERRMSG (CASE (CADR SESSION) + ((REJECT) (* ; "3rd element = (reason ...)") + (CAADDR SESSION)) + ((SERVICE.ERROR ACCESS.ERROR) + (* ; + "the specific reason is just as informative, and more readable than the whole error.") + (CADDR SESSION)) + (T (COND + (NSWIZARDFLG (HELP SESSION))) + (SUBSTRING (CDR SESSION) + 2 -2)))] + (if RETURNERRORS + then (RETURN (CONS 'ERROR ERRMSG)) + elseif (AND (EQ ERRMSG 'NoSuchRecipients) + (\NSMAIL.FIX.MAILBOX.LOCATIONS)) + then + + (* ;; "Rather odd message. We get this when the server no longer holds this inbox. At this point we have fixed mail servers in NS mode, but there's no good way for us to report the news, so go ahead and return NIL, but set %"continuance%" so that poll will happen again immediately") + + (replace (MAILSERVER CONTINUANCE) of MAILSERVER + with 0) + else (LET ((*PRINT-CASE* :UPCASE)) + (* ; "Lousy atomic error names...") + (CL:FORMAT PROMPTWINDOW "~%%From mail server ~A: ~A" + (fetch (MAILSERVER MAILSERVERNAME) + of MAILSERVER) + (CASE ERRMSG + (NoSuchService "Mail service not running") + (T ERRMSG))] + (RETURN NIL) + FAILFAST))]) + +(\NSMAIL.FIX.MAILBOX.LOCATIONS + [LAMBDA NIL (* ; "Edited 26-Jun-90 18:21 by jds") + + (* ;; "Called when we think user's mailboxes may have moved. If they have, sets new info into NS mode and returns T.") + + (LET + ((OLDDATA (\LAFITE.GET.USER.DATA 'NS)) + OLDSERVERS NEWSERVERS FULLNAME) + (if (AND OLDDATA (SETQ OLDSERVERS (fetch (LAFITEMODEDATA MAILSERVERS) of OLDDATA))) + then (* ; + "Actually, if we got here at all, OLDSERVERS surely is non-NIL. The check is for sanity.") + [SETQ NEWSERVERS (NS.FINDMAILBOXES (SETQ FULLNAME (fetch (LAFITEMODEDATA + UNPACKEDUSERNAME) + of OLDDATA] + [LET [(STATE (fetch (MAILSERVER MAILSTATE) of (CAR OLDSERVERS] + (* ; + "Reset the timer that tells us when next to check on location.") + (replace (NSMAILSTATE STATETIMER) of STATE + with (SETUPTIMER (if NEWSERVERS + then *NSMAIL-CACHE-TIMEOUT* + else (* ; + "Couldn't find servers? Try again soon") + 60000) + (fetch (NSMAILSTATE STATETIMER) of STATE] + (if [AND NEWSERVERS + (OR (NOT (EQ (LENGTH NEWSERVERS) + (LENGTH OLDSERVERS))) + (for SERVER in OLDSERVERS as PAIR in NEWSERVERS + thereis (OR (NOT (EQUAL.CH.NAMES (CAR PAIR) + (fetch MAILSERVERNAME of SERVER))) + (NOT (for I from 0 to 4 + bind (SERVERADDR _ (fetch MAILPORT + of SERVER)) + (PAIRADDR _ (CADR PAIR)) + always (EQ (\GETBASE SERVERADDR I) + (\GETBASE PAIRADDR I] + then + + (* ;; "Yes, mailbox info is different. Fix it up. Note that we do nothing if no mail servers were found. This is to avoid screwing up when we failed to talk to a clearinghouse (since otherwise we would find ourselves with no servers, hence nobody to wake up periodically and find out where the servers have moved to). If only CH.RETRIEVE.ITEM could give us an error return in that case...") + + (replace (LAFITEMODEDATA MAILSERVERS) of OLDDATA + with (\NSMAIL.MAKE.MAILSERVERS NEWSERVERS FULLNAME (fetch + (LAFITEMODEDATA + CREDENTIALS) + of OLDDATA))) + T]) + +(NS.NEXTMESSAGE + [LAMBDA (MAILBOX) (* ; "Edited 26-Jun-90 18:18 by jds") + (PROG ((ENVELOPES (fetch (NSMAILBOX NSMAILENVTAIL) of MAILBOX))) + (SELECTQ ENVELOPES + (NIL (* ; "First time, read all envelopes") + (COND + ([OR (fetch (NSMAILBOX NSMAILENVELOPES) of MAILBOX) + (NULL (SETQ ENVELOPES (\NSMAIL.READ.ENVELOPES MAILBOX] + (RETURN))) + (replace (NSMAILBOX NSMAILENVELOPES) of MAILBOX with ENVELOPES) + (replace (NSMAILBOX NSMAILENVTAIL) of MAILBOX with ENVELOPES)) + (T (* ; "Finished") + (RETURN)) + NIL) + (RETURN (CAR ENVELOPES]) + +(\NSMAIL.READ.ENVELOPES + [LAMBDA (MAILBOX) (* ; "Edited 26-Jun-90 18:19 by jds") + (LET [(ENVELOPES (INBASKET.CALL MAILBOX 'LIST (fetch (NSMAILBOX NSMAILSESSION) + of MAILBOX) + (COURIER.CREATE (INBASKET . RANGE) + FIRST _ (fetch (NSMAILBOX NSMAILFIRSTINDEX) of MAILBOX) + LAST _ (fetch (NSMAILBOX NSMAILLASTINDEX) of MAILBOX)) + (COURIER.CREATE (INBASKET . SELECTIONS) + TRANSPORT.ENVELOPE _ T INBASKET.ENVELOPE _ T MAIL.ATTRIBUTES _ + (LIST (\NSMAIL.ATTRIBUTE.TYPE BodyType))) + '(INBASKET . MESSAGE.DESCRIPTION] + (for E in ENVELOPES collect (CONS (COURIER.FETCH (INBASKET + . MESSAGE.DESCRIPTION) + MESSAGE.INDEX of E) + (APPEND (COURIER.FETCH (INBASKET + . MESSAGE.DESCRIPTION) + CONTENT.ATTRIBUTES of E) + (COURIER.FETCH (INBASKET + . MESSAGE.DESCRIPTION) + TRANSPORT.ENVELOPE of E) + (COURIER.FETCH (INBASKET + . MESSAGE.DESCRIPTION) + INBASKET.ENVELOPE of E]) + +(INBASKET.CALL + [CL:LAMBDA (MAILBOX PROCEDURE &REST ARGS) (* ; "Edited 26-Jun-90 18:19 by jds") + (PROG ((STREAM (fetch (NSMAILBOX NSMAILSTREAM) of MAILBOX)) + RESULT) + LP (if (AND (EQ [CAR (LISTP (SETQ RESULT (CL:APPLY (FUNCTION COURIER.CALL) + STREAM + 'INBASKET PROCEDURE ARGS] + 'ERROR) + (CASE (CAR (LAST ARGS)) + (NOERROR NIL) + (RETURNERRORS (* ; + "We'll only handle stream lost--caller gets the rest") + (EQ (CADR RESULT) + 'STREAM.LOST)) + (T (* ; + "Probably an error was already signaled") + T))) + then (SETQ STREAM (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX 'INBASKET PROCEDURE + )) + (GO LP) + else (RETURN RESULT]) + +(NS.RETRIEVEMESSAGE + [LAMBDA (MAILBOX MSGOUTFILE) (* ; "Edited 26-Jun-90 18:19 by jds") + (LET ((*RETRIEVAL-ERROR* NIL) + (ENVELOPE (pop (fetch (NSMAILBOX NSMAILENVTAIL) of MAILBOX))) + TYPE) + (if (OR NSMAIL.LEAVE.ATTACHMENTS (MEMB (SETQ TYPE (CADR (ASSOC 'BodyType ENVELOPE))) + \NSMAIL.GOOD.BODYTYPES)) + then (* ; + "Retrieve ordinary text message, or retrieve the text part and leave attachment behind") + (\NSMAIL.RETRIEVE MAILBOX ENVELOPE [FUNCTION (LAMBDA (MSGSTREAM) + + (* ;; + "MSGSTREAM is a bulk data stream containing content of msg, as a 'serialized file'") + + (SETFILEINFO + MSGSTREAM + 'ENDOFSTREAMOP + (FUNCTION + \NSMAIL.EOF.ON.RETRIEVE)) + ( + \NSMAIL.CHECK.SERIALIZED.VERSION + MSGSTREAM) + (\NSMAIL.READ.SERIALIZED.TREE + MSGSTREAM MSGOUTFILE + (CDR ENVELOPE] + (GETFILEPTR MSGOUTFILE) + MSGOUTFILE) + (COND + (*RETRIEVAL-ERROR* (printout MSGOUTFILE T *RETRIEVAL-ERROR* T))) + else (* ; + "Not text or mail note, so retrieve the whole thing raw and make an %"attachment%"") + (SETQ TYPE (\TYPE.FROM.FILETYPE TYPE)) + (LET ((BUFFER (OPENSTREAM '{NODIRCORE} 'BOTH)) + BODY ATTACHPOINT ATTRIBUTE.END) + [SETQ BODY (\NSMAIL.RETRIEVE + MAILBOX ENVELOPE (FUNCTION (LAMBDA (BULKSTREAM) + (* ; "Just eat it raw") + (LET + [(BODY (OPENSTREAM + '{NODIRCORE} + 'BOTH NIL + '((ENDOFSTREAMOP + \NSMAIL.EOF.ON.RETRIEVE + ] + (COPYBYTES BULKSTREAM BODY) + BODY] + (SETFILEPTR BODY 0) + (\NSMAIL.CHECK.SERIALIZED.VERSION BODY) + (\NSMAIL.READ.SERIALIZED.TREE BODY BUFFER (CDR ENVELOPE) + T) + (SETQ ATTRIBUTE.END (GETFILEPTR BODY)) + (SETQ BUFFER (OPENTEXTSTREAM BUFFER NIL NIL NIL (LIST 'FONT LAFITEDISPLAYFONT)) + ) + (TEDIT.INSERT.OBJECT (\MAILOBJ.CREATE BODY TYPE ATTRIBUTE.END) + BUFFER + (if (SETQ ATTACHPOINT (TEDIT.FIND BUFFER " + +Attachment: " 1)) + then (* ; + "Insert object at end of this line") + (+ ATTACHPOINT 14) + else (* ; "Shouldn't happen") + (+ (TEDIT.FIND BUFFER " + +" 1) + 2))) + (COPYBYTES (OPENSTREAM (COERCETEXTOBJ BUFFER 'FILE) + 'INPUT) + MSGOUTFILE) (* ; + "Would like this to be (COERCETEXTOBJ BUFFER (QUOTE FILE) MSGOUTFILE) but Tedit has a bug") + )) + (COND + ((NEQ (CADR ENVELOPE) + 'NO) (* ; + "Read okay, tell close mailbox to delete it. NO set when there is an attachment to leave behind") + (RPLACA (CDR ENVELOPE) + 'DELETE]) + +(\NSMAIL.RETRIEVE + [LAMBDA (MAILBOX ENVELOPE RETRIEVEFN START MSGOUTFILE) (* ; "Edited 26-Jun-90 18:19 by jds") + + (* ;; "Perform an Inbasket.Retrieve on the specified message, using RETRIEVEFN to read the bulk data. If START is true, then the file pointer on MSGOUTFILE is returned to START if we have to retry") + + (bind RESULT while (EQ [CAR (LISTP (SETQ RESULT (COURIER.CALL (fetch (NSMAILBOX + NSMAILSTREAM) + of MAILBOX) + 'INBASKET + 'RETRIEVE + (fetch (NSMAILBOX + NSMAILSESSION) + of MAILBOX) + (CAR ENVELOPE) + \NSMAIL.CTSTANDARD.MESSAGE + RETRIEVEFN 'RETURNERRORS] + 'ERROR) do (* ; "Maybe lost the stream?") + (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX + 'INBASKET + 'RETRIEVE) + (AND START (SETFILEPTR MSGOUTFILE START)) + finally (RETURN RESULT]) + +(\NSMAIL.EOF.ON.RETRIEVE +(LAMBDA (STREAM) (DECLARE (USEDFREE *RETRIEVAL-ERROR*)) (* ; "Edited 9-Sep-88 12:29 by bvm") (SETQ *RETRIEVAL-ERROR* "**Warning: errors in message format**") (COND (LAFITEDEBUGFLG (HELP "EOF during retrieve"))) (LET (POS) (COND ((SETQ POS (STKPOS (FUNCTION \NSMAIL.READ.SERIALIZED.TREE))) (RETFROM POS NIL T)) (T 0)))) +) + +(\NSMAIL.READ.SERIALIZED.TREE +(LAMBDA (MSGSTREAM MSGOUTFILE ENVELOPE ATTACHMENT) (* ; "Edited 17-Jan-89 17:30 by bvm") (* ;;; "Read a message, which is in the format of a NS Filing Serialized File. This is the recursive part, SerializedTree. Format is --- Sequence of Attribute; Content; children = Sequence of SerializedTree") (PROG (TYPE VALUE HEADERFIELDS LENGTH NOTEBODY HEADERS SENDER TYPEINFO DISCARDED COERCED FORMATSTREAM BODYSTREAM) (for N from (\WIN MSGSTREAM) to 1 by -1 do (SETQ TYPE (COURIER.READ MSGSTREAM NIL (QUOTE LONGCARDINAL))) (COND ((NOT (find old TYPEINFO in \NSMAIL.ATTRIBUTES suchthat (EQ (CADR TYPEINFO) TYPE))) (* ; "We don't understand this attribute") (if (AND NSMAILDEBUGFLG (NOT ATTACHMENT)) then (push DISCARDED TYPE)) (COURIER.SKIP.SEQUENCE MSGSTREAM NIL (QUOTE UNSPECIFIED))) ((EQ (SETQ TYPE (CAR TYPEINFO)) (QUOTE Note)) (* ;; "This is a star mail note. Treat as body of message. If it isn't the last attribute, save it for the end") (COND ((NEQ N 1) (COND (NOTEBODY (TERPRI NOTEBODY)) (T (SETQ NOTEBODY (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM NOTEBODY)) (T (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED) (* ; "Print accumulated header fields") (TERPRI MSGOUTFILE) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM MSGOUTFILE) (RETURN)))) ((OR (EQ TYPE (QUOTE LispFormatting)) (EQ TYPE (QUOTE OldLispFormatting))) (* ; "Note that this MUST be the last attribute") (COND ((EQ N 1) (* ; "Save the formatting so we can munge it") (SETQ FORMATSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM FORMATSTREAM) (RETURN)) (T (PRINTOUT PROMPTWINDOW T "Bad formatted message") (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM (OPENSTREAM (QUOTE {NULL}) (QUOTE OUTPUT)))))) (T (SETQ VALUE (PROGN (\WIN MSGSTREAM) (COURIER.READ MSGSTREAM (QUOTE MAILTRANSPORT) (CADDR TYPEINFO)))) (COND ((SELECTQ TYPE ((BodyType BodySize) NIL) (Sender (SETQ SENDER VALUE)) (From (COND ((AND (NULL SENDER) (NULL (CDR VALUE))) (SETQ SENDER (CAR VALUE)))) T) T) (push HEADERFIELDS (CONS TYPE VALUE)))))) finally (* ; "Note was not the final attribute. Print headers accumulated, then the Note last") (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED)) (COND (FORMATSTREAM (* ; "This is a TEdit formatted message") (LET ((START (GETFILEPTR MSGOUTFILE))) (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NIL ATTACHMENT DISCARDED) (TERPRI MSGOUTFILE) (* ; "We have now printed the header and a blank line. This is all the added text we have, not counted in the formatting") (SETQ START (- (GETFILEPTR MSGOUTFILE) START)) (if NOTEBODY then (COPYBYTES NOTEBODY MSGOUTFILE 0 -1) (if (NULL ATTACHMENT) then (* ; "There better be nothing more here. In case of attachment, caller is handling it separately") (\NSMAIL.DISCARD.SERIALIZED.CONTENT MSGSTREAM)) else (* ; "One or the other of these clauses (never both) produced the body of the message, to which the formatting applies.") (\NSMAIL.READ.SERIALIZED.CONTENT MSGSTREAM MSGOUTFILE)) (LA.ADJUST.FORMATTING FORMATSTREAM MSGOUTFILE START) (if (NULL ATTACHMENT) then (* ; "Have to get past the children. This better be null") (RPTQ (\WIN MSGSTREAM) (to (\WIN MSGSTREAM) do (* ; "Read and discard an attribute...") (COURIER.READ MSGSTREAM NIL (QUOTE LONGCARDINAL)) (COURIER.SKIP.SEQUENCE MSGSTREAM NIL (QUOTE UNSPECIFIED))))))) ((NULL ATTACHMENT) (* ; "No formatting, possibly read body now") (TERPRI MSGOUTFILE) (* ; "Set off header") (COND ((EQ (CAR ENVELOPE) (QUOTE NO)) (* ; "Can't read this attachment, leave in mailbox") (printout MSGOUTFILE T T "*** Attachment retained in mailbox for retrieval by other means ***" T) (COURIER.ABORT.BULKDATA))) (\NSMAIL.READ.SERIALIZED.CONTENT MSGSTREAM MSGOUTFILE) (RPTQ (\WIN MSGSTREAM) (* ; "Read children") (\NSMAIL.READ.SERIALIZED.TREE MSGSTREAM MSGOUTFILE)))))) +) + +(\NSMAIL.CHECK.SERIALIZED.VERSION +(LAMBDA (STREAM) (* ; "Edited 5-May-89 14:47 by bvm") (LET ((V (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL)))) (SELECTC V (\SERIALIZED.FILE.VERSIONS T) (HELP (CL:FORMAT NIL "Lafite does not understand serialized file version ~D. +RETURN to attempt retrieval anyway." V)))))) + +(\NSMAIL.READ.SERIALIZED.CONTENT +(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 17-Jan-89 17:14 by bvm") (* ;;; "Interprets INSTREAM as SerializedTree.Content, i.e., as a Bulkdata.StreamOfUnspecified followed by the lastByteIsSignificant flag. Copies the raw data therein to OUTSTREAM") (bind LASTSEGMENT? BYTE BYTECOUNT do (SETQ LASTSEGMENT? (NEQ (\WIN INSTREAM) 0)) (COND ((NEQ (SETQ BYTECOUNT (UNFOLD (\WIN INSTREAM) BYTESPERWORD)) 0) (RPTQ (SUB1 BYTECOUNT) (\BOUT OUTSTREAM (\BIN INSTREAM))) (SETQ BYTE (\BIN INSTREAM)) (* ; "Final byte of this segment. Don't copy until we know whether it's significant") (COND ((OR (NULL LASTSEGMENT?) (NEQ (\WIN INSTREAM) 0)) (* ; "Not last segment, or the word after says the final byte was significant") (\BOUT OUTSTREAM BYTE)))) (LASTSEGMENT? (* ; "Null body. Throw out the lastByteIsSignificant flag") (\WIN INSTREAM))) repeatuntil LASTSEGMENT?)) +) + +(\NSMAIL.DISCARD.SERIALIZED.CONTENT +(LAMBDA (INSTREAM) (* ; "Edited 17-Jan-89 17:17 by bvm") (* ;;; "Interprets INSTREAM as SerializedTree.Content, i.e., as a Bulkdata.StreamOfUnspecified followed by the lastByteIsSignificant flag and discards it all") (do (if (NEQ (PROG1 (\WIN INSTREAM) (RPTQ (UNFOLD (\WIN INSTREAM) BYTESPERWORD) (\BIN INSTREAM))) 0) then (* ; "Finished. Read the lastByteIsSignificant flag") (\WIN INSTREAM) (RETURN)))) +) + +(\NSMAIL.READ.STRING.AS.STREAM +(LAMBDA (INSTREAM OUTSTREAM) (* bvm%: "30-Jul-84 16:13") (* ;; "Considers INSTREAM to be positioned at a sequence of unspecified, and reads it as if its datatype were string, and copies said bytes to OUTSTREAM") (PROG (LENGTH) (\WIN INSTREAM) (* ; "Skip sequence count") (COPYBYTES INSTREAM OUTSTREAM (SETQ LENGTH (\WIN INSTREAM))) (COND ((ODDP LENGTH) (\BIN INSTREAM))))) +) + +(\NSMAIL.PRINT.HEADERFIELDS +(LAMBDA (MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED) (* ; "Edited 4-Aug-89 18:34 by bvm") (* ;; "Compose message header from HEADERFIELDS and ENVELOPE, printing to MSGOUTFILE. SENDER is the %"Sender%" field of the message, if we encountered one, or sole element of the %"From%" field. NOTEBODY if non-NIL is a stream containing the text of a Note attribute. if ATTACHMENT is true, we add a line %"Attachment:%" to the message where caller will later insert the attachment object. DISCARDED is list of fields we didn't recognize.") (LET (TYPE BADNAMES REASON TMP VALUE ID) (SETQ HEADERFIELDS (REVERSE HEADERFIELDS)) (COND (ENVELOPE (if (SETQ VALUE (ASSOC (QUOTE TransportProblem) ENVELOPE)) then (* ; "Return of undeliverable mail") (SETQ HEADERFIELDS (DREMOVE VALUE HEADERFIELDS)) (SETQ VALUE (CADR VALUE)) (* ; "VALUE is (invalidNames envelope)") (PRINTOUT MSGOUTFILE "Date: " (GDATE (COURIER.FETCH (MAILTRANSPORT . POSTMARK) TIME of (CADR (ASSOC (QUOTE Postmark) ENVELOPE))) (DATEFORMAT TIME.ZONE)) T "From: " (NSNAME.TO.STRING (CADR (ASSOC (QUOTE Originator) ENVELOPE)) T) T "Subject: Undeliverable mail" T T) (SETQ BADNAMES (COURIER.FETCH (MAILTRANSPORT . PROBLEM) UNDELIVERABLES of VALUE)) (SETQ REASON (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of (CAR BADNAMES))) (PRINTOUT MSGOUTFILE "This message could not be delivered to ") (if (NULL (CDR BADNAMES)) then (PRINTOUT MSGOUTFILE (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of (CAR BADNAMES)) T) " because: " REASON T) else (PRINTOUT MSGOUTFILE "the following recipients") (if (for PAIR in (CDR BADNAMES) always (EQ (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of PAIR) REASON)) then (* ; "Same reason for all") (PRINTOUT MSGOUTFILE " because: " REASON) (for PAIR in BADNAMES bind (SEPR _ ": ") do (PRINTOUT MSGOUTFILE SEPR (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of PAIR) T)) (SETQ SEPR ", ") finally (TERPRI MSGOUTFILE)) else (PRINTOUT MSGOUTFILE ":" T) (for PAIR in BADNAMES do (PRINTOUT MSGOUTFILE (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of PAIR) T) " because: " (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of PAIR) T)))) (PRINTOUT MSGOUTFILE T "- - - - - - - - -" T) (for PAIR in (CADR VALUE) do (* ; "Replace envelope of remaining message with returned envelope") (if (SETQ TMP (ASSOC (CAR PAIR) ENVELOPE)) then (RPLACD TMP (CDR PAIR)) else (push HEADERFIELDS PAIR)))) (* ;; "Prescan HEADERFIELDS to see if there is any additional info we should supply that wasn't in the message") (for PAIR in ENVELOPE do (SETQ VALUE (CADR PAIR)) (SELECTQ (SETQ TYPE (CAR PAIR)) ((PreviousRecipients) (push HEADERFIELDS (CONS TYPE VALUE))) (Postmark (COND ((NULL (ASSOC (QUOTE Date) HEADERFIELDS)) (push HEADERFIELDS (CONS (QUOTE Date) (COURIER.FETCH (MAILTRANSPORT . POSTMARK) TIME of VALUE)))))) (Originator (COND ((NOT (AND SENDER (EQUAL.CH.NAMES SENDER VALUE))) (* ; "The agent that sent the message is not the same as what the header gives as Sender/From.") (push HEADERFIELDS (CONS (if (ASSOC (QUOTE Sender) HEADERFIELDS) then (* ; "There's already a Sender field, so leave it as Originator") (QUOTE Originator) else (QUOTE Sender)) VALUE))))) (BodyType (COND ((AND (NOT ATTACHMENT) (NOT (MEMB VALUE \NSMAIL.GOOD.BODYTYPES))) (NCONC1 HEADERFIELDS (CONS (QUOTE Attachment) VALUE))))) (Message-ID (SETQ ID VALUE)) NIL)))) (for PAIR in (SORT HEADERFIELDS (FUNCTION (LAMBDA (X Y) (* ;; "X sorts before Y if X is in the well-known order and either Y appears after it or doesn't appear at all.") (AND (SETQ X (FMEMB (CAR X) NSMAIL.HEADER.ORDER)) (OR (FMEMB (CAR Y) X) (NULL (FMEMB (CAR Y) NSMAIL.HEADER.ORDER))))))) when (SETQ VALUE (CDR PAIR)) do (printout MSGOUTFILE (SETQ TYPE (CAR PAIR)) ": ") (CASE TYPE (Date (printout MSGOUTFILE (GDATE VALUE (DATEFORMAT NO.SECONDS TIME.ZONE SPACES)))) ((From To cc Reply-to) (\NSMAIL.PRINT.NAMES VALUE MSGOUTFILE (SELECTQ TYPE (From (* ; "Always fully qualified. Also check against sender.") (if (AND SENDER (NOT (for NAME in VALUE always (OR (EQ NAME SENDER) (AND (STRING-EQUAL (fetch NSDOMAIN of NAME) (fetch NSDOMAIN of SENDER)) (STRING-EQUAL (fetch NSORGANIZATION of NAME) (fetch NSORGANIZATION of SENDER))))))) then (* ; "Ugh, From and Sender are different domains. To reduce confusion, force everything to be fully qualified") (SETQ SENDER NIL)) NIL) (Reply-to (* ; "always full-qualified") NIL) SENDER))) ((Sender Originator) (printout MSGOUTFILE (NSNAME.TO.STRING VALUE T))) (Attachment (printout MSGOUTFILE "%"Type " |.I1| VALUE " ID " |.P2| ID "%"") (RPLACA ENVELOPE (QUOTE NO))) (T (while (AND (> (NCHARS VALUE) 0) (EQ (NTHCHARCODE VALUE -1) (CHARCODE CR))) do (* ; "Trailing cr's, e.g., in the Subject line, will cause the header not to parse") (SETQ VALUE (SUBSTRING VALUE 1 -2))) (if (STRPOS " +" VALUE) then (* ; "Internal CR? I suppose we could print it and make sure there is whitespace at the start of the next line, but why bother?") (SETQ VALUE (CL:SUBSTITUTE #\\ #\Newline VALUE))) (PRIN1 VALUE MSGOUTFILE))) (TERPRI MSGOUTFILE)) (if DISCARDED then (printout MSGOUTFILE "Discarded-Fields: ") (LA.PRINT.COMMA.LIST (REVERSE DISCARDED) MSGOUTFILE) (TERPRI MSGOUTFILE)) (COND (ATTACHMENT (* ; "Reserve a line where the attachment object will be placed.") (PRINTOUT MSGOUTFILE T "Attachment: " T))) (COND (NOTEBODY (TERPRI MSGOUTFILE) (COPYBYTES NOTEBODY MSGOUTFILE 0 -1) (TERPRI MSGOUTFILE))))) +) + +(\NSMAIL.PRINT.NAMES +(LAMBDA (NSNAMES OUTSTREAM DEFAULTNAME) (* ; "Edited 5-Jan-90 18:30 by bvm") (for NAME in NSNAMES bind (FIRSTTIME _ T) ORGDIFFERS do (COND (FIRSTTIME (SETQ FIRSTTIME NIL)) (T (PRIN3 ", " OUTSTREAM))) (PRIN3 (fetch NSOBJECT of NAME) OUTSTREAM) (LET ((ORG (fetch NSORGANIZATION of NAME)) (DOM (fetch NSDOMAIN of NAME))) (if (OR (SETQ ORGDIFFERS (NOT (AND DEFAULTNAME (OR (STRING-EQUAL ORG (fetch NSORGANIZATION of DEFAULTNAME)) (EQ (NCHARS ORG) 0))))) (NOT (OR (STRING-EQUAL DOM (fetch NSDOMAIN of DEFAULTNAME)) (EQ (NCHARS DOM) 0)))) then (* ;; "Have to print the domain. The null string tests are because there exists buggy software that doesn't fill in the domain and org--we want them to default correctly eventually.") (PRIN3 ":" OUTSTREAM) (PRIN3 DOM OUTSTREAM) (if ORGDIFFERS then (* ; "Have to print the org, too") (PRIN3 ":" OUTSTREAM) (PRIN3 ORG OUTSTREAM)))))) +) +) + + + +(* ; "Error handling") + +(DEFINEQ + +(\NSMAIL.COURIER.OPEN +(LAMBDA (ADDRESS) (* ; "Edited 9-Sep-88 12:06 by bvm") (COURIER.OPEN ADDRESS NIL T (QUOTE NSMAIL) NIL (CONSTANT (LIST (QUOTE ERRORHANDLER) (FUNCTION \NSMAIL.ERRORHANDLER))))) +) + +(\NSMAIL.ERRORHANDLER +(LAMBDA (STREAM ERRCODE) (* ; "Edited 9-Sep-88 12:35 by bvm") (* ;; "Called when SPP error occurs on NS mail courier connection STREAM. Fakes an error return from the courier.call.") (LET (POS) (if (AND (EQ ERRCODE (QUOTE STREAM.LOST)) (SETQ POS (STKPOS (FUNCTION COURIER.CALL)))) then (BLOCK 500) (RETFROM POS (QUOTE (ERROR STREAM.LOST)) T) else (\SPP.DEFAULT.ERRORHANDLER STREAM ERRCODE)))) +) + +(\NSMAIL.SIGNAL.ERROR + [LAMBDA (ERROR MAILBOX PROGRAM PROCEDURE) (* ; "Edited 26-Jun-90 18:19 by jds") + + (* ;; "Called when we get an error on an NS mail courier call. If stream lost, then tries to reestablish the connection, returning a new stream on success.") + + (if (EQ (CADR ERROR) + 'STREAM.LOST) + then (PRINTOUT PROMPTWINDOW T "Lost NS mail connection, trying to reestablish...") + (LET [(STREAM (\NSMAIL.COURIER.OPEN (create NSADDRESS + using (SPP.DESTADDRESS + (fetch (NSMAILBOX + NSMAILSTREAM) + of MAILBOX)) + NSSOCKET _ 0] + (if STREAM + then (PRINTOUT PROMPTWINDOW "done.") + (replace (NSMAILBOX NSMAILSTREAM) of MAILBOX with STREAM) + else (PRINTOUT PROMPTWINDOW "failed.") + (ERROR "NS mail connection lost, can't reestablish"))) + else (COURIER.SIGNAL.ERROR PROGRAM PROCEDURE ERROR]) +) + + + +(* ; "Close/flush protocol") + +(DEFINEQ + +(NS.CLOSEMAILBOX + [LAMBDA (MAILBOX FLUSH?) (* ; "Edited 26-Jun-90 18:19 by jds") + [COND + (FLUSH? (* ; + "Mark everything either deleted or seen") + (for E in (fetch (NSMAILBOX NSMAILENVELOPES) of MAILBOX) + bind START STATUS do [COND + ((NEQ (CADR E) + STATUS) + (COND + (START (\NSMAIL.CHANGE.STATUS + MAILBOX START (SUB1 (CAR E)) + STATUS))) + (SETQ START (CAR E)) + (SETQ STATUS (CADR E] + finally (COND + (START (\NSMAIL.CHANGE.STATUS MAILBOX START (fetch + (NSMAILBOX + NSMAILLASTINDEX + ) + of MAILBOX) + STATUS] + (\NSMAIL.LOGOFF (fetch (NSMAILBOX NSMAILSTATE) of MAILBOX) + (fetch (NSMAILBOX NSMAILSTREAM) of MAILBOX]) + +(\NSMAIL.LOGOFF + [LAMBDA (STATE STREAM) (* ; "Edited 26-Jun-90 18:22 by jds") + + (* ;; "Executes the Inbasket.Logoff procedure and clears appropriate state. Returns true if LOGOFF call succeeded.") + + (LET [(RESULT (COURIER.CALL STREAM 'INBASKET 'LOGOFF (fetch (NSMAILSTATE STATESESSION) + of STATE) + 'RETURNERRORS] + (PROG1 (AND (LISTP RESULT) + (NEQ (CAR RESULT) + 'ERROR)) + (replace (NSMAILSTATE STATESESSION) of STATE with NIL) + + (* ;; "Once session is closed, can't say anything about first new message if there are any messages left, because someone in the meantime could delete them from another session") + + (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with NIL) + (replace (NSMAILSTATE STATEOLDLAST) of STATE with NIL) + (CLOSEF STREAM))]) + +(\NSMAIL.CHANGE.STATUS + [LAMBDA (MAILBOX START END STATUS) (* ; "Edited 26-Jun-90 18:19 by jds") + +(* ;;; "Change status of messages START thru END to be STATUS, which is either DELETE or KEEP. Returns number of messages kept") + + (PROG ((SESSION (fetch (NSMAILBOX NSMAILSESSION) of MAILBOX)) + (STREAM (fetch (NSMAILBOX NSMAILSTREAM) of MAILBOX)) + (RANGE (COURIER.CREATE (INBASKET . RANGE) + FIRST _ START LAST _ END))) + (RETURN (COND + ((EQ STATUS 'DELETE) + (COURIER.CALL STREAM 'INBASKET 'DELETE SESSION RANGE) + 0) + (T (COURIER.CALL STREAM 'INBASKET 'CHANGE.STATUS SESSION RANGE 'KNOWN) + (ADD1 (IDIFFERENCE END START]) +) + +(RPAQ? NSMAILDEBUGFLG ) + +(RPAQ? NSMAIL.LEAVE.ATTACHMENTS ) + +(RPAQ? NSMAIL.HEADER.ORDER '(Date Sender From Subject In-Reply-to To cc Message-ID Reply-to)) + +(ADDTOVAR \NSMAIL.GOOD.BODYTYPES 2 4) + + + +(* ; "Handling attachments as a special kind of image object") + +(DEFINEQ + +(\MAILOBJ.CREATE +(LAMBDA (DATA TYPE ATTR.LENGTH NAME MORE.INFO START) (* ; "Edited 14-Feb-90 16:59 by bvm") (* ;; "Create a mail object encapsulating data (a core file in serialized file format). TYPE is the type of the serialized data.") (OR START (SETQ START 0)) (LET* ((TITLE (SELECTQ TYPE (REFERENCE (* ; "Reference to a file.") (if (NOT MORE.INFO) then (* ; "Try parsing the reference info--returns (REFERENCE info)") (LET* ((INFO (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA (LIST MAILOBJ.REFERENCE.FIELD) START))) (TYPE (\TYPE.FROM.FILETYPE (CADR (ASSOC (QUOTE TYPE) INFO))))) (SETQ NAME (\MAILOBJ.NS.TO.LISP.NAME (CADR (ASSOC (QUOTE HOST) INFO)) (CADR (ASSOC (QUOTE DIRECTORY) INFO)) (CADR (ASSOC (QUOTE NAME) INFO)) (AND (NEQ (CADR (ASSOC (QUOTE FLAGS) INFO)) \MAILOBJ.REFERENCE.LAST.FILED) (CADR (ASSOC (QUOTE VERSION) INFO))) (EQ TYPE (QUOTE DIRECTORY)))) (SETQ MORE.INFO (BQUOTE (FILE.ID (\, (CADR (ASSOC (QUOTE FILE.ID) INFO))) TYPE (\, TYPE)))))) (CL:FORMAT NIL "Reference to ~A ~A" (\MAILOBJ.TYPE.NAME (LISTGET MORE.INFO (QUOTE TYPE))) NAME)) (if NAME then (CONCAT NAME " (" (\MAILOBJ.TYPE.NAME TYPE T) ")") else (\MAILOBJ.TYPE.NAME TYPE)))) (TITLELEN (NCHARS TITLE)) (FONT (AND (> TITLELEN 20) (LET* ((FONT DEFAULTICONFONT) (SIZE (FONTPROP FONT (QUOTE SIZE)))) (* ; "Use a smaller font if available") (if (> TITLELEN 30) then (* ; "This is really getting out of hand...") (SETQ TITLE (CONCAT (SUBSTRING TITLE 1 25) "..."))) (AND (> SIZE 8) (CAR (NLSETQ (FONTCOPY FONT (QUOTE SIZE) (- SIZE 2)))))))) (IMAGE (WINDOWPROP (TITLEDICONW NIL TITLE FONT (QUOTE (0 . 0)) T NIL (QUOTE FILE)) (QUOTE ICONIMAGE)))) (* ; "Crude way of getting a bitmap with some text printed on it nicely") (IMAGEOBJCREATE (create MAILOBJ MAILOBJ.IMAGE _ IMAGE MAILOBJ.BOX _ (create IMAGEBOX XSIZE _ (BITMAPWIDTH IMAGE) YSIZE _ (BITMAPHEIGHT IMAGE) YDESC _ (LRSH (BITMAPHEIGHT IMAGE) 1) XKERN _ 0) MAILOBJ.TYPE _ TYPE MAILOBJ.DATA _ DATA MAILOBJ.ATTR.LENGTH _ ATTR.LENGTH MAILOBJ.START _ START MAILOBJ.NAME _ NAME MAILOBJ.INFO _ MORE.INFO MAILOBJ.EXPANDABLE _ (PROGN (* ; "True if object has children") (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA (CONSTANT (LIST (ASSOC (QUOTE IS.DIRECTORY) \NSFILING.ATTRIBUTES))) START)))) \MAILOBJ.IMAGEFNS))) +) + +(\MAILOBJ.TYPE.NAME +(LAMBDA (TYPE SHORT) (* ; "Edited 29-Sep-87 14:21 by bvm:") (* ;; "Translate filing TYPE into a descriptive string, e.g., %"Interpress Document%". If SHORT is true, leave out %"Document%". If TYPE is numeric, it is rendered as %"Type nnn Document%".") (if (EQ TYPE (QUOTE DIRECTORY)) then (* ; "Viewpoint calls these %"folders%"") "Viewpoint Folder" else (CL:FORMAT NIL "~:[~:(~A~)~;Type ~D~]~@[ Document~]" (FIXP TYPE) TYPE (NOT SHORT)))) +) + +(\MAILOBJ.NS.TO.LISP.NAME +(LAMBDA (HOST DIRECTORY NAME VERSION DIRECTORYFLG) (* ; "Edited 29-Sep-87 17:54 by bvm:") (* ;; "Turn these pieces parsed out of a reference icon into a Lisp-style file name. Mainly this means turning the slashes into angles. This code is stolen from \NSFILING.FULLNAME, which is what we would use if it didn't require a filing session arg.") (LET ((PATHNAME (if DIRECTORYFLG then (CONCAT DIRECTORY "/" NAME (if (AND VERSION (NEQ VERSION 1)) then (CONCAT "!" VERSION) else "")) else DIRECTORY)) FILENAME DIRLST FULLNAME FUNNYCHAR DOTSEEN QUOTEDDIRS) (for I from 1 bind CH (START _ 1) while (SETQ CH (NTHCHARCODE PATHNAME I)) do (SELCHARQ CH (%' (* ; "quote mark, skip it and next char") (add I 1)) (/ (* ; "Directory marker") (push DIRLST (SUBSTRING PATHNAME START (SUB1 I))) (SETQ START (ADD1 I))) ((; %: < > } %]) (* ; "Funny characters that filing doesn't care about but we do -- need to quote these") (SETQ FUNNYCHAR T)) NIL) finally (push DIRLST (SUBSTRING PATHNAME START))) (* ;; "DIRLST is in reverse order now.") (for DIR in DIRLST do (push QUOTEDDIRS (COND (FUNNYCHAR (\NSFILING.ADDQUOTES DIR T)) (T DIR)) (QUOTE >))) (CONCATLIST (NCONC (LIST (QUOTE {) HOST "}<") QUOTEDDIRS (AND (NOT DIRECTORYFLG) (CONS (\NSFILING.ADDQUOTES NAME) (AND VERSION (LIST (if (STRPOS "." NAME) then ";" else ".;") VERSION)))))))) +) + +(\MAILOBJ.DISPLAY + [LAMBDA (OBJ STREAM) (* ; "Edited 26-Jun-90 18:17 by jds") + (LET [(IMAGE (fetch (MAILOBJ MAILOBJ.IMAGE) of (fetch OBJECTDATUM of OBJ] + (* ; + "Display the image, centered on the baseline") + (BITBLT IMAGE NIL NIL STREAM (DSPXPOSITION NIL STREAM) + (- (DSPYPOSITION NIL STREAM) + (LRSH (BITMAPHEIGHT IMAGE) + 1]) + +(\MAILOBJ.GET +(LAMBDA (STREAM TEXTSTREAM) (* ; "Edited 14-Feb-90 16:50 by bvm") (DESTRUCTURING-BIND (LEN TYPE ATTR.LEN NAME . INFO) (READ STREAM FILERDTBL) (LET (DATASTREAM START) (if (EQ (fetch DEVICENAME of (fetch (STREAM DEVICE) of STREAM)) (QUOTE NODIRCORE)) then (* ; "No need to copy the data, just copy the cover") (SETQ DATASTREAM (NCREATE (QUOTE STREAM) STREAM)) (SETQ START (GETFILEPTR STREAM)) (LET ((EOF (+ START LEN))) (* ; "Fix the eof so we don't have to carry around the length") (replace (STREAM EPAGE) of DATASTREAM with (FOLDLO EOF BYTESPERPAGE)) (replace (STREAM EOFFSET) of DATASTREAM with (IMOD EOF BYTESPERPAGE))) else (SETQ DATASTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (COPYBYTES STREAM DATASTREAM LEN) (SETQ START 0)) (\MAILOBJ.CREATE DATASTREAM TYPE ATTR.LEN NAME INFO START)))) +) + +(\MAILOBJ.IMAGEBOX + [LAMBDA (OBJ) (* ; "Edited 26-Jun-90 18:17 by jds") + (fetch (MAILOBJ MAILOBJ.BOX) of (fetch OBJECTDATUM of OBJ]) + +(\MAILOBJ.PUT + [LAMBDA (OBJ STREAM) (* ; "Edited 26-Jun-90 18:17 by jds") + (LET* ((MAILOBJ (fetch OBJECTDATUM of OBJ)) + (COREFILE (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ)) + (END (GETEOFPTR COREFILE)) + (START (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ))) + (LET ((*PRINT-BASE* 10) + (*READTABLE FILERDTBL) + (NAME (fetch (MAILOBJ MAILOBJ.NAME) of MAILOBJ)) + (INFO (fetch (MAILOBJ MAILOBJ.INFO) of MAILOBJ))) + (* ; "Make sure we can read it back.") + (PRIN4 (LIST* (- END START) + (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ) + (fetch (MAILOBJ MAILOBJ.ATTR.LENGTH) of MAILOBJ) + (AND (OR NAME INFO) + (CONS NAME INFO))) + STREAM)) + (COPYBYTES COREFILE STREAM START END]) + +(\MAILOBJ.INIT +(LAMBDA NIL (* ; "Edited 29-Jun-87 16:36 by bvm:") (SETQ \MAILOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION \MAILOBJ.DISPLAY) (FUNCTION \MAILOBJ.IMAGEBOX) (FUNCTION \MAILOBJ.PUT) (FUNCTION \MAILOBJ.GET) (FUNCTION CL:IDENTITY) (FUNCTION \MAILOBJ.BUTTONEVENTFN)))) +) +) +(DEFINEQ + +(\MAILOBJ.BUTTONEVENTFN + [LAMBDA (OBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON) + (* ; "Edited 26-Jun-90 18:17 by jds") + (if (.COPYKEYDOWNP.) + then (* ; + "There's more to copy selection than this") + [AND NIL (LET [(NAME (fetch (MAILOBJ MAILOBJ.NAME) of (IMAGEOBJPROP + OBJ + 'OBJECTDATUM] + (AND NAME (BKSYSBUF NAME] + elseif (IMAGEOBJPROP OBJ 'BUSY) + then (* ; "Busy") + (PRINTOUT PROMPTWINDOW T "Attachment is busy") + else + (LET* + [(MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + (TYPE (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ)) + (REAL.TYPE (if (EQ TYPE 'REFERENCE) + then (LISTGET (fetch (MAILOBJ MAILOBJ.INFO) of MAILOBJ) + 'TYPE) + else TYPE)) + (CMD (MENU (create MENU + ITEMS _ + `(("View as text" '\MAILOBJ.VIEW + "View the attachment as raw text, using TEdit") + (,(if (EQ TYPE 'REFERENCE) + then (* ; + "Note that we are storing the reference itself, not the referenced file") + "Store reference" + else "Put to file") + '\MAILOBJ.PUT.FILE "Store the attachment in a file. This operation loses information unless the file is on an NS File Server." + ) + ,@[AND (EQ REAL.TYPE 'INTERPRESS) + '(("Send to Printer" '\MAILOBJ.HARDCOPY + "Send the document to the printer of your choice."] + ,@[AND (fetch (MAILOBJ MAILOBJ.EXPANDABLE) of MAILOBJ) + '(("Expand folder" '\MAILOBJ.EXPAND + "Extract the first-level subparts of the folder"] + ,@(SELECTQ TYPE + (REFERENCE [AND (GETD 'FILEBROWSER) + (EQ (NTHCHARCODE (fetch (MAILOBJ MAILOBJ.NAME) + of MAILOBJ) + -1) + (CHARCODE >)) + `(("FileBrowse" '\MAILOBJ.FB + "Invoke the File Browser on the referenced object" + ]) + NIL)) + CENTERFLG _ T] + (if (NULL CMD) + then (* ; + "Nothing selected; allow TEdit to select") + T + else (* ; "Do the command in its own process so that the window can return to its more natural state (instead of severely clipped)") + (ADD.PROCESS (LIST (FUNCTION \MAILOBJ.DO.COMMAND) + (KWOTE CMD) + (KWOTE OBJ) + (KWOTE WINDOW) + (KWOTE TEXTSTREAM)) + 'NAME + 'MAILOBJ + 'RESTARTABLE + 'HARDRESET + 'BEFOREEXIT + 'DON'T) (* ; + "Return DON'T so that the window doesn't pop on top to select") + 'DON'T]) + +(\MAILOBJ.DO.COMMAND +(LAMBDA (CMD OBJ WINDOW TEXTSTREAM) (* ; "Edited 3-Jul-87 17:51 by bvm:") (RESETLST (RESETSAVE (IMAGEOBJPROP OBJ (QUOTE BUSY) T) (LIST (QUOTE IMAGEOBJPROP) OBJ (QUOTE BUSY) NIL)) (CL:FUNCALL CMD OBJ WINDOW TEXTSTREAM))) +) + +(\MAILOBJ.HARDCOPY + [LAMBDA (OBJ WINDOW) (* ; "Edited 26-Jun-90 18:17 by jds") + + (* ;; "Hardcopy the attachment in MAILOBJ. WINDOW is the window in which we are viewing it (not currently used).") + + (LET* ((*UPPER-CASE-FILE-NAMES* NIL) + (PRINTER (GetPrinterName)) + (MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + (REFP (EQ (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ) + 'REFERENCE)) + ATTRIBUTES PRINTRESULTS NAME DATA START) + (if (NULL PRINTER) + then (* ; "abort") + NIL + elseif (NOT (STRPOS ":" PRINTER)) + then (* ; "not ns") + (PRINTOUT PROMPTWINDOW T PRINTER " is not an Interpress printer") + else (SETQ PRINTER (GETNSPRINTER PRINTER)) + (if REFP + then (NSPRINT PRINTER (SETQ NAME (fetch (MAILOBJ MAILOBJ.NAME) + of MAILOBJ))) + else (* ; + "Have to do this by hand, since we don't have a nice standalone stream") + [SETQ ATTRIBUTES + (\MAILOBJ.PARSE.ATTRIBUTES + (SETQ DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ)) + [CONSTANT `([DOCUMENT.NAME ,@(CDR (ASSOC 'NAME \NSFILING.ATTRIBUTES] + (DOCUMENT.CREATION.DATE ,@(CDR (ASSOC 'CREATED.ON + \NSFILING.ATTRIBUTES] + (SETQ START (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ] + (* ; + "Parse out the name and creation date, and use them for the document name/date") + [if (SETQ NAME (LISTGET ATTRIBUTES 'DOCUMENT.NAME)) + then (* ; "Fix up any wayward subject") + (LISTPUT ATTRIBUTES 'DOCUMENT.NAME (SETQ NAME ( + \MAILOBJ.MUNGE.NAME + NAME] + [SETQ PRINTRESULTS (\NSPRINT.INTERNAL PRINTER ATTRIBUTES + (FUNCTION (LAMBDA (DATASTREAM) + (\MAILOBJ.COPY.BODY + DATA DATASTREAM + (+ START (fetch (MAILOBJ + MAILOBJ.ATTR.LENGTH + ) + of MAILOBJ))) + NIL] + (if (AND PRINTRESULTS NSPRINT.WATCHERFLG) + then (* ; + "Set up a 'watchdog' process to keep the guy informed of the print job's status.") + (\NSPRINT.WATCH.JOB PRINTRESULTS PRINTER NAME))) + (PRINTOUT PROMPTWINDOW T NAME " sent to " (fetch NSOBJECT of (CAR PRINTER]) + +(\MAILOBJ.FB + [LAMBDA (OBJ WINDOW) (* ; "Edited 26-Jun-90 18:17 by jds") + + (* ;; "Invoke the File Browser on the referenced object") + + (FILEBROWSER (fetch (MAILOBJ MAILOBJ.NAME) of (IMAGEOBJPROP OBJ 'OBJECTDATUM]) + +(\MAILOBJ.PUT.FILE + [LAMBDA (OBJ WINDOW) (* ; "Edited 26-Jun-90 18:17 by jds") + + (* ;; "Store the attachment of MAILOBJ as file of user's choosing. Prompt for file name. If it's on an NS directory, we can deserialize and thus preserve the whole thing.") + + (LET* + ((MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + (DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ)) + (START (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ)) + (PW (CREATEW (create REGION + LEFT _ LASTMOUSEX + BOTTOM _ LASTMOUSEY + WIDTH _ (WINDOWPROP WINDOW 'WIDTH) + HEIGHT _ (HEIGHTIFWINDOW (TIMES 4 (FONTPROP DEFAULTFONT 'HEIGHT)) + NIL 8)) + NIL 8)) + FILE DEVICE CONDITION) + (if [NULL (SETQ FILE (TTYINPROMPTFORWORD "Put attachment to file: " NIL NIL PW NIL + 'TTY + (CHARCODE (CR] + then (PRINTOUT PW "...aborted") + elseif (NULL (SETQ DEVICE (\GETDEVICEFROMNAME (SETQ FILE (\ADD.CONNECTED.DIR FILE)) + T))) + then (PRINTOUT PW T "No such server/device") + else + (ALLOW.BUTTON.EVENTS) + (PRINTOUT PW " ... ") + (if [CL:MULTIPLE-VALUE-SETQ + (FILE CONDITION) + (IGNORE-ERRORS (if (EQ (fetch OPENFILE of DEVICE) + (FUNCTION \NSFILING.OPENFILE)) + then (* ; + "NS device. Really need better test than this.") + (SETFILEPTR DATA START) + (LET ((*UPPER-CASE-FILE-NAMES* NIL)) + (DECLARE (CL:SPECIAL *UPPER-CASE-FILE-NAMES*)) + (* ; "Get name pretty") + (\NSFILING.DESERIALIZE FILE DATA DEVICE)) + else [SETQ FILE + (OPENSTREAM FILE 'OUTPUT 'NEW + `((TYPE ,(fetch (MAILOBJ MAILOBJ.TYPE) + of MAILOBJ)) + (SEQUENTIAL T] + (PRINTOUT PW "(some attributes will be lost) ") + (\MAILOBJ.COPY.BODY DATA FILE (+ START (fetch + (MAILOBJ + MAILOBJ.ATTR.LENGTH + ) + of MAILOBJ)) + PW) + (CLOSEF FILE] + then (PRINTOUT PW T FILE " written.") + else (PRINTOUT PW "failed: " CONDITION]) + +(\MAILOBJ.VIEW + [LAMBDA (OBJ WINDOW) (* ; "Edited 26-Jun-90 18:17 by jds") + + (* ;; "View the text of the attachment. This is often enough to tell you whether you want to bother doing something more exciting with it.") + + (RESETLST + [LET* + ((MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + (TYPE (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ)) + (REFP (EQ TYPE 'REFERENCE)) + (WREG (WINDOWREGION (OR (CAR (WINDOWPROP WINDOW 'EXTRAWINDOWS)) + WINDOW))) + PROPS W SUBJECT START DATA DATASTART) + [if REFP + then (SETQ SUBJECT (fetch (MAILOBJ MAILOBJ.NAME) of MAILOBJ)) + (SETQ TYPE (LISTGET (fetch (MAILOBJ MAILOBJ.INFO) of MAILOBJ) + 'TYPE)) + (SETQ START NIL) + else (SETQ DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ)) + [SETQ SUBJECT (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA + (CONSTANT (LIST (ASSOC 'NAME \NSFILING.ATTRIBUTES))) + (SETQ DATASTART (fetch (MAILOBJ MAILOBJ.START) + of MAILOBJ] + (SETQ START (+ DATASTART (fetch (MAILOBJ MAILOBJ.ATTR.LENGTH) of MAILOBJ] + [SETQ W (CREATEW (create REGION + using WREG LEFT _ + (+ (fetch (REGION LEFT) of WREG) + (if (> (+ (fetch (REGION LEFT) of WREG) + (fetch (REGION WIDTH) of WREG) + MAILOBJ.WINDOWOFFSET) + SCREENWIDTH) + then (- MAILOBJ.WINDOWOFFSET) + else MAILOBJ.WINDOWOFFSET)) + BOTTOM _ (- (fetch (REGION BOTTOM) of WREG) + (if (< (- (fetch (REGION BOTTOM) of WREG) + MAILOBJ.WINDOWOFFSET) + 0) + then (- MAILOBJ.WINDOWOFFSET) + else MAILOBJ.WINDOWOFFSET))) + (CONCAT "Attachment: " (\MAILOBJ.MUNGE.NAME SUBJECT] + (* ; + "Make window slightly overlapping display window") + (WINDOWADDPROP WINDOW 'EXTRAWINDOWS W T) + [if (NEQ TYPE 'TEDIT) + then (* ; + "TEdit's not so good on binary files, so just pull out the text.") + (LET + [(COMPACTDATA (OPENSTREAM '{NODIRCORE} 'BOTH] + [if REFP + then [RESETSAVE NIL (LIST 'CLOSEF (SETQ DATA (OPENSTREAM SUBJECT 'INPUT NIL + '((SEQUENTIAL T] + else (SETFILEPTR DATA (+ DATASTART 4)) (* ; + "Skip the version number (LONGCARDINAL). Next comes SEQUENCE Filing.Attribute") + (if NIL + then + + (* ;; "First extract possible text from unknown attributes. This is not really worth much, other than it skips the mail note, and it is completely the wrong thing on sub-mailobjs, for which none of the fields (except the subject) has been exposed.") + + (to (\WIN DATA) bind X TYPE + do (SETQ TYPE (COURIER.READ DATA NIL 'LONGCARDINAL)) + (if (find X in \NSMAIL.ATTRIBUTES + suchthat (EQ (CADR X) + TYPE)) + then (* ; + "Something of known type--it's probably in the message header. Just skip it") + (COURIER.SKIP.SEQUENCE DATA NIL 'UNSPECIFIED) + else (* ; + "Unknown attribute--extract text from it in case it's interesting. Next word is a count of words") + (\MAILOBJ.EXTRACT.TEXT DATA COMPACTDATA + (UNFOLD (\WIN DATA) + BYTESPERWORD] + (\MAILOBJ.EXTRACT.TEXT DATA COMPACTDATA (- (\GETEOFPTR DATA) + (GETFILEPTR DATA))) + (SETQ DATA COMPACTDATA) + (SETQ START NIL) + (SETQ PROPS (LIST 'FONT LAFITEDISPLAYFONT] + (OPENTEXTSTREAM DATA W START (AND START (GETEOFPTR DATA)) + (APPEND PROPS '(PROMPTWINDOW DON'T])]) + +(\MAILOBJ.MUNGE.NAME +(LAMBDA (STRING) (* ; "Edited 15-Aug-89 17:03 by bvm") (* ;; "Get rid of the CR's in string, substituting something more innocuous.") (if (OR (NULL STRING) (NOT (STRPOS " +" STRING))) then STRING else (CL:SUBSTITUTE #\\ #\Newline STRING)))) + +(\MAILOBJ.COPY.BODY +(LAMBDA (INSTREAM OUTSTREAM START PW) (* ; "Edited 6-Jul-87 12:47 by bvm:") (SETFILEPTR INSTREAM START) (\NSMAIL.READ.SERIALIZED.CONTENT INSTREAM OUTSTREAM) (if (NEQ (\WIN INSTREAM) 0) then (PRINTOUT (OR PW PROMPTWINDOW) T "Warning: Attachment had children, which were not processed."))) +) + +(\MAILOBJ.EXPAND + [LAMBDA (OBJ WINDOW TEXTSTREAM) (* ; "Edited 26-Jun-90 18:17 by jds") + (LET* ((MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) + (DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ)) + (IMAGEPOS (TEDIT.FIND.OBJECT TEXTSTREAM OBJ)) + NUMCHILDREN CHILDREN SUBDATA SUBSTART TYPE PARSE) + (SETFILEPTR DATA (+ (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ) + (fetch (MAILOBJ MAILOBJ.ATTR.LENGTH) of MAILOBJ))) + (\NSMAIL.DISCARD.SERIALIZED.CONTENT DATA) (* ; + "Skip over the body of the folder (should be empty, actually)") + (if (EQ (SETQ NUMCHILDREN (\WIN DATA)) + 0) + then (* ; + "Why did it say it was a directory?") + (PRINTOUT PROMPTWINDOW T "There is nothing in that 'folder' to expand!") + else (to NUMCHILDREN do (* ; + "copy each child into its own image obj") + (SETQ SUBDATA (OPENSTREAM '{NODIRCORE} 'BOTH)) + (COURIER.WRITE SUBDATA \SERIALIZED.FILE.VERSION NIL + 'LONGCARDINAL) + (SETQ SUBSTART (\MAILOBJ.COPY.CHILD DATA SUBDATA)) + (* ; "Copy recursive part") + (SETQ PARSE (\MAILOBJ.PARSE.ATTRIBUTES + SUBDATA + (CONSTANT (LIST (ASSOC 'FILE.TYPE + \NSFILING.ATTRIBUTES + ) + (ASSOC 'NAME + \NSFILING.ATTRIBUTES + ))) + 0)) + (SETQ TYPE (LISTGET PARSE 'FILE.TYPE)) + [push CHILDREN (\MAILOBJ.CREATE + SUBDATA + (AND TYPE (\TYPE.FROM.FILETYPE + TYPE)) + SUBSTART + (LISTGET PARSE 'NAME] + (* ; + "Create object, parsing the type field out of the raw data") + ) + (add IMAGEPOS 1) + (TEXTPROP TEXTSTREAM 'READONLY (PROG1 (TEXTPROP TEXTSTREAM 'READONLY) + (TEXTPROP TEXTSTREAM 'READONLY NIL) + (* ; + "This ought to be one call, but the macro does not expand properly") + (for C in CHILDREN + do + (* ; +"Insert the objects following obj in reverse order of creation, so they come out right in the end.") + (TEDIT.INSERT.OBJECT C TEXTSTREAM + IMAGEPOS)))]) + +(\MAILOBJ.COPY.CHILD +(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 6-Jul-87 14:41 by bvm:") (* ;; "This is the counterpart to \nsmail.read.serialized.tree, except that it copies the data as it parses it, rather than interpreting it. Returns file pointer of the start of the main child's data section.") (* ;; "We are parsing here the recursive part of Filing.SerializedFile: SerializedTree, which consists of: Sequence of Attribute; Content; children = Sequence of SerializedTree") (LET (ATTRLENGTH SUBSTART NCHILDREN LASTSEGMENT?) (\WOUT OUTSTREAM (SETQ ATTRLENGTH (\WIN INSTREAM))) (* ; "number of attributes") (to ATTRLENGTH do (RPTQ 4 (\BOUT OUTSTREAM (\BIN INSTREAM))) (* ; "Copy attribute type (longcardinal)") (\MAILOBJ.COPY.SEQUENCE INSTREAM OUTSTREAM) (* ; "Copy attribute value (sequence unspecified)")) (SETQ SUBSTART (GETFILEPTR OUTSTREAM)) (* ;; "Now copy the body, which is StreamOfUnspecified followed by lastByteIsSignficant boolean") (do (\WOUT OUTSTREAM (SETQ LASTSEGMENT? (\WIN INSTREAM))) (* ; "1 => this is last segment") (\MAILOBJ.COPY.SEQUENCE INSTREAM OUTSTREAM) (* ; "Copy the sequence") repeatuntil (NEQ LASTSEGMENT? 0) finally (\WOUT OUTSTREAM (\WIN INSTREAM)) (* ; "Copy lastByteIsSignficant boolean")) (\WOUT OUTSTREAM (SETQ NCHILDREN (\WIN INSTREAM))) (to NCHILDREN do (\MAILOBJ.COPY.CHILD INSTREAM OUTSTREAM)) SUBSTART)) +) + +(\MAILOBJ.COPY.SEQUENCE +(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 6-Jul-87 14:37 by bvm:") (* ;; "Copy a Sequence of Unspecified from in to out.") (LET ((SEQLENGTH (\WIN INSTREAM))) (\WOUT OUTSTREAM SEQLENGTH) (* ; "Representation is sequence length (word) followed by that many words") (RPTQ (UNFOLD SEQLENGTH BYTESPERWORD) (\BOUT OUTSTREAM (\BIN INSTREAM))))) +) + +(\MAILOBJ.EXTRACT.TEXT +(LAMBDA (DATA OUTSTREAM LEN) (* ; "Edited 15-Aug-89 16:38 by bvm") (* ;; "Copy LEN bytes from the stream DATA to OUTSTREAM, where all the runs of non-printing characters are replaced by some small number of ugly characters that won't upset tedit.") (to LEN bind CH HELDCH (SKIPPING _ -1) do (if (OR (>= (SETQ CH (\BIN DATA)) 127) (AND (< CH (CHARCODE SPACE)) (SELCHARQ CH ((TAB CR) NIL) ( (* ; "VP eol") (SETQ CH (CHARCODE CR)) NIL) T))) then (* ; "Junk") (SETQ HELDCH NIL) (* ; "I don't care if the previous byte was accidentally ascii") (if (EVENP (add SKIPPING 1) 16) then (BOUT OUTSTREAM MAILOBJ.SKIPCHAR)) elseif (< SKIPPING 0) then (* ; "in a nice ascii section") (BOUT OUTSTREAM CH) elseif HELDCH then (* ; "We were just waiting to see...") (BOUT OUTSTREAM HELDCH) (SETQ HELDCH NIL) (SETQ SKIPPING -1) (BOUT OUTSTREAM CH) else (* ; "We had been skipping. Don't print this byte until we see the next byte is nice, too, so as to reduce the gibberish of accidental ascii in the middle of binary") (SETQ HELDCH CH))) OUTSTREAM) +) + +(\MAILOBJ.PARSE.ATTRIBUTES +(LAMBDA (DATA FIELDS START) (* ; "Edited 14-Feb-90 16:26 by bvm") (* ;; "Parse the SUBJECT field out of the serialized stream DATA beginning at START. FIELDS is in the format of \nsfiling.attributes entries") (SETFILEPTR DATA (+ START 4)) (* ; "Skip the version number (LONGCARDINAL). Next comes SEQUENCE Filing.Attribute") (to (\WIN DATA) bind (CNT _ (LENGTH FIELDS)) X TYPE do (SETQ TYPE (COURIER.READ DATA NIL (QUOTE LONGCARDINAL))) (if (find old X in FIELDS suchthat (EQ (CADR X) TYPE)) then (* ; "X = (type number interpretation)") (\WIN DATA) (push $$VAL (CAR X) (COURIER.READ DATA NIL (CADDR X))) (if (<= (SETQ CNT (SUB1 CNT)) 0) then (* ;; "Found them all") (RETURN $$VAL)) else (COURIER.SKIP.SEQUENCE DATA NIL (QUOTE UNSPECIFIED))))) +) +) + +(ADDTOVAR FILING.TYPES (VIEWPOINT 4353) + (RES 4428) + (XEROX860 5120) + (REFERENCE 4427) + (MAILFOLDER 4417)) + +(RPAQQ MAILOBJ.REFERENCE.FIELD + (REFERENCE 4421 (NAMEDRECORD (FILE.ID (FILING . FILE.ID)) + (SERVICE NSNAME) + (ADDRESS NSADDRESS) + (HOST STRING) + (DIRECTORY STRING) + (NAME STRING) + (TYPE (FILING . ATTRIBUTE.TYPE)) + (NIL UNSPECIFIED) + (PAGES CARDINAL) + (VERSION CARDINAL) + (FLAGS CARDINAL)))) + +(RPAQ? MAILOBJ.WINDOWOFFSET 16) + +(RPAQ? MAILOBJ.SKIPCHAR (CHARCODE ".")) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD MAILOBJ (MAILOBJ.IMAGE MAILOBJ.BOX MAILOBJ.TYPE MAILOBJ.DATA MAILOBJ.ATTR.LENGTH + MAILOBJ.START MAILOBJ.NAME MAILOBJ.EXPANDABLE . MAILOBJ.INFO)) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \MAILOBJ.REFERENCE.LAST.FILED 8192) + + +(CONSTANTS \MAILOBJ.REFERENCE.LAST.FILED) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\MAILOBJ.INIT) + +(AND (EQ MAKESYSNAME :LYRIC) + (FILESLOAD (SYSLOAD) + NSRANDOM)) +) + + + +(* ; "sending mail") + +(DEFINEQ + +(\NSMAIL.SEND.PARSE +(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 17-Jan-89 15:55 by bvm") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) RECIPIENTS MSGFIELDS FORMATTEDP HEADEREOF INTERESTINGFIELDS SUBJECT ATTACHMENT) (OR (SETQ MSGFIELDS (\LAFITE.PREPARE.SEND MSG EDITORWINDOW \LAPARSE.NSMAIL)) (RETURN)) (COND ((EQ (CAAR MSGFIELDS) (QUOTE EOF)) (SETQ HEADEREOF (CADR (pop MSGFIELDS))))) (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) ((To cc From Reply-to) (push INTERESTINGFIELDS (RPLACD PAIR (\NSMAIL.PARSE (CDR PAIR) SENDER EDITORWINDOW))) (SELECTQ (CAR PAIR) ((To cc) (LET ((EXPANDED (for NAME in (CDR PAIR) join (if (CL:STRING= (fetch NSDOMAIN of NAME) ";") then (* ; "DL syntax") (\NSMAIL.EXPAND.DL (fetch NSOBJECT of NAME) SENDER EDITORWINDOW) else (LIST NAME))))) (SETQ RECIPIENTS (COND (RECIPIENTS (NS.REMOVEDUPLICATES (APPEND EXPANDED RECIPIENTS))) (T EXPANDED))))) (PROGN (* ; "Might want to check validity of From and Reply-to") NIL))) ((Subject In-Reply-to) (RPLACD PAIR (COND ((CDDR PAIR) (CONCATLIST (CDR PAIR))) (T (CADR PAIR)))) (* ; "Make one string") (push INTERESTINGFIELDS PAIR) (COND ((EQ (CAR PAIR) (QUOTE Subject)) (SETQ SUBJECT (CDR PAIR))))) (Date (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) (Sender (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) (Format (SETQ FORMATTEDP (SELECTQ (CADR PAIR) (TEDIT T) NIL))) ((REFERENCE ATTACHMENT) (if ATTACHMENT then (\SENDMESSAGEFAIL EDITORWINDOW "Can only send a single attachment")) (SETQ ATTACHMENT T) (push INTERESTINGFIELDS PAIR)) NIL)) (COND ((NULL RECIPIENTS) (\SENDMESSAGEFAIL EDITORWINDOW "No recipients!"))) (OR FORMATTEDP (SELECTQ (\LAFITE.CHOOSE.MSG.FORMAT MSG NIL EDITORWINDOW) (TEDIT (SETQ FORMATTEDP T)) (NIL (* ; "Aborted") (RETURN)) NIL)) (RETURN (create NSMAILPARSE NSPSUBJECT _ SUBJECT NSPRECIPIENTS _ RECIPIENTS NSPSTART _ HEADEREOF NSPFIELDS _ INTERESTINGFIELDS NSPFORMATTED _ FORMATTEDP)))) +) + +(\NSMAIL.PARSE.REFERENCE +(LAMBDA (FILENAME EDITWINDOW) (* ; "Edited 17-Jan-89 15:55 by bvm") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FULLNAME (FINDFILE FILENAME T))) (COND ((NULL FULLNAME) (\SENDMESSAGEFAIL EDITWINDOW "Can't find reference file " FILENAME)) (T (LET* ((FIELDS (UNPACKFILENAME.STRING FULLNAME)) (HOST (LISTGET FIELDS (QUOTE HOST))) (NSHOST (PARSE.NSNAME HOST)) (ADDRESS (LOOKUP.NS.SERVER NSHOST)) (NAME (LISTGET FIELDS (QUOTE NAME))) (EXT (LISTGET FIELDS (QUOTE EXTENSION))) (VERSION (LISTGET FIELDS (QUOTE VERSION))) (ID (GETFILEINFO FULLNAME (QUOTE FILE.ID))) (TYPE (GETFILEINFO FULLNAME (QUOTE FILE.TYPE))) (SIZE (GETFILEINFO FULLNAME (QUOTE SIZE)))) (COND ((NOT (AND (STRPOS ":" HOST) ADDRESS)) (\SENDMESSAGEFAIL EDITWINDOW "Reference file must be on NS server")) ((NOT (AND ID TYPE SIZE)) (\SENDMESSAGEFAIL EDITWINDOW "Can't lookup info on " FULLNAME)) (T (BQUOTE ((FILE.ID (\, ID)) (SERVICE (\, NSHOST)) (ADDRESS (\, ADDRESS)) (HOST (\, HOST)) (DIRECTORY (\, (CL:SUBSTITUTE #\/ #\> (UNPACKFILENAME.STRING FULLNAME (QUOTE DIRECTORY))))) (NAME (\, (if EXT then (SETQ NAME (CONCAT NAME "." EXT)) else NAME))) (TYPE (\, (if (OR (NEQ TYPE 0) (NULL EXT)) then (* ; "Interesting type, or no clue from extension") TYPE elseif (AND (SETQ TYPE (\NSMAIL.GUESS.FILE.TYPE NAME EXT)) (SELECTQ (\SENDMESSAGE.MENUPROMPT EDITWINDOW (\LAFITE.CREATE.MENU (BQUOTE (((\, (CONCAT "Change file type to " TYPE)) T) ("Leave as type BINARY" NIL) ("Abort" (QUOTE ABORT)))) "Fix type of reference file?") "Referenced document is of type BINARY; some mail clients will not understand.") (NIL NIL) (ABORT (ERROR!)) (if (SETFILEINFO FULLNAME (QUOTE TYPE) (SETQ TYPE (\FILETYPE.FROM.TYPE TYPE))) then TYPE else (\SENDMESSAGEFAIL EDITWINDOW "Could not set the file type")))) else (* ; "Oh, give up, leave it binary") 0))) (NIL 0) (PAGES (\, (ADD1 SIZE))) (VERSION (\, (OR (AND VERSION (MKATOM VERSION)) 0))) (FLAGS 0)))))))))) +) + +(\NSMAIL.EXPAND.DL +(LAMBDA (DL SENDER EDITWINDOW) (* ; "Edited 16-Jan-89 14:04 by bvm") (LET ((FILENAME (PACKFILENAME.STRING (QUOTE BODY) (if (EQL (CL:CHAR DL 0) #\") then (* ; "quoted file name, take off the quotes first") (CL:SUBSEQ DL 1 (- (CL:LENGTH DL) 1)) else DL) (QUOTE EXTENSION) LAFITEDL.EXT)) STREAM) (if (NULL (SETQ FILENAME (if (OR (UNPACKFILENAME.STRING FILENAME (QUOTE HOST)) (UNPACKFILENAME.STRING FILENAME (QUOTE DIRECTORY))) then (INFILEP FILENAME) else (* ; "Search default directories") (FINDFILE FILENAME T (CONS LAFITEDEFAULTHOST&DIR LAFITEDLDIRECTORIES))))) then (\SENDMESSAGEFAIL EDITWINDOW "Can't find file named " DL) elseif (NULL (SETQ STREAM (CAR (NLSETQ (OPENTEXTSTREAM (MKATOM FILENAME)))))) then (\SENDMESSAGEFAIL EDITWINDOW "Can't open " DL) else (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM)) (* ; "I hope this closes the file. We used OPENTEXTSTREAM instead of OPEN so that file can contain tedit formatting.") (bind LINE while (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) join (\NSMAIL.PARSE LINE SENDER EDITWINDOW)))))) +) + +(\NSMAIL.PARSE +(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* bvm%: " 3-Jul-84 16:21") (NS.REMOVEDUPLICATES (COND ((LISTP FIELD) (for PIECE in FIELD join (\NSMAIL.PARSE1 PIECE DEFAULTDOMAIN EDITWINDOW))) (T (\NSMAIL.PARSE1 FIELD DEFAULTDOMAIN EDITWINDOW))))) +) + +(\NSMAIL.PARSE1 +(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* bvm%: " 3-Jul-84 16:26") (COND (FIELD (bind ADDR (START _ 1) COMMA when (PROGN (SETQ ADDR (SUBSTRING FIELD START (COND ((SETQ COMMA (STRPOS (QUOTE %,) FIELD START)) (SUB1 COMMA))))) (do (* ; "Strip leading blanks") (SELCHARQ (CHCON1 ADDR) ((SPACE TAB) (GNC ADDR)) (RETURN))) (do (* ; "Strip trailing blanks") (SELCHARQ (NTHCHARCODE ADDR -1) ((SPACE TAB) (GLC ADDR)) (RETURN))) (NEQ (NCHARS ADDR) 0)) collect (PARSE.NSNAME ADDR NIL DEFAULTDOMAIN) repeatwhile (COND (COMMA (SETQ START (ADD1 COMMA)))))))) +) + +(NS.REMOVEDUPLICATES +(LAMBDA (LST) (* ; "Edited 6-Jun-88 13:38 by bvm") (CL:REMOVE-DUPLICATES LST :TEST (FUNCTION EQUAL.CH.NAMES))) +) + +(\NSMAIL.SEND + [LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* ; "Edited 26-Jun-90 18:25 by jds") + +(* ;;; "MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients") + + (DECLARE (SPECVARS MSG START MSGFIELDS EDITORWINDOW ABORTWINDOW FORMATSTREAM REFERENCE + ATTACHMENT ATTACHED-ATTRIBUTES BODYTYPE BODYLENGTH NOTEP)) + (* ; + "For \NSMAIL.SEND.MESSAGE.CONTENT") + (RESETLST + (PROG ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW))) + (RECIPIENTS (fetch (NSMAILPARSE NSPRECIPIENTS) of PARSE)) + (START (OR (fetch (NSMAILPARSE NSPSTART) of PARSE) + (GETEOFPTR MSG))) + (MSGFIELDS (fetch (NSMAILPARSE NSPFIELDS) of PARSE)) + (CREDENTIALS (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*)) + FORMATSTREAM REFERENCE ATTACHMENT BODYTYPE BODYLENGTH NOTEP COURIERSTREAM DATASTREAM + RECIPIENTSCHECK SENDRESULT SENDERFIELD DATEFIELD TYPE MAILDROP RESULTS + ATTACHED-ATTRIBUTES) + [COND + (PWINDOW (* ; + "Make sure prompt window will expand as needed. Probably generic sendmessage should do this") + (RESETSAVE (TTYDISPLAYSTREAM PWINDOW)) + (RESETSAVE (LINELENGTH T] + (COND + ((AND (fetch (NSMAILPARSE NSPFORMATTED) of PARSE) + (TEDIT.FORMATTEDFILEP MSG)) (* ; + "Message is formatted, so get info. Have to exclude header, since it is not sent.") + (SETQ MSG (COPYTEXTSTREAM MSG)) + (TEDIT.DELETE MSG 1 START) + (SETQ FORMATSTREAM (COERCETEXTOBJ MSG 'SPLIT)) + (* ; "Get (body . formatting)") + (SETQ MSG (OPENSTREAM (CAR FORMATSTREAM) + 'INPUT)) + (SETQ FORMATSTREAM (OPENSTREAM (CDR FORMATSTREAM) + 'INPUT)) + (SETQ START 0)) + ((AND (TEXTSTREAMP MSG) + (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message has formatting, but caller asked to send it as plain text. Carefully coerce it, since TEDIT ns chars and image objects don't pass thru COPYBYTES very well") + (SETQ MSG (LAFITE.MAKE.PLAIN.TEXTSTREAM MSG START)) + (SETQ START 0))) + (SETQ BODYLENGTH (- (GETEOFPTR MSG) + START)) + (SETQ REFERENCE (ASSOC 'REFERENCE MSGFIELDS)) + (SETQ ATTACHMENT (ASSOC 'ATTACHMENT MSGFIELDS)) + (if (OR REFERENCE ATTACHMENT) + then (* ; "Text must be sent as mail note") + (if (< BODYLENGTH *NSMAIL-MAX-NOTE-LENGTH*) + then (SETQ NOTEP T) + else (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW + "Message text too long to send with attachment"))) + (if (AND REFERENCE ATTACHMENT) + then (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW + "Can't send both attachment file AND reference")) + ) + elseif (AND *NSMAIL-SEND-MAIL-NOTES* (< BODYLENGTH *NSMAIL-MAX-NOTE-LENGTH*)) + then (SETQ NOTEP T)) + (if ATTACHMENT + then (SETQ MSGFIELDS (DREMOVE ATTACHMENT MSGFIELDS)) + (SETQ ATTACHMENT (\NSMAIL.PREPARE.ATTACHMENT (CADR ATTACHMENT))) + elseif REFERENCE + then (RPLACD REFERENCE (\NSMAIL.PARSE.REFERENCE (CADR REFERENCE) + EDITORWINDOW)) + (SETQ BODYTYPE \NSMAIL.REFERENCE.BODYTYPE)) + [COND + (PWINDOW (CLEARW PWINDOW) + (LET ((TYPE (if REFERENCE + then (CADR (ASSOC 'TYPE (CDR REFERENCE))) + else BODYTYPE))) + (CL:FORMAT PWINDOW + "Delivering ~:[~;formatted ~]~@[with ~A ~]~@[~A ~]to ~D recipient~:P" + FORMATSTREAM [AND TYPE (CL:STRING-CAPITALIZE (MKSTRING + ( + \TYPE.FROM.FILETYPE + TYPE] + (COND + (REFERENCE "reference") + (ATTACHMENT "attachment")) + (LENGTH RECIPIENTS] + [COND + ((NULL (SETQ MAILDROP (\NSMAIL.FINDSERVER))) + (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't find a mail drop"] + (to 3 until (SETQ COURIERSTREAM (COURIER.OPEN MAILDROP NIL T 'NSMAILER)) + do (* ; + "loop 3 times trying to start this send") + (DISMISS 1000)) + [COND + ((NULL COURIERSTREAM) + (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop"] + (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) + COURIERSTREAM)) + (AND PWINDOW (printout PWINDOW '|...|)) + (SETQ RESULTS (COURIER.CALL COURIERSTREAM 'MAILTRANSPORT 'POST (CAR CREDENTIALS) + (CDR CREDENTIALS) + RECIPIENTS NIL T \NSMAIL.CTSTANDARD.MESSAGE NIL + (FUNCTION \NSMAIL.SEND.MESSAGE.CONTENT) + 'RETURNERRORS)) + [COND + ((EQ (CAR (LISTP RESULTS)) + 'ERROR) + (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (SELECTQ (CADR RESULTS) + (INVALID.RECIPIENTS + (\LAFITE.INVALID.RECIPIENTS + (CDDR RESULTS))) + (MKSTRING (CDR RESULTS] + (AND NSMAILDEBUGFLG (printout PROMPTWINDOW T "Post results: " RESULTS)) + (RETURN (LENGTH RECIPIENTS))))]) + +(\NSMAIL.PREPARE.ATTACHMENT +(LAMBDA (FILE) (* ; "Edited 14-Sep-89 12:15 by bvm") (DECLARE (USEDFREE MSGFIELDS EDITORWINDOW ATTACHMENT ATTACHED-ATTRIBUTES BODYTYPE BODYLENGTH)) (LET* ((HOST (UNPACKFILENAME.STRING FILE (QUOTE HOST))) (SERIALIZED (STRPOS ":" HOST)) (ATTRCOUNT 0) ATTRSTREAM) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (if SERIALIZED then (\NSFILING.GETFILE (\GETDEVICEFROMHOSTNAME (MKATOM (U-CASE HOST))) FILE (QUOTE SERIALIZE) (QUOTE OLD) NIL NIL T) else (OPENSTREAM FILE (QUOTE INPUT)))) (if (NULL STREAM) then (\LAFITE.SEND.FAIL EDITORWINDOW (OR CONDITION "Attachment not found.")) (ERROR!)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STREAM)) (if SERIALIZED then (* ; "Parse out the attributes portion of the serialized file and save those that are not specifically mail attributes") (SETQ ATTRSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.CHECK.SERIALIZED.VERSION STREAM) (to (\WIN STREAM) bind TYPE WORDCOUNT do (SETQ TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (if (EQ TYPE (\NSMAIL.ATTRIBUTE.TYPE BodyType)) then (* ; "We always send type explicitly") (\WIN STREAM) (SETQ BODYTYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) elseif (OR (for TRIPLE in \NSMAIL.ATTRIBUTES thereis (EQ TYPE (CADR TRIPLE))) (AND (< TYPE 100) (for TRIPLE in \NSFILING.ATTRIBUTES when (EQ TYPE (CADR TRIPLE)) do (* ; "Only a few filing attributes are interesting. Is.directory appears to be vital (the server won't deserialize something with children without it)") (RETURN (NOT (FMEMB (CAR TRIPLE) (QUOTE (IS.DIRECTORY CREATED.BY CREATED.ON MODIFIED.BY MODIFIED.ON)))))))) then (* ; "A mail attribute or file-specific file attribute, skip it") (COURIER.SKIP.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED)) else (* ; "Save it") (add ATTRCOUNT 1) (COURIER.WRITE ATTRSTREAM TYPE NIL (QUOTE LONGCARDINAL)) (\WOUT ATTRSTREAM (SETQ WORDCOUNT (\WIN STREAM))) (COPYBYTES STREAM ATTRSTREAM (UNFOLD WORDCOUNT BYTESPERWORD)))) (SETQ ATTACHED-ATTRIBUTES (CONS ATTRCOUNT ATTRSTREAM)) else (* ; "Not on an NS server, let's investigate the type") (CASE (SETQ BODYTYPE (\FILETYPE.FROM.TYPE (GETFILEINFO STREAM (QUOTE TYPE)))) ((NIL 0) (* ; "Under specified") (if (SETQ BODYTYPE (\NSMAIL.GUESS.FILE.TYPE (FULLNAME STREAM))) then (SETQ BODYTYPE (\FILETYPE.FROM.TYPE BODYTYPE)) elseif (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (\LAFITE.CREATE.MENU (QUOTE (("Send as BINARY attachment" T) ("Abort" NIL))) "Send attachment?") "Warning: Type of attached file is unknown; most mail clients can't do anything interesting with this.") then (SETQ BODYTYPE 0) else (ERROR!)))) (push MSGFIELDS (BQUOTE (MODIFIED.ON (\,@ (GETFILEINFO STREAM (QUOTE ICREATIONDATE))))))) STREAM))) +) + +(\NSMAIL.GUESS.FILE.TYPE +(LAMBDA (FILENAME EXT) (* ; "Edited 17-Jan-89 15:42 by bvm") (* ;; "Given a file name, try to guess what type it is from the extension, since file's TYPE property was boring. EXT is computed from FILENAME if omitted.") (OR (CAR (CL:ASSOC (OR EXT (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION))) FILING.TYPES :TEST (QUOTE STRING-EQUAL))) (LET ((TYPE (PRINTFILETYPE.FROM.EXTENSION FILENAME))) (AND TYPE (CAR (CL:ASSOC TYPE FILING.TYPES :TEST (QUOTE STRING-EQUAL))))))) +) + +(\NSMAIL.SEND.MESSAGE.CONTENT +(LAMBDA (DATASTREAM) (* ; "Edited 13-Sep-89 17:15 by bvm") (DECLARE (USEDFREE MSG START MSGFIELDS EDITORWINDOW ABORTWINDOW FORMATSTREAM REFERENCE ATTACHMENT ATTACHED-ATTRIBUTES BODYTYPE BODYLENGTH NOTEP)) (* ; "From \NSMAIL.SEND") (* ;; "Transmits the bulkdata portion of the message") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (* ;; "Want to send a serialized file on DATASTREAM --- version plus SerializedTree. See \NSMAIL.READ.SERIALIZED.TREE") (COURIER.WRITE DATASTREAM \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "Version") (* ;; "Now comes (SEQUENCE ATTRIBUTE); the attributes we want to send are those in MSGFIELDS plus Date, From, BodyType and Note") (\WOUT DATASTREAM (+ (LENGTH MSGFIELDS) (if FORMATSTREAM then (* ; "Also a LispFormatting item") 1 else 0) (if NOTEP then (* ; "Send body as Note attribute") (SETQ BODYLENGTH 0) 1 else (* ; "Send as body") 0) (if ATTACHED-ATTRIBUTES then (* ; "From serialized file") (CAR ATTACHED-ATTRIBUTES) else 0) 4)) (* ; "Number of attributes") (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE Date) (IDATE)) (COND ((ASSOC (QUOTE From) MSGFIELDS) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE Sender) SENDER)) (T (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE From) (LIST SENDER)))) (for PAIR in MSGFIELDS do (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (CAR PAIR) (CDR PAIR))) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE BodyType) (COND (BODYTYPE) (NOTEP \NSMAIL.EMPTY.BODYTYPE) (T \NSMAIL.TEXT.BODYTYPE))) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE BodySize) (if ATTACHMENT then (SETQ BODYLENGTH (GETEOFPTR ATTACHMENT)) else BODYLENGTH)) (COND ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT))) (ERROR!))) (COND (NOTEP (\NSMAIL.SEND.STREAM.AS.STRING MSG DATASTREAM START (\NSMAIL.ATTRIBUTE.TYPE Note)))) (COND (FORMATSTREAM (\NSMAIL.SEND.STREAM.AS.STRING FORMATSTREAM DATASTREAM 0 (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)))) (PROGN (* ; "Now the content of the serialized tree, first part of which is a Bulkdata.StreamOfUnspecified") (COND (ATTACHMENT (if ATTACHED-ATTRIBUTES then (* ; "We have a serialized file here already. First send the rest of the interesting attributes") (COPYBYTES (CDR ATTACHED-ATTRIBUTES) DATASTREAM 0 -1) (* ; "Then the rest of the serialization") (COPYBYTES ATTACHMENT DATASTREAM) else (COURIER.WRITE.STREAM.UNSPECIFIED DATASTREAM ATTACHMENT 0 BODYLENGTH))) (NOTEP (* ; "Null content") (\WOUT DATASTREAM 1) (* ; "Last segment") (\WOUT DATASTREAM 0) (* ; "Empty sequence")) (T (COURIER.WRITE.STREAM.UNSPECIFIED DATASTREAM MSG START (GETEOFPTR MSG))))) (if (NOT ATTACHED-ATTRIBUTES) then (* ; "Finally, the last of the serialized tree") (\WOUT DATASTREAM (LOGXOR (LOGAND BODYLENGTH 1) 1)) (* ; "Last byte significant (even number of bytes)") (\WOUT DATASTREAM 0) (* ; "No children")) (COND ((NULL ABORTWINDOW)) ((WINDOWPROP ABORTWINDOW (QUOTE ABORT)) (ERROR!)) (T (* ; "Too late to abort now") (DELETEMENU (CAR (WINDOWPROP ABORTWINDOW (QUOTE MENU))) NIL ABORTWINDOW))) (RETURN NIL))) +) + +(COURIER.WRITE.STREAM.UNSPECIFIED +(LAMBDA (OUTSTREAM INSTREAM START END) (* bvm%: "16-May-85 14:24") (* ;;; "Copies INSTREAM from START to END onto OUTSTREAM in the form of Bulkdata.StreamOfUnspecified --- format is one or more concatenations of {lastSegmentP,SequenceUnspecified} --- returns T if even number of bytes written, NIL if odd") (LET (LENGTH) (COND (END (SETFILEPTR INSTREAM START) (SETQ LENGTH (IDIFFERENCE (COND ((EQ END -1) (GETEOFPTR INSTREAM)) (T END)) START))) (START (SETQ LENGTH START)) (T (SETQ LENGTH (IDIFFERENCE (GETEOFPTR INSTREAM) (GETFILEPTR INSTREAM))))) (while (GREATERP LENGTH MAX.BULK.SEGMENT.LENGTH) do (\WOUT OUTSTREAM 0) (* ; "Not last segment") (\WOUT OUTSTREAM (FOLDHI MAX.BULK.SEGMENT.LENGTH BYTESPERWORD)) (* ; "Word length of this segment") (COPYBYTES INSTREAM OUTSTREAM MAX.BULK.SEGMENT.LENGTH) (SETQ LENGTH (IDIFFERENCE LENGTH MAX.BULK.SEGMENT.LENGTH))) (\WOUT OUTSTREAM 1) (* ; "Last segment") (\WOUT OUTSTREAM (FOLDHI LENGTH BYTESPERWORD)) (* ; "Word length of this segment") (COPYBYTES INSTREAM OUTSTREAM LENGTH) (COND ((EVENP LENGTH) T) (T (* ; "Garbage last byte") (\BOUT OUTSTREAM 0) NIL)))) +) + +(\NSMAIL.SEND.STREAM.AS.STRING +(LAMBDA (INSTREAM OUTSTREAM START ATTRIBUTE) (* bvm%: "30-Jul-84 15:31") (* ;; "Writes the contents of INSTREAM, beginning at byte START, to OUTSTREAM in the form of a Filing Attribute whose type is ATTRIBUTE and whose value is a string") (PROG ((EOF (GETEOFPTR INSTREAM)) LENGTH) (COURIER.WRITE OUTSTREAM ATTRIBUTE NIL (QUOTE LONGCARDINAL)) (\WOUT OUTSTREAM (ADD1 (FOLDHI (SETQ LENGTH (IDIFFERENCE EOF START)) BYTESPERWORD))) (* ; "Sequence length") (\WOUT OUTSTREAM LENGTH) (* ; "String length") (COPYBYTES INSTREAM OUTSTREAM START EOF) (COND ((ODDP LENGTH) (\BOUT OUTSTREAM 0))))) +) + +(\NSMAIL.WRITE.ATTRIBUTE +(LAMBDA (STREAM TYPE VALUE) (* ; "Edited 17-Jan-89 16:39 by bvm") (LET* (FILINGP (TYPEINFO (if (EQ TYPE (QUOTE REFERENCE)) then (* ; "This is handled specially so that we don't read references on input") MAILOBJ.REFERENCE.FIELD else (OR (ASSOC TYPE \NSMAIL.ATTRIBUTES) (SETQ FILINGP (ASSOC TYPE \NSFILING.ATTRIBUTES)))))) (if TYPEINFO then (COURIER.WRITE STREAM (CADR TYPEINFO) NIL (QUOTE LONGCARDINAL)) (* ; "Type code") (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE (if FILINGP then (QUOTE FILING) else (QUOTE MAILTRANSPORT)) (CADDR TYPEINFO)) else (ERROR "Unknown mail attribute" TYPE)))) +) + +(\NSMAIL.FINDSERVER +(LAMBDA NIL (* bvm%: "14-Nov-84 23:47") (PROG ((NULL.AUTHENTICATOR (CONSTANT (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE _ (QUOTE SIMPLE) VALUE _ NIL))) INFO) (RETURN (COND ((AND \NSMAIL.SERVER.CACHE (find ADDR in \NSMAIL.SERVER.CACHE suchthat (\NSMAIL.CHECKSERVER (COURIER.EXPEDITED.CALL ADDR \NSMAIL.SOCKET (QUOTE MAILTRANSPORT) (QUOTE SERVER.POLL) NULL.AUTHENTICATOR (QUOTE (0)) (QUOTE RETURNERRORS)))))) ((SETQ INFO (COURIER.BROADCAST.CALL \NSMAIL.SOCKET (QUOTE MAILTRANSPORT) (QUOTE SERVER.POLL) (LIST NULL.AUTHENTICATOR (QUOTE (0))) (FUNCTION \NSMAIL.CHECKSERVER) NSMAIL.NET.HINT)) (push \NSMAIL.SERVER.CACHE INFO) INFO))))) +) + +(\NSMAIL.CHECKSERVER +(LAMBDA (POLLRESULT) (* bvm%: " 1-Jul-84 15:15") (* ;; "Checks that the result of a SERVER.POLL is useful. Returns the server's address") (COND ((AND (FIXP (CAR POLLRESULT)) (ILESSP (CAR POLLRESULT) 10)) (CAR (CADR POLLRESULT))))) +) +) + +(FILESLOAD LAFITEMAIL) + + + +(* ; "for LAFITE.MAKE.PARSE.TABLE") + + +(RPAQQ NSMAIL.PARSEFIELDS + (("DATE:" LAFITE.READ.LINE.FOR.TOC Date) + ("SUBJECT:" LAFITE.READ.LINE.FOR.TOC Subject) + ("SENDER:" LAFITE.READ.NAME.FIELD Sender) + ("FROM:" LAFITE.READ.NAME.FIELD From) + ("REPLY-TO:" LAFITE.READ.NAME.FIELD Reply-to) + ("IN-REPLY-TO:" LAFITE.READ.LINE.FOR.TOC In-Reply-to) + ("TO:" LAFITE.READ.NAME.FIELD To) + ("CC:" LAFITE.READ.NAME.FIELD cc) + ("FORMAT:" LAFITE.READ.FORMAT) + ("ATTACHED-REFERENCE:" LAFITE.READ.LINE.FOR.TOC REFERENCE) + ("ATTACHED-FILE:" LAFITE.READ.LINE.FOR.TOC ATTACHMENT))) + +(RPAQ \LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \LAPARSE.NSMAIL) +) + +(RPAQ? \NSMAIL.SERVER.CACHE ) + +(RPAQ? NSMAIL.NET.HINT ) + +(RPAQ? *NSMAIL-MAX-NOTE-LENGTH* 8000) + +(RPAQ? *NSMAIL-SEND-MAIL-NOTES* ) + +(RPAQ? *NSMAIL-CACHE-TIMEOUT* 14400000) + +(RPAQ? LAFITEDL.EXT "DL") + +(CL:PROCLAIM '(GLOBAL NSMAIL.NET.HINT *NSMAIL-MAX-NOTE-LENGTH* *NSMAIL-SEND-MAIL-NOTES* + *NSMAIL-CACHE-TIMEOUT*)) + +(ADDTOVAR \SYSTEMCACHEVARS \NSMAIL.SERVER.CACHE) +(DEFINEQ + +(\NSMAIL.MESSAGE.P +(LAMBDA (MSG) (* ; "Edited 6-May-88 13:58 by bvm") (AND (STRPOS ":" (fetch (LAFITEMSG FROM) of MSG)) (QUOTE ?))) +) + +(\NSMAIL.MESSAGE.FROM.SELF.P +(LAMBDA (MSG) (* ; "Edited 6-May-88 14:37 by bvm") (* ;; "True if message is from current user. Easy in NS case because we always make the From field be exactly our full name") (STRING-EQUAL (fetch (LAFITEMSG FROM) of MSG) (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*))) +) + +(\NSMAIL.MAKEANSWERFORM +(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 6-Jun-88 14:09 by bvm") (LET ((MSGFIELDS (\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) MSGDESCRIPTORS))) SUBJECT FROM DATE SENDER REPLYTO TO CC ORIGINALREGISTRY OLDFROM NEWTO) (* ; "get the fields from the file") (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) (Subject (SETQ SUBJECT (CADR PAIR))) (Sender (SETQ SENDER (CADR PAIR))) (From (SETQ FROM (CADR PAIR))) (Date (SETQ DATE (CADR PAIR))) (Reply-to (SETQ REPLYTO (CDR PAIR))) (To (SETQ TO (CDR PAIR))) (cc (SETQ CC (CDR PAIR))) NIL)) (* ; "first parse the strings into recipients") (COND (SENDER (* ; "Sender is a mail address, and has the official registry") (SETQ ORIGINALREGISTRY (PARSE.NSNAME SENDER)) (SETQ OLDFROM (AND FROM (\NSMAIL.PARSE FROM ORIGINALREGISTRY)))) (FROM (* ; "Have to parse the From field before we can get its registry") (SETQ ORIGINALREGISTRY (CAR (SETQ OLDFROM (\NSMAIL.PARSE FROM))))) (T (LAB.PROMPTPRINT MAILFOLDER T "Can't reply--no FROM or SENDER field"))) (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\NSMAIL.PARSE REPLYTO ORIGINALREGISTRY))) OLDFROM)) (LAFITE.FILL.IN.ANSWER.FORM SUBJECT FROM DATE NEWTO (CL:SET-DIFFERENCE (COND (REPLYTO (* ; "Only this address, so can only cc to self now") (LIST (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (T (* ; "Take everyone who got the original, removing duplicates, of course.") (NS.REMOVEDUPLICATES (APPEND (AND TO (\NSMAIL.PARSE TO ORIGINALREGISTRY)) (AND CC (\NSMAIL.PARSE CC ORIGINALREGISTRY)))))) NEWTO :TEST (FUNCTION EQUAL.CH.NAMES)) (FUNCTION \NSMAIL.PRINT.NAMES)))) +) +) + + + +(* ; "Utility for handling mail attributes") + + +(PUTPROPS ENVELOPE.ITEM COURIERDEF (\NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM)) +(DEFINEQ + +(\NS.READ.ENVELOPE.ITEM +(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:11 by bvm") (* ;; "Reads a mailing envelope attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE); if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (LET* ((TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (VALUETYPE (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CADR TRIPLE)) (SETQ TYPE (QUOTE (\, (CAR TRIPLE)))) (QUOTE (\, (CADDR TRIPLE)))))))))))) (LIST TYPE (if VALUETYPE then (\WIN STREAM) (* ; "Skip sequence count") (COURIER.READ STREAM PROGRAM VALUETYPE) else (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED)))))) +) + +(\NS.WRITE.ENVELOPE.ITEM +(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:31 by bvm") (* ;;; "Writes a filing attribute value pair to STREAM. ITEM is a list of two elements (TYPE VALUE)") (LET ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COURIER.WRITE STREAM (OR (FIXP TYPE) (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CAR TRIPLE)) (SETQ VALUETYPE (QUOTE (\, (CADDR TRIPLE)))) (QUOTE (\, (CADR TRIPLE))))))) (T (ERROR "Unknown Envelope Item Type" TYPE)))))) NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED)))))) +) +) + +(RPAQQ \NSMAIL.ENVELOPE.ITEM.TYPES + ((Postmark 0 POSTMARK) + (Message-ID 1 MESSAGEID) + (ContentsType 2 LONGCARDINAL) + (CONTENTS.SIZE 3 LONGCARDINAL) + (Originator 4 RNAME) + (TransportProblem 6 PROBLEM) + (RETURN.TO.NAME 7 RNAME) + (Previous-Recipients 8 RNAME.LIST) + (BodyType 17 LONGCARDINAL) + (Status 1000 (INBASKET . STATUS)))) +(DECLARE%: EVAL@COMPILE DOCOPY + +(RPAQQ \NSMAIL.ATTRIBUTES + ((From 4672 NAME.LIST) + (Date 4673 TIME) + (Reply-to 4674 NAME.LIST) + (To 4676 NAME.LIST) + (cc 4677 NAME.LIST) + (Subject 9 STRING) + (Message-ID 4693 MESSAGEID) + (Sender 4705 NAME) + (BodySize 16 LONGCARDINAL) + (BodyType 17 LONGCARDINAL) + (Note 4687 STRING) + (OldLispFormatting 4910 STRING) + (LispFormatting 4911 STRING) + (In-Reply-to 4690 STRING))) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD NSMAILBOX (NSMAILSTREAM NSMAILENVTAIL NSMAILENVELOPES NSMAILLASTINDEX . NSMAILSTATE) + [ACCESSFNS NSMAILBOX ((NSMAILSESSION (fetch STATESESSION + of (fetch NSMAILSTATE + of DATUM))) + (NSMAILFIRSTINDEX (fetch STATEFIRSTNEW + of (fetch NSMAILSTATE + of DATUM]) + +(RECORD NSMAILSTATE (STATESESSION STATEFIRSTNEW STATEOLDLAST STATENAME STATECREDENTIALS + STATEADDRESS STATELASTERROR STATETIMER)) + +(RECORD NSMAILPARSE (NSPSUBJECT NSPRECIPIENTS NSPSTART NSPFORMATTED . NSPFIELDS)) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \NSMAIL.SOCKET 26) + +(RPAQQ \SERIALIZED.FILE.VERSION 2) + +(RPAQQ \SERIALIZED.FILE.VERSIONS (2 3)) + +(RPAQQ \NSMAIL.CTSTANDARD.MESSAGE 0) + +(RPAQQ \NSMAIL.TEXT.BODYTYPE 2) + +(RPAQQ \NSMAIL.EMPTY.BODYTYPE 4) + +(RPAQQ \NSMAIL.REFERENCE.BODYTYPE 4427) + +(RPAQQ MAX.BULK.SEGMENT.LENGTH 32768) + +(RPAQQ \NULL.CACHE.VERIFIER (0 0 0 0)) + + +(CONSTANTS \NSMAIL.SOCKET \SERIALIZED.FILE.VERSION \SERIALIZED.FILE.VERSIONS + \NSMAIL.CTSTANDARD.MESSAGE \NSMAIL.TEXT.BODYTYPE \NSMAIL.EMPTY.BODYTYPE + \NSMAIL.REFERENCE.BODYTYPE MAX.BULK.SEGMENT.LENGTH \NULL.CACHE.VERIFIER) +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \NSMAIL.ATTRIBUTE.TYPE MACRO [ARGS (COND + ((CADR (ASSOC (CAR ARGS) + \NSMAIL.ATTRIBUTES))) + (T (ERROR "Unknown mail attribute" + (CAR ARGS)) + 'IGNOREMACRO]) + +(PUTPROPS \NSMAIL.WRITE.ATTRIBUTE MACRO + [ARGS (LET [(INFO (CDR (ASSOC (CAR (CONSTANTEXPRESSIONP (CADR ARGS))) + \NSMAIL.ATTRIBUTES] + (COND + [INFO (LIST '\NSMAIL.WRITE.ATTRIBUTE.MACRO (CAR ARGS) + (CAR INFO) + (CADDR ARGS) + (KWOTE (CADR INFO] + (T 'IGNOREMACRO]) + +(PUTPROPS \NSMAIL.WRITE.ATTRIBUTE.MACRO MACRO (OPENLAMBDA (STREAM TYPENO VALUE VALUETYPE) + (COURIER.WRITE STREAM TYPENO NIL + 'LONGCARDINAL) + (COURIER.WRITE.SEQUENCE.UNSPECIFIED + STREAM VALUE 'MAILTRANSPORT VALUETYPE))) +) + + +(PUTPROPS \NSMAIL.ATTRIBUTE.TYPE INFO NOEVAL) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS NSMAIL.NET.HINT \NSMAIL.ENVELOPE.ITEM.TYPES \NSMAIL.ATTRIBUTES \NSMAIL.SERVER.CACHE + NSMAILDEBUGFLG NSWIZARDFLG NSMAIL.LEAVE.ATTACHMENTS \NSMAIL.GOOD.BODYTYPES + MAILOBJ.WINDOWOFFSET MAILOBJ.SKIPCHAR \MAILOBJ.IMAGEFNS MAILOBJ.REFERENCE.FIELD + \NSFILING.ATTRIBUTES DEFAULTICONFONT NSPRINT.WATCHERFLG NSMAIL.HEADER.ORDER FILING.TYPES) +) + + +(CL:PROCLAIM '(CL:SPECIAL *RETRIEVAL-ERROR*)) + + +(FILESLOAD (SOURCE) + LAFITEDECLS) + + +(FILESLOAD (LOADCOMP) + CLEARINGHOUSE) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA INBASKET.CALL) +) +(PUTPROPS NSMAIL COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (15176 18023 (\NSMAIL.AUTHENTICATE 15186 . 16404) (\NSMAIL.MAKE.MAILSERVERS 16406 . +17334) (\NSMAIL.LOGIN 17336 . 17562) (NS.FINDMAILBOXES 17564 . 18021)) (18335 59849 (NS.POLLNEWMAIL +18345 . 19228) (NS.OPENMAILBOX 19230 . 21228) (\NSMAIL.CHECK 21230 . 32463) ( +\NSMAIL.FIX.MAILBOX.LOCATIONS 32465 . 36016) (NS.NEXTMESSAGE 36018 . 36929) (\NSMAIL.READ.ENVELOPES +36931 . 38905) (INBASKET.CALL 38907 . 40247) (NS.RETRIEVEMESSAGE 40249 . 45307) (\NSMAIL.RETRIEVE +45309 . 47078) (\NSMAIL.EOF.ON.RETRIEVE 47080 . 47430) (\NSMAIL.READ.SERIALIZED.TREE 47432 . 51396) ( +\NSMAIL.CHECK.SERIALIZED.VERSION 51398 . 51711) (\NSMAIL.READ.SERIALIZED.CONTENT 51713 . 52607) ( +\NSMAIL.DISCARD.SERIALIZED.CONTENT 52609 . 53056) (\NSMAIL.READ.STRING.AS.STREAM 53058 . 53467) ( +\NSMAIL.PRINT.HEADERFIELDS 53469 . 58947) (\NSMAIL.PRINT.NAMES 58949 . 59847)) (59881 61895 ( +\NSMAIL.COURIER.OPEN 59891 . 60094) (\NSMAIL.ERRORHANDLER 60096 . 60518) (\NSMAIL.SIGNAL.ERROR 60520 + . 61893)) (61933 65545 (NS.CLOSEMAILBOX 61943 . 63668) (\NSMAIL.LOGOFF 63670 . 64710) ( +\NSMAIL.CHANGE.STATUS 64712 . 65543)) (65827 72849 (\MAILOBJ.CREATE 65837 . 68062) (\MAILOBJ.TYPE.NAME + 68064 . 68531) (\MAILOBJ.NS.TO.LISP.NAME 68533 . 69884) (\MAILOBJ.DISPLAY 69886 . 70464) ( +\MAILOBJ.GET 70466 . 71289) (\MAILOBJ.IMAGEBOX 71291 . 71496) (\MAILOBJ.PUT 71498 . 72569) ( +\MAILOBJ.INIT 72571 . 72847)) (72850 98554 (\MAILOBJ.BUTTONEVENTFN 72860 . 77169) (\MAILOBJ.DO.COMMAND + 77171 . 77418) (\MAILOBJ.HARDCOPY 77420 . 81186) (\MAILOBJ.FB 81188 . 81466) (\MAILOBJ.PUT.FILE 81468 + . 84817) (\MAILOBJ.VIEW 84819 . 90235) (\MAILOBJ.MUNGE.NAME 90237 . 90501) (\MAILOBJ.COPY.BODY 90503 + . 90817) (\MAILOBJ.EXPAND 90819 . 94981) (\MAILOBJ.COPY.CHILD 94983 . 96340) (\MAILOBJ.COPY.SEQUENCE +96342 . 96710) (\MAILOBJ.EXTRACT.TEXT 96712 . 97773) (\MAILOBJ.PARSE.ATTRIBUTES 97775 . 98552)) (99976 + 122547 (\NSMAIL.SEND.PARSE 99986 . 101938) (\NSMAIL.PARSE.REFERENCE 101940 . 103858) ( +\NSMAIL.EXPAND.DL 103860 . 104927) (\NSMAIL.PARSE 104929 . 105190) (\NSMAIL.PARSE1 105192 . 105760) ( +NS.REMOVEDUPLICATES 105762 . 105900) (\NSMAIL.SEND 105902 . 112999) (\NSMAIL.PREPARE.ATTACHMENT 113001 + . 115686) (\NSMAIL.GUESS.FILE.TYPE 115688 . 116189) (\NSMAIL.SEND.MESSAGE.CONTENT 116191 . 119224) ( +COURIER.WRITE.STREAM.UNSPECIFIED 119226 . 120370) (\NSMAIL.SEND.STREAM.AS.STRING 120372 . 120992) ( +\NSMAIL.WRITE.ATTRIBUTE 120994 . 121619) (\NSMAIL.FINDSERVER 121621 . 122285) (\NSMAIL.CHECKSERVER +122287 . 122545)) (123769 125868 (\NSMAIL.MESSAGE.P 123779 . 123917) (\NSMAIL.MESSAGE.FROM.SELF.P +123919 . 124240) (\NSMAIL.MAKEANSWERFORM 124242 . 125866)) (126016 127515 (\NS.READ.ENVELOPE.ITEM +126026 . 126783) (\NS.WRITE.ENVELOPE.ITEM 126785 . 127513))))) +STOP diff --git a/internal/envos/NSMAIL.TEDIT b/internal/envos/NSMAIL.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..28f66464ed309b616f580aedb9dc05147f3fe23a GIT binary patch literal 7187 zcmeHLPmCK^8K2#zB_XleEJ*ZF&|^u7jkZ>@UD7n5g1h!^+RN5$&&X-ErGk)Q@+3t5c^}Wr0v(qm1M_P?T zH}$nLOv)Qid_C4d5~~D@lPF9=C-m_YD% zfmYXa6yAhXwPSmJRjF2JgA*c$-u$#`YqPV1wSK6gG{CACD=$#3S>!ouY8IwyoW_Y7 z*^uXBKhJ`MmKRUtMZNNK~)XIi1vh0Vh4!`@Pd6D0Q%TY zyfCQX?B-Aoa>L+kc2c{SNi#`!U(C}2X zl*tzT2VpW&+mSud2VS7XSBG6LI>ni#1^Z*2WL`fjCX4giJtz+^7=7sH(1k8>IzV*B zDh*s61=_};CSch5TG${l-qG-cV=TJ^JK&?s?mfCCoPBy6?q_ zj$j*vH z4W-r8OGayw5BjFf3|~`MJUyL+UXU;c0+?pIYk6+xNo;BW#o*!0g%V;otg$C?O8H1y z>VSN(1068$mlALDQN_W)lx_yGxzP1YVTVF_Fkc;h~LY0Th`kvD`&py-nv!TwX$;TO#P!1hbb=?DXS}I z-1@Bo<(;?Q|KqRfH;ykP8+D2r{%e$@nJ}m1i01g7^8!*n_FMx%S-!K*Py{moGof;j zCP^3=BxBiz0t2W5BxsPDB0!4Ag1|sn<%UwKlJkptL*DmM1kNb*92DDu9nF;OIAP>U zeT1fzW)mJzsEbRb6D)Gp9P8{vpY3H3$${wvN}#-4G&G>cbmTcB7OIQZ;@h*V(M0wX zco`%>fV^TCT2ZbYJD#ToGhhIe?4}03f-rcjup)>RX~=ch8fGd;ebZ2ZrYSIy6>h_0 z=9GOq8UPL;uNRJsu!G~^L%0-xw(kuFI`U$m8l0?RaIOLSVFa|ALmT|*q^6k@YMZbm znnZvbASJ;(UK8^O(J|mk;8!4v2SH!Z={cx!m4TK1oHe_wJ=rr(0rmhb9q{LBhY2wq zX_ypcQH3Zj5gccb07M(6k*rI$i1BlL$5G{87)7%+dIeh%6M+4~B8ciYTJm3+|(Jm{q)qG%oh7=Q&{^X*@FrjnFg0 z$lLb<%m%Z$D3`3@VxMQh%mY#_o#=7)gO7GmT8M}7aXu44!!Up#`v5y7PsHPM7iKM< z3CC=sVVKUOkb|QM3kT5Qx$vWboERNcc@Yk}3tbq1p&9f=5nu!wLR1>Xx?r{d?rH00f0$7s{2t=Tw_L18R&1?-!rd;u56dHG zWKFRi$$BRBj-|?W9H(RIPhT6ziUDPg_6|%3wgcnJ>@JHXZ{jh@88X*%(NeO@AgXBs zagY>+=|0-4k++ZjfYh#3OEA{zi$ReX=Rs{6okA^A0vP8*d4*pzb_|*WewsyIy1|&j zUEE<~hlkaDtQe!|m=LDYja*IepE4+m@_Aw+(qo~}UFNyy+7x`ot<^hLX{XuSY_wXn z_Vs+I!(@P4n)nQ`hN8yZ&SM)L;+BP3O!=Mxyy#yMQwR{? zU;s0{7SKa6W+JGTu8wdE22x^Dz#AAe{VW$nB@rZ7S}gk^y0OAwg?nf+gG1WrkSuQu z3evPA3SpK`QR3NU8)(ALFEU&`v{OHsvl#5m0nIc~PQ1KSC%f85gcnDaLJcHi8&}&wpwD$C}0?A-ezSm7<)I5ya1UG6yh3Uv6QQ6gZWHC zn8}kwt6C6Gr8}6HF1C+4M12yLP49+UK;Q))Wz!9sIQB_T%oEm0BfOQs4IBZ0)jf22 zGX*6;Nf?Gfl1JGEwKI%k^Fxa$#*gVn>>Q?ij{!S4J>dlbr?wj2qnLgZCw7wJEtR=? zWXi{*aB9X;u|DIGxe3Kb*W9IPNiLK3m0QhTUzN+dwe5y#H(RQ_)oC?5&GuGDm22JF z)6LC_>h){gezUzzrmv{;6;(c`&Z!IM*VPkGuH(tF(5^d%+wieEx|I z_4oy~e(@r{DpVZA%Z*wcMjA7+hyHbn-fOq9KoZz4Zm1_VHq-|G7JK`RYkk=$E(FVy z7u3erFQ^OW&KdC)?40{pnEqE>2*uYguB#0Md%a-s|Go9G3HRUeR;41uF}?-sFJXAN=cmk-e8cj6pTPHu^~%yk909?f$XApH1@7@FTSgw2k1gMu zuTBQ&Cm$NLwDj(hd9qHjq_Rx3P8RAkTQ7bcv+lP(Z#`hp#rmvSTDFeTu(IIG-lyHg zM-Q0Kigm2j+3r{m=LGp)79ZWu-~1=a(!S4-0!i|pLYA?1@^W{t)u?Va`djU#!oit> z!YvZ=jTHHx-N>8}-A!^VTm1ec6&6m*tj{<8Gu`jGk?xa@Wg@?9F%P~6;@qF)`0y}6 z1j5qy4{=z3J49IeX^}va zo;pOZp2-P6q^XoX$tfgIk>BMj;^kZct`GyV_w~kODG5c6KOZ72efJRIb01jW`oZu2 E0mJsBeElocal>lde>lispcore>internal>library>READINTERPRESS.;2 16698 + + changes to%: (VARS READINTERPRESSCOMS) + + previous date%: " 5-Jan-89 17:42:57" +{DSK}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") (SEARCHIPLIST CODE (CONSTANT (for OP DOTLOC in OPERATORS collect (* Strip off extension) (COND ((SETQ DOTLOC (STRPOS "." (CAR OP))) (LIST (SUBATOM (CAR OP) 1 (SUB1 DOTLOC)) (CADR OP))) (T OP]) + +(SHORTINT [LAMBDA BYTES (* rmk%: "19-APR-83 17:34") (for I (RESULT _ 0) from 1 to BYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8) (ARG BYTES I))) finally (RETURN (IDIFFERENCE RESULT 4000]) + +(TOKENFORMAT [LAMBDA (BYTE) (* rmk%: "19-APR-83 17:41") (SELECTQ (LRSH BYTE 7) (0 'SHORTINT) (SELECT (LOGAND (LRSH BYTE 5) 3) (0 'SHORTOP) (1 'LONGOP) (2 'SHORTSEQUENCE) (3 'LONGSEQUENCE) (SHOULDNT]) + +(FINDSEQUENCETYPE [LAMBDA (CODE) (* rmk%: "15-Mar-84 09:04") (for X in (CONSTANT SEQUENCETYPES) when (EQ CODE (CADR X)) do (RETURN (CAR X)) finally (RETURN (LIST CODE 'NOT-A-SEQUENCE-TYPE]) + +(PRINTTOKEN [LAMBDA (ISTREAM OSTREAM) (* hdj "15-Jul-86 21:55") (PROG (CODE BYTE2 (BYTE1 (BIN.RIP ISTREAM OSTREAM))) (SELECTQ (TOKENFORMAT BYTE1) (SHORTINT (SETQ BYTE2 (BIN.RIP ISTREAM OSTREAM)) (printout OSTREAM .TAB 20) (PRINT (SHORTINT BYTE1 BYTE2) OSTREAM)) (SHORTOP (SETQ CODE (LOGAND BYTE1 31)) (printout OSTREAM .TAB 20) (printout OSTREAM (OR (FINDOPNAME CODE) (FINDNONPRIMNAME CODE) (CONCAT CODE "not an opcode")) T)) (LONGOP (SETQ CODE (IPLUS (LLSH (LOGAND BYTE1 31) 8) (BIN.RIP ISTREAM OSTREAM))) (printout OSTREAM .TAB 20) (printout OSTREAM (OR (FINDOPNAME CODE) (FINDNONPRIMNAME CODE) (CONCAT CODE "not an opcode")) T)) (SHORTSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31)) (BIN.RIP ISTREAM OSTREAM))) (LONGSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31 )) (LOGOR (LLSH (BIN.RIP ISTREAM OSTREAM) 16) (LLSH (BIN.RIP ISTREAM OSTREAM) 8) (BIN.RIP ISTREAM OSTREAM)))) (SHOULDNT]) + +(PRINTSEQUENCE [LAMBDA (ISTREAM OUTSTREAM TYPE LENGTH) (* ; "Edited 5-Jan-89 11:13 by jds") (SELECTQ TYPE (SEQIDENTIFIER (printout OUTSTREAM 20 "ID: ") (CHARSET ISTREAM 0) (bind (CHARSET _ 0) until (ILEQ LENGTH 0) do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH) OUTSTREAM))) (SEQINTEGER (PROG ((NUM (READINT.IP ISTREAM OUTSTREAM LENGTH))) (printout OUTSTREAM 20 NUM))) (SEQRATIONAL (PROG [(NUM (READINT.IP ISTREAM OUTSTREAM (LRSH LENGTH 1))) (DENOM (READINT.IP ISTREAM OUTSTREAM (LRSH LENGTH 1] (printout OUTSTREAM 20 NUM "/" DENOM " = " (FQUOTIENT NUM DENOM)))) (SEQSTRING (printout OUTSTREAM 20 "STR[" LENGTH "] = %"") (CHARSET ISTREAM 0) (bind (CHARSET _ 0) until (ILEQ LENGTH 0) do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH) OUTSTREAM)) (printout OUTSTREAM '%")) (SEQCOMMENT (for I from 1 to LENGTH first (printout OUTSTREAM 20 "Comment vector of " LENGTH " bytes" 22) do (printout OUTSTREAM |.I4| (BIN ISTREAM)))) (SEQPACKEDPIXELVECTOR (bind YBYTES (I _ 5) (XBITS _ (READINT.IP ISTREAM OUTSTREAM 2)) (YBITS _ (READINT.IP ISTREAM OUTSTREAM 2)) first (printout OUTSTREAM 20 "Packed pixel" " vector of " LENGTH " bytes [" XBITS "X" YBITS "]") (SETQ YBYTES (UNFOLD (FOLDHI YBITS BITSPERWORD) BYTESPERWORD)) (* ;  "The number of bytes on a line is always even--gets to a word boundary") while (ILEQ I LENGTH) do (printout OUTSTREAM T 10) (for J from 1 to YBYTES do (printout OUTSTREAM |.I8.-2.T| (BIN ISTREAM )) (add I 1)))) (SEQLARGEVECTOR (for I VAL (BYTESPERELT _ (BIN ISTREAM)) from 2 to LENGTH first (printout OUTSTREAM 20 "Large vector of " BYTESPERELT " bytes per element") do (SETQ VAL (READINT.IP ISTREAM OUTSTREAM BYTESPERELT)) (printout OUTSTREAM 22 |.I5| I ": " VAL))) (SEQCONTINUED (HELP "Can't handle SEQCONTINUED yet")) (SEQINSERTFILE (HELP "Can't handle SEQINSERTFILE yet")) (SEQCOMPRESSPIXELVECTOR (HELP "Can't handle SEQCOMPRESSPIXELVECTOR yet")) (SHOULDNT)) (TERPRI OUTSTREAM]) + +(SEARCHIPLIST [LAMBDA (CODE IPLIST) (* rmk%: "15-Mar-84 09:15") (for X in IPLIST when (EQ CODE (CADR X)) do (RETURN (CAR X]) + +(READINT.IP [LAMBDA (ISTREAM OSTREAM NBYTES) (* ; "Edited 31-Mar-88 16:56 by jds") (* ;; "Read an integer (of NBYTES length), printing out byte values as you go.") (for I (RESULT _ 0) from 1 to NBYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8) (BIN.RIP ISTREAM OSTREAM))) finally (RETURN (SIGNED RESULT (UNFOLD NBYTES BITSPERBYTE]) + +(SHOWFILE [LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES) (* rmk%: "16-Jun-84 15:29") (OR MAXZEROLINES (SETQ MAXZEROLINES 5)) (RESETLST (PROG (STREAM) [RESETSAVE (SETQ STREAM (OPENFILE IPFILE 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (SETQ STREAM (GETSTREAM STREAM)) (* Don't do an OPENSTREAM until (OPENP stream) is NIL if stream is closed.) (RESETSAVE (OUTPUT)) [RESETSAVE (SETQ OUTPUTFILE (OPENFILE OUTPUTFILE 'OUTPUT)) '(PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE] (OUTPUT OUTPUTFILE) (printout NIL .FONT DEFAULTFONT (OPENP STREAM 'INPUT) T T) [for I B1 B2 B3 B4 B5 B6 B7 B8 (NZEROLINES _ 0) from 1 by 8 until (\EOFP STREAM) do (printout NIL |.I5| I %,,) (SETQ B1 (SHOWBYTE STREAM)) (SETQ B2 (SHOWBYTE STREAM)) (SETQ B3 (SHOWBYTE STREAM)) (SETQ B4 (SHOWBYTE STREAM)) (printout NIL %,,) (SETQ B5 (SHOWBYTE STREAM)) (SETQ B6 (SHOWBYTE STREAM)) (SETQ B7 (SHOWBYTE STREAM)) (SETQ B8 (SHOWBYTE STREAM)) (TAB 23) (COND (B1 (printout NIL |.I4| B1))) (COND (B2 (printout NIL |.I4| B2))) (COND (B3 (printout NIL |.I4| B3))) (COND (B4 (printout NIL |.I4| B4))) (printout NIL %,,) (COND (B5 (printout NIL |.I4| B5))) (COND (B6 (printout NIL |.I4| B6))) (COND (B7 (printout NIL |.I4| B7))) (COND (B8 (printout NIL |.I4| B8 T] (RETURN (LIST (CLOSEF IPFILE) (CLOSEF OUTPUTFILE]) + +(SHOWBYTE [LAMBDA (STREAM) (* rmk%: "13-JUL-82 18:01") (PROG [(BYTE (COND ((NOT (\EOFP STREAM)) (\BIN STREAM] [COND (BYTE (PRIN1 (COND ((AND (IGEQ BYTE (CHARCODE SPACE)) (ILESSP BYTE (CHARCODE DEL)) (NEQ BYTE 96)) (CHARACTER BYTE)) (T '%.] (RETURN BYTE]) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS BIN.RIP MACRO [ARGS (LET ((ISTREAM (CAR ARGS)) + (OSTREAM (CADR ARGS))) + `(LET [(C (BIN ,ISTREAM] + (COND + ((IGREATERP (POSITION ,OSTREAM) + 15) + (printout ,OSTREAM 5 "|" 8))) + (printout ,OSTREAM |.I3| C " ") + C]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + INTERPRESS) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA SHORTINT TOKEN) +) +(PUTPROPS READINTERPRESS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1249 2653 (PRINTMASTER 1259 . 2651)) (2654 15701 (OPCODE 2664 . 2896) (TOKEN 2898 . +4148) (FINDNONPRIMNAME 4150 . 4311) (FINDOPNAME 4313 . 5063) (SHORTINT 5065 . 5415) (TOKENFORMAT 5417 + . 5788) (FINDSEQUENCETYPE 5790 . 6064) (PRINTTOKEN 6066 . 8120) (PRINTSEQUENCE 8122 . 11193) ( +SEARCHIPLIST 11195 . 11386) (READINT.IP 11388 . 11965) (SHOWFILE 11967 . 15155) (SHOWBYTE 15157 . +15699))))) +STOP diff --git a/internal/envos/RS232TEST b/internal/envos/RS232TEST new file mode 100644 index 00000000..52a236df --- /dev/null +++ b/internal/envos/RS232TEST @@ -0,0 +1,242 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "26-Jun-90 19:15:35" |{DSK}local>lde>lispcore>internal>library>RS232TEST.;2| 9419 + + |changes| |to:| (VARS RS232TESTCOMS) + + |previous| |date:| "20-Feb-87 00:10:14" +|{DSK}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 diff --git a/internal/envos/SKETCHCOLOR b/internal/envos/SKETCHCOLOR new file mode 100644 index 00000000..13f0d549 --- /dev/null +++ b/internal/envos/SKETCHCOLOR @@ -0,0 +1,105 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "26-Jun-90 19:20:18" {DSK}local>lde>lispcore>internal>library>SKETCHCOLOR.;2 4982 + + changes to%: (VARS SKETCHCOLORCOMS) + + previous date%: " 9-Jan-87 16:47:16" +{DSK}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 diff --git a/internal/envos/SOURCELOOKUP b/internal/envos/SOURCELOOKUP new file mode 100644 index 00000000..ad96c1b0 --- /dev/null +++ b/internal/envos/SOURCELOOKUP @@ -0,0 +1,109 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") +(FILECREATED "26-Mar-87 09:52:19" {ERIS}LIBRARY>INTERNAL>SOURCELOOKUP.;1 5861 + + previous date%: "21-Jan-86 09:49:57" {ERIS}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 diff --git a/internal/envos/SOURCELOOKUP.TEDIT b/internal/envos/SOURCELOOKUP.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..7b6764e5e0c1b8313615832dfe77e5960f77807c GIT binary patch literal 2486 zcmbVMOK;mo5M~^wkF<-Xk3&%)!5}%rz6ePlm-bKy5*-ntMU|A$KWV{&7qh!k1d?gL6 zRnb%eHd>v@LKxt%7Ws-a<#B!;* zzJNmI&05qH4vWo%ujt$FC`S?|!Yf^oM=DC8MU5(*^19*G02qst;W(PUfcYeZQxrcA z8OwTY!A##aQe$Gjp5aDgt5$sJA!*T3pqbc(yuMe2LN);API-P#Adf{24Zu z^12M?a>2rIuBcBOG>(m01J83|XdcdFjtzpja_!&E6&+6EWHx(^^1CuhRaNR-)^C1f z>?jN8zw8$N^yqhw|KqwUkB@2G1zf7;()Za%bs^s2^q~xw%5lJsS{!X`CzlDae29Eg4iMpQ#e^n zw|mQu;$$?OhlAGCtr=DsA>sbg(cto(ruMgaqh)Oks0L>SBl8Wu256(jciZmD>a9E- zwXlt@ec2u8Clm=4+44Q^5~-ENEpO`Lv777GcN)c1U-)WxI*Y>$`+Bvor_|_U*Se0( z_5Sibq0*dQ^e)9QK5=0>+rC@<_hF|aPktC+uq_x>+Yh{$j>D5^8jg=ycZ9Bv0mIy} zGmJs|^XGtm_kz2@kvnbw4i5WYJLg^8ot?Y>$1d(}|7!1i7#s#)1s~vR6QUJ(A!fZ z`kx7UBiZ*iBB<8CZbV$G2qTxVAMCc0qu(he&XLKOTUWuQyke1g)?053v iRYaG*8^1o(rP4R-k^K*YTe$y5>d^Ri?`local>lde>lispcore>internal>library>STACKHACK.;2| 2119 + + |changes| |to:| (VARS STACKHACKCOMS) + + |previous| |date:| "11-May-88 11:28:17" +|{DSK}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 diff --git a/internal/envos/TEDITCOLOR b/internal/envos/TEDITCOLOR new file mode 100644 index 00000000..57f1b917 --- /dev/null +++ b/internal/envos/TEDITCOLOR @@ -0,0 +1,401 @@ +(FILECREATED "26-Feb-86 10:59:11" {ERIS}LIBRARY>TEDITCOLOR.;3 26648 + + changes to: (VARS TEDITCOLORCOMS) + + previous date: "26-Feb-86 10:44:36" {ERIS}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 diff --git a/internal/envos/USPS b/internal/envos/USPS new file mode 100644 index 00000000..a3333d9b --- /dev/null +++ b/internal/envos/USPS @@ -0,0 +1,194 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "26-Jun-90 19:31:43" |{DSK}local>lde>lispcore>internal>library>USPS.;2| 9175 + + |changes| |to:| (VARS USPSCOMS) + + |previous| |date:| "13-Feb-89 13:49:35" |{DSK}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 diff --git a/internal/envos/datepatch b/internal/envos/datepatch new file mode 100644 index 00000000..bfd5118f --- /dev/null +++ b/internal/envos/datepatch @@ -0,0 +1,97 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 13:42:42" {DSK}local>lde>lispcore>internal>library>datepatch.;2 17784 + + changes to%: (VARS DATEPATCHCOMS) + + previous date%: "30-May-89 12:29:12" {DSK}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 (* ; "Daymonthyear") (\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 diff --git a/internal/envos/datepatch.tedit b/internal/envos/datepatch.tedit new file mode 100644 index 0000000000000000000000000000000000000000..e5a565ed774dddbf798cd412fc1636550e2a6794 GIT binary patch literal 6691 zcmeHKTW{mm5th80G-|5!UKA)$Ocex>8ddipmmg6Dx_TNNsjE$OA1=78{Bb zc(JVw`dlFBYkx!kLtpxupVe=MJV%nf&L(*aP#dBS=gfV+nR9elt?pN=-L_*4+fL`4 zUkV_+>rWS5O~!(ma=Ls-M_r>;^?L|i588uD9!vEFQFt_cyy6nCgg@w z@@`TuoFLJL+LwWsre6H_KQ?QS zN|I~=9(FzPD2?dCW6KkNwqml2z*o%1LD%|GD6f5YMf*+Ke{%e!wjBs-;POPXnLl9{ zbjXEPf8uh$iA3xMNkp+Xi7rF`H77b;u^m3SZ)K@P#?R3$V) zzAll6B=9fiX|Q@)U9(p{d+x@*dl7h_SKCN)l0@)^4d;q;WnSPdyfB5`m^~J|lA}7@ zPrMYaU2?T(nxy>QU@tu3m2E$VVwf#1fE*~8M_HWEwFlSncGh>O9!3CLI)~5c+(*<| z2n%TzqJ#kw3l-6F86`fr5P5fI6c3l#nWdU$=fze(?lx*WZQOO2!5Hc(z@07S#f-%twQAFX*X5J)aV9Yj^ zMhhQKA`mzsMMfqe5HbXofGtXqmk1fkQzqu1@QucDr=_`}1u_$W0r1NJ6ZayCf($v; z4cfYFHR$%?dzmqgscW3J$32GwVWj$#IpF6J|YrV;uRU?xbUE^6Wmj+&cB*&4Dx{S*1K+w_6iYf>HvT*=}vA&?j?+!r)) zQMEdcnG}IuyQ_qI9Ho+BZDr{)OE+dU#v0(BP+iY~pIxBCTmGG>q;BV9;1Ci*PO&^d@=jh^j+ zSO_N>x;#c~H1n=8%>jLO{nQ%u+fGr+M7q=M64GGu%!vTqa(VibP5}3!m1m zkUea744Vd4i=%8b02SbbRGw=Gdvxku#2FuP$B%I$s5p#v*Ssf`jtivZ^HW?ej-Eni zfz<0Lp5j14Z|9lE9FR$sgA*l@<7yTKL39mtUtkybTrAx05Mb^jZG`*MXpf`@_eZS5 zJ=l|Dkb_n#3Wfe+8Tg2>NFEPZKb-p)KDu`>?w=T=mUY_7%~m_+bF*i*2a@17mfn^# znHBCI?D9F21C&eXxws_E=-@D?*VT2SAuQh}6Lq^)GsExk2-Igsnq|aAAg>-RREFp<<`x8tfALv~U z38pnh#qmRui)KC-INVL!2Vn2EUozT0HH>E!Gn@n&<{vjxkr1l$*j+9mi31|fCvMuj z&1K7v09;l=oD^IwzAN%@7QOblHFCs_N4xpe631_GP2~$0Co^~2?zQc6!>-sK)bLcs z7rFsfqyqT6^{F>= zvjFwu!;*i8Ox3kh?s3KOR118dow8+(@A3{GV)+RzsLdyv^r>8zwmS^Gs4wo={(Wed z(`O6qJbKq?-`uA<+re)HKg5*>{Z}08P5G%IVAq|TYbY3y(Jj9!YP4)1UQHD?2!4Ic zX&C8qQiYUX@LSaq|2?SpOdHqW`mlXw$cc~D&=}d~D}#E5;}|14wR)yy4o)qqw@2+0 zvqLr9ifRqAo%YDV0m8B$($QXn?@xPlw0}U4pB&(=?ieo|(aLv;`tcz>IikZ)j=&3M z&>EOr-^cV_OX8#oVASqe)-#*xe;v2G)G-DK!{|1sbKV{mJNB5P?2OEz1DDOgbJI3Y zdInjir(_#FqvH$_vm@`rk>!A3bn{(K%|4FQcHiv1#HrFXMgy{*8>5~%C=@s&^O<3d zbMf&29D2`qF>DWP(;CpoI2-rcBeHwe(9mz68s^!#Lw%!bj{EGGF;bStwlR`Aa5in{ zCEVp4qCk90c|(Perv1l<^yr8Vj*sz`=bZju7OwISvMh~;wCy{kO6drz8+?9*&(4E~ zc$9*&P=sakQFioOv$Ti*Qt8L|ly@NY4S&tjZ}IbIM(-nLEq^VZm)Y}j`Rj5n zzV+O2ds9S$eY;4ru<~t zP`-y>D#3|hJKtOIJ%}?FN;$-KN=(=(y}^YdG3(HPhfTqIU3i-yH^#@T=^cK+IJ+|7 zB@@IiMg>ZdQ-qBvvfziNXdb0Tyk$4VRpBcPFx*5?377w&D3T90@R6dhI!?9T5xq(s zvmPo|sR;X_EpmL~{ap&@Oq|eC|56k!r8R4c&W)zLR8l%y`-;M**}-2cf{sCWRSfL$ zKbeJjRrXYBO8;dVzsW8?bfz_rjz#m-l$6q^tDy+LR2gLfI`u%MdiBYV=AmfnRTwFQcWaXWosT~bGw!=H`tDP-y z@eY5svv7w+`=&Fd)Cwv%u%6PQcC^fgYDWw)uVT@0JW(uaN1B6K??m_uX62o~@nWlZ zQX!_W76#=X^5sT|O24-Jm|2tzJE-%trHyyQ{VjuA;Nxu_^PQc-@CVh>zhD37e;+Z) AbpQYW literal 0 HcmV?d00001 diff --git a/internal/envos/filebanger.tedit b/internal/envos/filebanger.tedit new file mode 100644 index 0000000000000000000000000000000000000000..6d5132c1cb3c3376d260994ca0e4a4853657ee0b GIT binary patch literal 4686 zcmd5<&yOQV74~kjgdb@X1tkPd1qh8Na;zm13erX^d1pMkX1y~L+sZ1(cDveLns!yI zt9!go6#fFlzX0L_2aa&z&Xp4f{s{gEzOSmw?y;Ta%1ARVSG{`gd+&Yky_$>Bc=%*+ z`E)pmq6?MFg@~>AN|wrg{b{ajk(g3GR=SdSdLQOY@|Z@y%&8 zt>Ut>A{JV%MGA9b?(7Mrg~EYZYf+RYk=FKwm}OEdY=(cR(X#)9KHfBREXsY(TbN6F7 z06;3{%o29=!mRtz%m}2u*rE@)Y7*3gcT%k4jp#lfjmQ1#$<^6#Iu$27E}Zt5&0DoV z#4AEFI^V#K1xDn)9Yvr42X=vox;r&s0sCK-a3Ma~ClmodqcF;^&e@i5o`qNG4jzD`Jv$i;w{U1DSFiuOv;z z-qY?n;P>lW<5ZKw@gJ^N}Dw_6W&4t>=87BCZ2%=?Bc^V1RgDM%?7qZkB99% zFKf+)f!f)bZ3y0T&XsbBOqXId`yyzkR{Gu0d26l9Uen-l(6xl`bNLf`<*L)C=HzI_ z`x0$&7gWk&W4~0LX$BNY<+nCys$~AVMGVla7 z&6L@S;Uk^tGzl*325DXO1n-fyzO8P=^a_kE5}x!r=_|@r@;E^dU!dV zO@@OPY__^-Z=^Kg$pvH86k|xEljA8tF#1Xtb>%BB6s%X)7BY1ODX4o1iW+@V!J)*g z0E#`uRZzou7D9mAkDdZW={+yd)m+6>epe|w{<<1n8nY0&A6VUAK79DFDH{M?VO*jH z;Wlc$c9R7x4RJ&z6bLdBQ)APhj&IS}dAd;cM%OG}h7Rl0-j60B@<4PIX4c;LKiO{v!o?D!<}{kIZMfOR45JeqDaTe^ zwu6SO_a$W6e=tUth9qk0rx}2*AC&Tu z#W+LYoD^lze+th?hQ0+BZlpDUbfv-xlD#QFzKkTGArKz-e?_!z{WHChGFcA3bGm6A*sVhijdmW%d98p_%{z{4-YIc#YZ^;lD9nU zM`Lv((Kd!>-8u#*X!)4AK z6bNU_Vn6zPI2m1h(E?2%9~FEy91vRfvRP=Q+m2E()NU{ zIW;OVy1EX&p|>GOzi>T-tB;ZOG=*L0=1WApdi5%rtxYpC8XH-Bi~j~B+5*}e`d<>` zC69)>h8O7iFgtBbg?MvvBPuJPs5PD){ypI7mLl3_&BsQ8|2S0QhX10(^m0#9{)1ug zj6xOwJOE}5H3I+;d(OOfpmnm@Z16PxKSJN(&x6ieoh}#m{?+*wKkvWEzej(9+`Bw| zjaJLo`JnRwq~GAT|0x|XxT~+h;N+YT{@lM8RtKMV^*Ia& zGGXIQMC-lITW90JbUHeNlkVq!=g1}u9!f&|2b~8`2WQU)o$m&voga3-^K3Z&d^j7O z4LaZ7>g3`+lGE{`53q1v`1JUbgN;vk%RAvEe$?Jze(zj4*r1hnc*TjqK0h5MD*Z7} z;I8}KnxV*yClvV}7Zmx73+{MQVe!wfL!X??Ps0wsQq6DnH=?ldD=vJ2@gF{@lJo2^YCwg%ZEtmk``&OZ;(P;%EC3zuT91xG(YBMk4x8=d&;W{$KG^ B1*`x7 literal 0 HcmV?d00001 diff --git a/internal/envos/internal-library-readme.tedit b/internal/envos/internal-library-readme.tedit new file mode 100644 index 00000000..4884ff2c --- /dev/null +++ b/internal/envos/internal-library-readme.tedit @@ -0,0 +1,3 @@ +Files in this directory /usr/local/lde/iternal/ +where copied from {eris}internal>library> +31-Jan-90 diff --git a/internal/envos/unixmail.tedit b/internal/envos/unixmail.tedit new file mode 100644 index 0000000000000000000000000000000000000000..d0edeeb240c9d6a45491baa0396d7749e57ec954 GIT binary patch literal 7709 zcmeHI%Wm676dfwg!?jtUZ60la0<$Tg0D^$@0Tfw9wpE*eL>sc?1}IQ~mPR&ViZn<{ ziGnP;PEnw%enEF#chgO``GVvd@)x~ls7q0dWTjnnH3Up@&YXMBy@#ZHqQbG-?77a9 zcEf4eU)uK9w*AnybA;{**_l3)awj^KJ6@<{73cbB@>qqFD5*bDarCU-k46t{$L)3w z_j4-sj5rqq?(#! zRTJNnz0iLq&!Z$w>SL{Dpa?zy}dPGzKLrjW;=<%T0+4wHaMz$9Q2FbS9hOadkWlYmLU zBw!LS377;-0ww{IfJvZ~z;&@HYGPY#Td#ygdsbzm#8_N@gC%iq;&P3+6}nolP`di4 zVT+5_7%+E>N-FQk{YZ1K!DZ!96EDR}>s!6QUN__3AofP({dG6i^m_nz%0V9puaMl< zQDeV(&}{5E?!MUS^jw#2u+G@;oHyvf-4(aG%}(2K8!hoc#-PV>N8H?PHI9#+UGZrK z(ge4~jrQSQv*R*R{Isl``1i!-L9=zz>^i%RoV-MUoaUn2x%(WObwoRJ42jN<3e6zI zbpWKM-#?826}NCA9E%F=Z5?!at!90{+5OJ73X*f1nF1H$`u`TcG!mQF?9v{7B^m)?(N&T5}K6tO+Vuyh%sn(xmD!$O=su0quxv_r6@c9s1 zXvM(|JEIlNWq=yBbQTPNakp54QT{FhVB80=bkMX+E!zpd%y`G{t0Lpdu*45VD&Fl+ z7|@RZap?Gpmsn)xG@6lz&n4qFj@=vfAgjVhuXhR1OY6{-!SMU@os%i@DZh zjG7;dH30IaZS27CHEy^AP#%;4{ojijF#e1gs|WpsDLNGR;QP=%P|(gNjBx0mGq76s z_XP?x^Dipb{hm3PMmtp*VW;)4gmuI<_gF;CeP5P=uMxZFVW}Ne&-A+S!5E~5Pyc>oH;+=`DRAm`1O#YB+JufkVhuT zXlha-XV@WczKneyqq`{0mwrq$KMg62vRm?#kW!5y;HI%zEY`(%5a=v(@Yizb+`rY7 zEmKW?9Fv(+KGT$#bT0Eea=V?uIZdNjXXFDF8$Z+`<%ZH_0?XcsLqrWceAmC|4!%3& zF}Zk`UAcGrqv2WmN}gYNS1$+c%Wl);uTpBKOIv;fhBO7;=Y|@ZMcY3q-%fVob z^ooJN%;%i9Rg{Eg1vAfG>f59sE}9sVXJl><8JtjNo&WZAe`A0huNdJ-onx0S%!*bT zrjh8mji6pMt}NTYYFHgpd#Rbz8FEOWkuOsd#|Hl0oS=Z$oO!o%>9xn6i;VaBXC6J` zF{J$!9Y1OE;xI!GA3kgxzyMNs--9^H7E)eWQ6?d+!Hj@Qw4cUndP)u^vyHjF@h9sX zRG36JbY!Ct@~q7g%)8U16SKUT*@R~cKhRCbdEwHf=G2vuQA2WG-E&-_fLrP0kSx1J{c+$KoeEi+a|zs!&unbH|t^!neFTxiOw5 zK*Xx~Ucr~nV0cCClLPkv{?vR4U}XUt8g|)6jDNN~#kKTochxD-ae<%0Ya_l)F~*h_ z@Q`O3Ts?KEx~i!h`0=+*Ye{EJnZcZLD9L&IqPuObFI>6;ak!-uG>1@RgGN26p+(;y zI4FN)b*)L0beP~SxX6atM5fys|L!YJC9-euUP*IQ2ten`9N zA9Mh2JiVr~LA%>{GwkppqKD0bDXcpgONUG-n;9a+|V7Fz*=vGb3w8zXQ0Eo8zSdvC`qG%oJm#i&2H7}2A~`0bd6?Ge4i zuLaR~_V+SNu*l|EoLR8-54lb<*~hHZ@V=5u(}jc@vU$qa3vIWZrt{+Z*R#|+8w|nu zM~KTlzH8Qa?}P6dSQ>!M+=rI`Del|@q=u@4>n^K9>Cro2QhZxU=gsi+qoBL0uSV*X zdWVq^m^*wAaJRO4>P!uQ8>%bmODii|fs;+SUF_vDKD9L3du0f`AS}u4)#a81dYfI}wr89x8eBiSs z_6HQIhiXnzv&wXONT)b=1ZJ^5ME$}jKO~(8E^WoQLOhZ)468!fHk*UXp)~FmUxX0pA>$E)(@H(eB<**uK*Jvh{E5b#Yq25yvl2BjQY%(^}Zr+PmkT z+u8=BkzQVclP7cKz>?a*#_;vHNl`ARCwDt3)x}{2pF{_FW>GvrZC&R=a3x)8Y)^+< zx+d7iS6EFSEmD(1HFW4Qt#DE*#oUiG5J*JM_AtkrEhk5%%t+<>I45qyWtBPk5(NKR z&M-%GYF7G=nZ=C|_zABY;=qM=z!|C7r0*HDVX+chN8~tSxh!1Ys6XgaO1|R1->C!UfUq1lL@oyxV>+hBsdx6q8}~bHYCUgKqjT0CjrtvG z;hc8=rKx_uW9R*R2}%fI#64-X0(R* zX0MIoy@=2DBL2D;(XJxCst(j#|7kDc)4hm~tB7aSf!eZvs3O)1#ATS!Rqz=2#j4ll zF3Y)m=P5NC!t~!X`nKv&jXAX#{#cz-L;R_Vs8Q*06;Z3$pR0&kEYGWm8Xcch5kHq1 ot7Yo63f<{bPVQk9Q49OOdlCQIi}>GO#J?+uPrg_G{KtR(51qV$NdN!< literal 0 HcmV?d00001 diff --git a/library/COLOR-BRAINSTORMING.TXT b/library/COLOR-BRAINSTORMING.TXT new file mode 100644 index 0000000000000000000000000000000000000000..7200f42155e5978f8f3640a40b8df0d3fa3e02a3 GIT binary patch literal 3220 zcmb_dU2oh(6g4STF))0K@_@uuRbV&TY}A$_@c>bhCMD1`QBsh2W7fXAJIdH&X2#jN zZ#?nBFXGRYGvnQ`v5_hyb|rg!e82Cx*ZW2rySRp#iBrLQeJ+OtxX z&Kp~(awdd0D#_28v~r#%tj%IXR+bkun6O_kmvoP0nbX4&4s$h|GvvIXhXhfahf%w- z%2?$aGE-ui%}IGK$XJ@TZmBUfEljO*_#jn!MkpTfsdD`CWs(s7C&?ME(}eNY@nqwf z5}z16%OuBt_2iQ|-V!8L;vhkgnZ~zsAZ0QGN=XB>#=QVGgGP`G8W&Nwwd5(Y(cEA zT$f^VY4e4&EYkhQ_rv8uxO^2Z4@G)jai*lE*{W$W%UH9OFy+KkM!g(Y63p&J@3t1@a`4@snFTo{D1(jS=GJC$=FLC}|ZjxM{Uoh`~_`K2c(QAkyi zYaHZO2+myQFp1;3sBbE?_$SAfjsn-GkVbO!NTkS5q`Rdm zqEV3^6>`RyFsU1-oH)TOLTUSia=uhqsL536f-Gmo!V{j`I0KV1Q#B$@ql?o}YCN18 z=Urx1g+SA24FpUbYF|d}T+NhMFG2ymoM`sqP-%`H(Y8y8L5`HM2oUymkIu!FnLYMM z28@t8%=#5gGg--r0v1Y!_(~tD-p);mH4>C6qnjD3xGqZr9?!;fXJJeZV<5${BZQpw zouR-$fb*8YLCXbW4tIzKX6mt)%J2&FS6PEHIoj05yUoD8NkS5XEr%tBYY~RGLOCFAbRF6b;$5M8r>Dcn0ILRAgtXGFY2}!Q&wA$7xNg& zf;4r`923~e&?T)M0clemiYM6oo)#Q$;WKc>f_D0snTWHi!ePd9uEKZ(Cvo*S@ee!O zk3eM^luIl>fO zlRnfSS>%-vN%-ANZX~1RF8=LrW8<~u>ECaoHTb{CCaQ%! zV_x|Uz@RJfQ5X2I3*7u4fX})%&bz>OUEr__^m6&8EAdtrh^$&q|KqO2W*6wyqvy8g z<^8UW_qxEVOV~5ov++UKXiuUC^wRGEk-X~#>H$4EeA0>Q+~xm+dEAiC)!vHhRDtT^nC_fgid+Z{~WT-|njPs(z;{G42A_atXWR+IEP` P1iJ~~t-HyeFaG))S}1&T literal 0 HcmV?d00001 diff --git a/library/COLOR.TEDIT b/library/COLOR.TEDIT new file mode 100644 index 00000000..2a80139e --- /dev/null +++ b/library/COLOR.TEDIT @@ -0,0 +1,236 @@ +1 KALEIDOSCOPE MANUAL - 16-JAN-89 - Dev. Draft 1 KALEIDOSCOPE MANUAL - 16-JAN-89 - Dev. Draft COLOR 1 ENVOS KALEIDOSCOPE 1 COLOR 6 2 Introduction 1 This document describes software for driving color displays. In order to run COLOR, you need either a Sun (3 or 4) with CG4 color hardware and display, a Dorado (Xerox 1132) with attached color display, or a Dandelion (Xerox 1108) with attached BusMaster and color display. The color software which is distributed among a number of files can be divided into a machine independent group of files that all users can usefully load and a machine dependent group containing files that work for particular combinations of hardware. The machine independent color graphics code is stored in the library files LLCOLOR.LCOM and COLOR.LCOM. LOADing COLOR.LCOM causes LLCOLOR.LCOM to be LOADed. The machine dependent portions of Xerox Lisp color software is stored in files such as MAIKOCOLOR.LCOM, DORADOCOLOR.LCOM, or COLORNNCC.LCOM. The user LOADs one of these files according to what kind of machine and color card the user is using. The Sun color driver resides in the file MAIKOCOLOR.LCOM which loads LLCOLOR.LCOM and COLOR.LCOM. The CG4 device suppports 8 bpp at 1152 by 900 resolution. The user must be running ldecolor, the special color capable emulator. The physical display monitor is shared by both the monochrome and color screens (described below) . The Dorado color driver resides in the file DORADOCOLOR.LCOM which loads LLCOLOR.LCOM and COLOR.LCOM. The Dorado color board supports four or eight bits per pixel (bpp) at 640 by 480 resolution. (The board supports 24 bpp also, but Xerox Lisp doesn't yet.) The Dandelion color drivers reside in the files DANDELIONUFO.LCOM, DANDELIONUFO4096.LCOM, and COLORNNCC.LCOM, one package for each of three different kinds of boards. The user should load one of these packages on a Dandelion attached to a BusMaster and color display. The DANDELIONUFO and DANDELIONUFO4096 packages drive 4 bpp at 640 by 400 resolution color boards used inside Xerox which have been made obsolete by COLORNNCC. The COLORNNCC package drives an 8 bpp color at 512 by 480 resolution board, the Revolution 512 x 8, made by Number Nine Computer Corporation. The Revolution 512 x 8 is available both inside and outside Xerox through Number Nine. 2 Hardware Displays and Software Screens 1 On some workstations (such as the Dorado and Dandelion), there may be physically two separate displays. On most Suns, there is a single physical display, which additionally may be shared by two Unix devices. One device is monochrome (b/w), and the other is color. To support the various hardware configurations and external display devices, the software has a special datatype, a "screen". There are two distinct instances of screens, a b/w screen, and a color screen. A screen represents and controls a physical hardware display, and contains windows, icons, and tracks the mouse. On workstations with physically two separate hardware displays, each display is represented by a corresponding screen data structure. On workstations with a single hardware display, the display is shared by both the b/w screen and the color screen. In all cases, before initialization only the b/w screen (and thus display) is visible and active. After initialization both screens are active (can contain screen images), although on single displays, only one screen is visible at a time. Since each screen logically controls a display, we will henceforth use the terms "screen" and "display" interchangeably. Screens are discussed in greater detail below. 2 Turning the Color Display Software On and Off 1 The color display software can be turned on and off. While the color display software is on, the memory used for the color display screen bitmap is locked down, and a small amount of processing time is used to drive the color display. (COLORDISPLAYP) [Function] returns T if the color display is on; otherwise it returns NIL. (COLORDISPLAYONOFF TYPE) [Function] turns off the color display if ONOFF is 'OFF. If ONOFF is 'ON, it turns on the color display allocating memory for the color screen bitmap. TYPE should be one of 'MAIKOCOLOR, 'DORADOCOLOR, 'DANDELIONUFO, 'DANDELIONUFO4096, or 'COLORNNCC. The usual sequence of events for the user is to LOAD the software needed to drive a particular color card and then to call COLORDISPLAY with the appropriate TYPE to turn the software on. For example, (LOAD 'COLOR.LCOM) (LOAD 'COLORNNCC.LCOM) (COLORDISPLAY 'ON 'REV512X8) will turn on the software needed to drive the Number Nine Computer Corporation's Revolution 512 x 8 card with 1108 and BusMaster. Besides initializing or reinitializing a color card that has been powered off, COLORDISPLAY allocates memory for the color screen bitmap. Turning on the color display requires allocating and locking down the memory necessary to hold the color display screen bitmap. Turning off the color display frees this memory. 2 Colors 1 The number of bits per pixel determines the number of different colors that can be displayed at one time. When there are 4 bpp, 16 colors can be displayed at once. When there are 8 bpp, 256 colors can be displayed at once. A table called a color map determines what color actually appears for each pixel value. A color map gives the color in terms of how much of the three primary colors (red, green, and blue) is displayed on the screen for each possible pixel value. A color can be represented as a number, an atom, or a triple of numbers. Colors are ultimately given their final interpretation into how much red, blue, and green they represent through a color map. A color map maps a color number ([0 . . . 2nbits-1]) into the intensities of the three color guns (primary colors red, green, and blue). Each entry in the color map has eight bits for each of the primary colors, allowing 256 levels per primary or 224 possible colors (not all of which are distinct to the human eye). Within Xerox Lisp programs, colors can be manipulated as numbers, red-green-blue triples, names, or hue-lightness-saturation triples. Any function that takes a color accepts any of the different representations. If a number is given, it is the color number used in the operation. It must be valid for the color bitmap used in the operation. (Since all of the routines that use a color need to determine its number, it is fastest to use numbers for colors. COLORNUMBERP, described below, provides a way to translate into numbers from the other representations.) Red Green Blue Triples 1 A red green blue (RGB) triple is a list of three numbers between 0 and 255. The first element gives the intensity for red, the second for green, and the third for blue. When an RGB triple is used, the current color map is searched to find the color with the correct intensities. If none is found, an error is generated. (That is, no attempt is made by the system to assign color numbers to intensities automatically.) An example of an RGB triple is (255 255 255), which gives the color white. RGB [Record] is a record that is defined as (RED GREEN BLUE); it can be used to manipulate RGB triples. COLORNAMES [Association list] maps names into colors. The CDR of the color name's entry is used as the color corresponding to the color name. This can be any of the other representations. (Note: It can even be another color name. Loops in the name space such as would be caused by putting '(RED . CRIMSON) and '(CRIMSON . RED) on COLORNAMES are not checked for by the system.) Some color names are available in the initial system and are intended to allow color programs written by different users to coexist. These are: Name RGB Number in default color maps BLACK (0 0 0) 15 255 BLUE (0 0 255) 14 252 GREEN (0 255 0) 13 227 CYAN (0 255 255) 12 224 RED (255 0 0) 3 31 MAGENTA (255 0 255) 2 28 YELLOW (255 255 0) 1 3 WHITE (255 255 255) 0 0 Hue Lightness Saturation Triples 1 A hue lightness saturation triple is a list of three numbers. The first number (HUE) is an integer between 0 and 355 and indicates a position in degrees on a color wheel (blue at 0, red at 120, and green at 240). The second (LIGHTNESS) is a real number between zero and one that indicates how much total intensity is in the color. The third (SATURATION) is a real number between zero and one that indicates how disparate the three primary levels are. HLS [Record] is a record defined as (HUE LIGHTNESS SATURATION); it is provided to manipulate HLS triples. Example: the color blue is represented in HLS notation by (0 .5 1.0). (COLORNUMBERP COLOR BITSPERPIXEL NOERRFLG) [Function] returns the color number (offset into the screen color map) of COLOR. COLOR is one of the following: ˇ A positive number less than the maximum number of colors, ˇ A color name, ˇ AN RGB triple, or ˇ An HLS triple. If COLOR is one of the above and is found in the screen color map, its color number in the screen color map is returned. If not, an error is generated unless NOERRFLG is non-NIL, in which case NIL is returned. (RGBP X) [Function] returns X if X is an RGB triple; NIL otherwise. (HLSP X) [Function] returns X if X is an HLS triple; NIL otherwise. 2 Color Maps 1 The screen color map holds the information about what color is displayed on the color screen for each pixel value in the color screen bitmap. The values in the current screen color map may be changed, and this change is reflected in the colors displayed at the next vertical retrace (approximately 1/30 of a second). The color map can be changed to obtain dramatic effects. (SCREENCOLORMAP NEWCOLORMAP) [Function] reads and sets the color map that is used by the color display. If NEWCOLORMAP is non-NIL, it should be a color map, and SCREENCOLORMAP sets the system color map to be that color map. The value returned is the value of the screen color map before SCREENCOLORMAP was called. If NEWCOLORMAP is NIL, the current screen color map is returned without change. (CMYCOLORMAP CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL) [Function] Returns a color map that assumes the BITSPERPIXEL bits are to be treated as three separate color planes with CYANBITS bits being in the cyan plane, MAGENTABITS bits being in the magenta plane, and YELLOWBITS bits being in the yellow plane. Within each plane, the colors are uniformly distributed over the intensity range 0 to 255. White is 0 and black is 255. (RGBCOLORMAP REDBITS GREENBITS BLUEBITS BITSPERPIXEL) [Function] Returns a color map that assumes the BITSPERPIXEL bits are to be treated as three separate color planes with REDBITS bits being in the red plane, GREENBITS bits being in the green plane, and BLUEBITS bits being in the blue plane. Within each plane, the colors are uniformly distributed over the intensity range 0 to 255. White is 255 and black is 0. (GRAYCOLORMAP BITSPERPIXEL) [Function] Returns a color map containing shades of gray. White is 0 and black is 255. (COLORMAPCREATE INTENSITIES BITSPERPIXEL) [Function] creates a color map for a screen that has BITSPERPIXEL bits per pixel. If BITSPERPIXEL is NIL, the number of bits per pixel is taken from the current color display setting. INTENSITIES specifies the initial colors that should be in the map. If INTENSITIES is not NIL, it should be a list of color specifications other than color numbers, e.g., the list of RGB triples returned by the function INTENSITIESFROMCOLOR MAP. (INTENSITIESFROMCOLORMAP COLORMAP) [Function] returns a list of the intensity levels of COLORMAP (default is (SCREENCOLORMAP)) in a form accepted by COLORMAPCREATE. This list can be written on file and thus provides a way of saving color map specifications. (COLORMAPCOPY COLORMAP BITSPERPIXEL) [Function] returns a color map that contains the same color intensities as COLORMAP if COLORMAP is a color map. Otherwise, it returns a color map with default color values. (MAPOFACOLOR PRIMARIES) [Function] returns a color map that is different shades of one or more of the primary colors. For example, (MAPOFACOLOR '(RED GREEN BLUE)) gives a color map of different shades of gray; (MAPOFACOLOR 'RED) gives different shades of red. Changing Color Maps 1 The following functions are provided to access and change the intensity levels in a color map. (SETCOLORINTENSITY COLORMAP COLORNUMBER COLORSPEC) [Function] sets the primary intensities of color number COLORNUMBER in the color map COLORMAP to the ones specified by COLORSPEC. COLORSPEC can be either an RGB triple, an HLS triple, or a color name. The value returned is NIL. (COLORLEVEL COLORMAP COLORNUMBER PRIMARY NEWLEVEL) [Function] sets and reads the intensity level of the primary color PRIMARY (RED, GREEN, or BLUE) for the color number COLORNUMBER in the color map COLORMAP. If NEWLEVEL is a number between 0 and 255, it is set. The previous value of the intensity of PRIMARY is returned. (ADJUSTCOLORMAP PRIMARY DELTA COLORMAP) [Function] adds DELTA to the intensity of the PRIMARY color value (RED, GREEN, or BLUE) for every color number in COLORMAP. (ROTATECOLORMAP STARTCOLOR THRUCOLOR) [Function] rotates a sequence of colors in the SCREENCOLORMAP. The rotation moves the intensity values of color number STARTCOLOR into color number STARTCOLOR+1, the intensity values of color number STARTCOLOR+1 into color number STARTCOLOR+2, etc., and THRUCOLOR's values into STARTCOLOR. (EDITCOLORMAP VAR NOQFLG) [Function] allows interactive editing of a color map. If VAR is an atom whose value is a color map, its value is edited. Otherwise a new color map is created and edited. The color map being edited is made the screen color map while the editing takes place so that its effects can be observed. The edited color map is returned as the value. If NOQFLG is NIL and the color display is on, you are asked if you want a test pattern of colors. A yes response causes the function SHOWCOLORTESTPATTERN to be called, which displays a test pattern with blocks of each of the possible colors. You are prompted for the location of a color control window to be placed on the black-and-white display. This window allows the value of any of the colors to be changed. The number of the color being edited is in the upper left part of the window. Six bars are displayed. The right three bars give the color intensities for the three primary colors of the current color number. The left three bars give the value of the color's Hue, Lightness, and Saturation parameters. These levels can be changed by positioning the mouse cursor in one of the bars and pressing the left mouse button. While the left button is down, the value of that parameter tracks the Y position of the cursor. When the left button is released, the color tracking stops. The color being edited is changed by pressing the middle mouse button while the cursor is in the interior of the edit window. This brings up a menu of color numbers. Selecting one sets the current color to the selected color. The color being edited can also be changed by selecting the menu item "PickPt." This switches the cursor onto the color screen and allows you to select a point from the color screen. It then edits the color of the selected point. To stop the editing, move the cursor into the title of the editing window and press the middle button. This brings up a menu. Select Stop to quit. 2 Color Bitmaps 1 A color bitmap is actually a bitmap that has more than one bit per pixel. To test whether a bitmap is a color bitmap, the function BITSPERPIXEL can be used. (BITSPERPIXEL BITMAP) [Function] returns the bits per pixel of BITMAP; if this does not equal one, BITMAP is a color bitmap. In multiple-bit-per-pixel bitmaps, the bits that represent a pixel are stored contiguously. BITMAPCREATE is passed a BITSPERPIXEL argument to create multiple-bit-per-pixel bitmaps. (BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL) [Function] creates a color bitmap that is WIDTH pixels wide by HEIGHT pixels high allowing BITSPERPIXEL bits per pixel. Currently any value of BITSPERPIXEL except one, four, eight, or NIL (defaults to one) causes an error. A four-bit-per-pixel color screen bitmap uses approximately 76K words of storage, and an eight-bit-per-pixel one uses approximately 153K words. There is only one such bitmap. The following function provides access to it. (COLORSCREENBITMAP) [Function] returns the bitmap that is being or will be displayed on the color display. This is NIL if the color display has never been turned on (see COLORDISPLAY below). 2 2 Screens, Screenpositions, and Screenregions 1 In addition to positions and regions, the user needs to be aware of screens, screenpositions, and screenregions in the presence of multiple screens. Screens 1 SCREEN [Datatype] There are generally two screen datatype instances in existence when working with color. This is because the user is attached to two displays, a black and white display and a color display. (MAINSCREEN) [Function] returns the screen datatype instance that represents the black and white screen. This will be something like {SCREEN}#74,24740. (COLORSCREEN) [Function] returns the screen datatype instance that represents the color screen. Screens appear as part of screenpositions and screenregions, serving as the extra information needed to make clear whether a particular position or region should be viewed as lying on the black and white display or the color display. (SCREENBITMAP SCREEN) [Function] returns the bitmap destination of SCREEN. If SCREEN=NIL, returns the black and white screen bitmap. Screenpositions 1 SCREENPOSITION [Record] Somewhat like a position, a screenposition denotes a point in an X,Y coordinate system on a particular screen. Screenpositions have been defined according to the following record declaration: (RECORD SCREENPOSITION (SCREEN . POSITION) (SUBRECORD POSITION)) A SCREENPOSITION is an instance of a record with fields XCOORD, YCOORD, and SCREEN and is manipulated with the standard record package facilities. For example, (create SCREENPOSITION XCOORD _ 10 YCOORD _ 20 SCREEN _ (COLORSCREEN)) creates a screenposition representing the point (10,20) on the color display. The user can extract the position of a screenposition by fetching its POSITION. For example, (fetch (SCREENPOSITION POSITION) of SP12). Screenregions 1 SCREENREGION [Record] Somewhat like a region, a screenregion denotes a rectangular area in a coordinate system. Screenregions have been defined according to the following record declaration: (RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION)) Screenregions are characterized by the coordinates of their bottom left corner and their width and height. A SCREENREGION is a record with fields LEFT, BOTTOM, WIDTH, HEIGHT, and SCREEN. It can be manipulated with the standard record package facilities. There are access functions for the REGION record that return the TOP and RIGHT of the region. The user can extract the region of a screenregion by fetching its REGION. For example, (fetch (SCREENREGION REGION) of SR8). Screenposition and Screenregion Prompting 1 The following functions can be used by programs to allow the user to interactively specify screenpositions or screenregions on a display screen. (GETSCREENPOSITION WINDOW CURSOR) [Function] 1 Similar to GETPOSITION. Returns a SCREENPOSITION that is specified by the user. GETSCREENPOSITION waits for the user to press and release the left button of the mouse and returns the cursor screenposition at the time of release. If WINDOW is a WINDOW, the screenposition will be on the same screen as WINDOW and in the coordinate system of WINDOW's display stream. If WINDOW is NIL, the position will be in screen coordinates. 1 (GETBOXSCREENPOSITION BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG) [Function] 1 Similar to GETBOXPOSITION. Returns a SCREENPOSITION that is specified by the user. Allows the user to position a "ghost" region of size BOXWIDTH by BOXHEIGHT on a screen, and returns the SCREENPOSITION of the lower left corner of the screenregion chosen. A ghost region is locked to the cursor so that if the cursor is moved, the ghost region moves with it. The user can change to another corner by holding down the right button. With the right button down, the cursor can be moved across a screen or to other screens without effect on the ghost region frame. When the right button is released, the mouse will snap to the nearest corner, which will then become locked to the cursor. (The held corner can be changed after the left or middle button is down by holding both the original button and the right button down while the cursor is moved to the desired new corner, then letting up just the right button.) When the left or middle button is pressed and released, the lower left corner of the screenregion chosen at the time of release is returned. If WINDOW is a WINDOW, the screenposition will be on the same screen as WINDOW and in the coordinate system of WINDOW's display stream. If WINDOW is NIL, the position will be in screen coordinates.its lower left corner in screen coordinates. 1 (GETSCREENREGION MINWIDTH MINHEIGHT OLDREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS) [Function] 1 Similar to GETREGION. Returns a SCREENREGION that is specified by the user. Lets the user specify a new screenregion and returns that screenregion. GETSCREENREGION prompts for a screenregion by displaying a four-pronged box next to the cursor arrow at one corner of a "ghost" region: €ŔŕđřçüĂţ˝đ$Ř$˜˝ Ă ç. If the user presses the left button, the corner of a "ghost" screenregion opposite the cursor is locked where it is. Once one corner has been fixed, the ghost screenregion expands as the cursor moves. To specify a screenregion: (1) Move the ghost box so that the corner opposite the cursor is at one corner of the intended screenregion. (2) Press the left button. (3) Move the cursor to the screenposition of the opposite corner of the intended screenregion while holding down the left button. (4) Release the left button. Before one corner has been fixed, one can switch the cursor to another corner of the ghost screenregion by holding down the right button. With the right button down, the cursor changes to a "forceps" ( 9Ŕ)@9Ŕ€€€pŕ``) and the cursor can be moved across a screen or to other screens without effect on the ghost screenregion frame. When the right button is released, the cursor will snap to the nearest corner of the ghost screenregion. After one corner has been fixed, one can still switch to another corner. To change to another corner, continue to hold down the left button and hold down the right button also. With both buttons down, the cursor can be moved across a screen or to other screens without effect on the ghost screenregion frame. When the right button is released, the cursor will snap to the nearest corner, which will become the moving corner. In this way, the screenregion may be moved all over a screen and to other screens, before its size and screenposition is finalized. The size of the initial ghost screenregion is controlled by the MINWIDTH, MINHEIGHT, OLDREGION, and INITCORNERS arguments. 1 (GETBOXSCREENREGION WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG) [Function] 1 Similar to GETBOXREGION. Returns a SCREENREGION that is specified by the user. Performs the same prompting as GETBOXSCREENPOSITION and returns the SCREENREGION specified by the user instead of the SCREENPOSITION of its lower left corner. 1 2 Color Windows and Menus 1 The Xerox Lisp window system provides both interactive and programmatic constructs for creating, moving, reshaping, overlapping, and destroying windows in such a way that a program can use a window in a relatively transparent fashion (see ("Windows" . TERM)). Menus are a special type of window provided by the window system, used for displaying a set of items to the user, and having the user select one using the mouse and cursor. The menu facility also allows users to create and use menus in interactive programs (see ("Menus" . TERM)). As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display. (CREATEW REGION TITLE BORDERSIZE NOOPENFLG) [Function] 1 Creates a new window. REGION indicates where and how large the window should be by specifying the exterior screenregion of the window. In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of. This problem is solved by allowing CREATEW to take screenregion arguments as REGION. For example, (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) creates a window titled "FOO WINDOW" on the color screen. To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression. Note that it is still perfectly legal to pass in a REGION that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW. This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor. This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens. 1 (WINDOWPROP WINDOW PROP NEWVALUE) [NoSpread Function] 1 If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on. If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error. Any other PROP name is handled in the usual way. 1 (OPENWINDOWS SCREEN) [Function] 1 Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN). If SCREEN=NIL, then SCREEN will default to the screen containing the cursor. If SCREEN=T, then a list of all open windows on all screens is returned. 1 2 Color Fonts 1 The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color. Color Font Creation 1 The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts. This is made possible in some cases by there being new ways to call familiar font functions. (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) [Function] 1 In addition to creating black and white fonts, FONTCREATE can be used to create color fonts. For example, (FONTCREATE 'GACHA 10 '(BOLD REGULAR REGULAR YELLOW BLUE) 0 '8DISPLAY) will create an 8 bit per pixel font with blue letters on a yellow background. The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE. DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font. A color font face is a 5 tuple, (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR) whereas a black and white font face is just a 3 tuple, (WEIGHT SLOPE EXPANSION) The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters. Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation. A color font face can also be represented as a LITATOM. A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes. For example, MRR-YELLOW-BLUE BOLD-YELLOW-RED ITALIC-90-200 BRR-100-53 are acceptable color font faces. Hence, (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY) will create a color font. LITATOM FACE arguments fall into one of the following patterns: wse wse-backcolor-forecolor STANDARD STANDARD-backcolor-forecolor ITALIC ITALIC-backcolor-forecolor BOLD BOLD-backcolor-forecolor BOLDITALIC BOLDITALIC-backcolor-forecolor where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number. 1 (FONTPROP FONT PROP) [Function] 1 Returns the value of the PROP property of font FONT. Besides black and white font properties, the following font properties are recognized: FORECOLOR The color of the characters of the font, represented as a color number. This is the color in which the characters of the font will print. BACKCOLOR The color of the background of the characters of the font, represented as a color number. This is the color in which the the background of characters of the font will print. A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR. Color Font Profiles 1 Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance. The user can specify that different colors of fonts be used for different kinds of elements when printing in color. A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example. A FONTPROFILE such as ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) ...) would have comments print in green and clisp words print in blue while ordinairy atoms would print in red. Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set. The user should indicate what font is to be used for each font class by calling the function FONTPROFILE: (FONTPROFILE PROFILE) [Function] 1 Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts. Each element of PROFILE is a list of the form: (FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1) ... (OTHERDEVICEn OTHERFONTn)) FONTCLASS is the font class name and FONT# is the font number for that class. DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively. The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED). 1 FONTPROFILE [Variable] 1 This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE. Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 1 2 Using Color 1 The current color implementation allows display streams to operate on color bitmaps. The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function. (DSPCOLOR COLOR STREAM) [Function] sets the foreground color of a stream. It returns the previous foreground color. If COLOR is NIL, it returns the current foreground color without changing anything. The default foreground color is MINIMUMCOLOR=0, which is white in the default color maps. (DSPBACKCOLOR COLOR STREAM) [Function] sets the background color of a stream. It returns the previous background color. If COLOR is NIL, it returns the current background color without changing anything. The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps. The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream. Following are some notes about them. 2 BITBLTing in Color 1 If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level. Thus painting color 3 onto color 10 results in color 11. If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR. BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy. If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color. Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT NIL NIL NIL COLORSTR 50 75 100 200 'TEXTURE 'REPLACE 'BLUE). 2 Drawing Curves and Lines in Color 1 For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color. A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR). Also, a brush can be a bitmap (which can be a color bitmap). Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap. (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR) [Function] (DRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (RELDRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (DRAWBETWEEN POS1 POS2 WIDTH OPERATION STREAM COLOR) [Function] If the COLOR argument is NIL, the DSPCOLOR of the stream is used. 2 Printing in Color 1 Printing only works in REPLACE mode. The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with. Example of printing to an 8bpp color screen: (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) (DSPFONT (FONTCREATE 'GACHA 10 'MRR-YELLOW-GREEN 0 '8DISPLAY) FOO) (PRINT 'HELLO FOO) ; will print in green against a yellow background. 2 Operating the Cursor on the Color Screen 1 The cursor can be moved to the color screen. The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN. (CURSORPOSITION NEWPOSITION - -) [Function] 1 NEWPOSITION can be a position or a screenposition. (CURSORSCREEN SCREEN XCOORD YCOORD) [Function] 1 Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD. SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN). While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor. It is automatically taken down whenever an operation is performed that changes any bits on the color screen. The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen. While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time. 2 Miscellaneous Color Functions 1 (COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL) [Function] creates a color bitmap from a black and white bitmap. The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero. This provides a way of producing a color bitmap from a black and white bitmap. (UNCOLORIZEBITMAP BITMAP COLORMAP) [Function] creates a black and white bitmap from a color bitmap. (SHOWCOLORTESTPATTERN BARSIZE) [Function] displays a pattern of colors on the color display. This is useful when editing a color map. The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen. Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row. The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers. The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color˙˙ď%˙about 20). (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL ( PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) ( 54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) ( PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) ( HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))))7ĚĚř ˜Ôř8ĚĚř ˜ÔřT(ĚĚř1ĚřşĚ(ĚĚř)KKřT/KĚřřT(ĚĚř5ĚĚř nřT/ĚĚřřT/ĚĚřřT/ĚĚřČT/ĚĚřČT/ĚĚř řT/ř2řT/řČT/řřT/řřT.ĚĚřř.ĚĚř ř/řČT/ř2ČT.ĚĚřČ.ĚĚř Č<ř PAGEHEADING VERSOHEAD<ř PAGEHEADING RECTOHEAD;ř PAGEHEADINGFOOTINGV;ř PAGEHEADINGFOOTINGR ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +MODERNMODERN MODERNMODERNMODERN +MODERN +MODERN +MODERN + HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN HRULE.GETFNMODERN  HRULE.GETFNMODERN× ü ž ă f   • f +Ý  HRULE.GETFNMODERN. HRULE.GETFNMODERNî   @   +   W ď (   " ‚ =  HRULE.GETFNMODERN  HRULE.GETFNMODERNô É  `   HRULE.GETFNMODERN  ë   + ]  + > Ż  &           HRULE.GETFNMODERN  ż   + ¤     ?   =     Ë     "      "  HRULE.GETFNMODERN  HRULE.GETFNMODERNy    D + q  B  -  i  (  _    L    *  X = Ľ    * Ł    ?  N    ă  HRULE.GETFNMODERN _    +8 -   + Z    +& 8 ,   S       =     m + +) + +  +   + /  ę ŕ ľ ; č –  HRULE.GETFNMODERN HRULE.GETFNMODERNž      v 4       ) E ß   Ą  HRULE.GETFNMODERN HRULE.GETFN, HRULE.GETFNMODERN•  HRULE.GETFNMODERN ž      2  "  1  HRULE.GETFNMODERN +  + +    HRULE.GETFNMODERN  + Ş ' ) Ţ ) HRULE.GETFNMODERN‘    HRULE.GETFNMODERN + ë ? "  4  HRULE.GETFNMODERN + -  HRULE.GETFNMODERN + Š  ˆ ? "  a  HRULE.GETFNMODERN + C  HRULE.GETFNMODERN +  ( BMOBJ.GETFN3Í H Ę , BMOBJ.GETFN3Ü 1 @      HRULE.GETFNMODERN + '  HRULE.GETFNMODERN + đ  HRULE.GETFNMODERN +  HRULE.GETFNMODERN HRULE.GETFNMODERNď ). Menus are a special type of window provided by the window system, used for displaying a set of items to the user, and having the user select one using the mouse and cursor. The menu facility also allows users to create and use menus in interactive programs (see ("Menus" . TERM)). As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display. (CREATEW REGION TITLE BORDERSIZE NOOPENFLG) [Function] 1 Creates a new window. REGION indicates where and how large the window should be by specifying the exterior screenregion of the window. In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of. This problem is solved by allowing CREATEW to take screenregion arguments as REGION. For example, (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) creates a window titled "FOO WINDOW" on the color screen. To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression. Note that it is still perfectly legal to pass in a REGION that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW. This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor. This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens. 1 (WINDOWPROP WINDOW PROP NEWVALUE) [NoSpread Function] 1 If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on. If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error. Any other PROP name is handled in the usual way. 1 (OPENWINDOWS SCREEN) [Function] 1 Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN). If SCREEN=NIL, then SCREEN will default to the screen containing the cursor. If SCREEN=T, then a list of all open windows on all screens is returned. 1 2 Color Fonts 1 The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color. Color Font Creation 1 The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts. This is made possible in some cases by there being new ways to call familiar font functions. (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) [Function] 1 In addition to creating black and white fonts, FONTCREATE can be used to create color fonts. For example, (FONTCREATE 'GACHA 10 '(BOLD REGULAR REGULAR YELLOW BLUE) 0 '8DISPLAY) will create an 8 bit per pixel font with blue letters on a yellow background. The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE. DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font. A color font face is a 5 tuple, (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR) whereas a black and white font face is just a 3 tuple, (WEIGHT SLOPE EXPANSION) The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters. Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation. A color font face can also be represented as a LITATOM. A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes. For example, MRR-YELLOW-BLUE BOLD-YELLOW-RED ITALIC-90-200 BRR-100-53 are acceptable color font faces. Hence, (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY) will create a color font. LITATOM FACE arguments fall into one of the following patterns: wse wse-backcolor-forecolor STANDARD STANDARD-backcolor-forecolor ITALIC ITALIC-backcolor-forecolor BOLD BOLD-backcolor-forecolor BOLDITALIC BOLDITALIC-backcolor-forecolor where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number. 1 (FONTPROP FONT PROP) [Function] 1 Returns the value of the PROP property of font FONT. Besides black and white font properties, the following font properties are recognized: FORECOLOR The color of the characters of the font, represented as a color number. This is the color in which the characters of the font will print. BACKCOLOR The color of the background of the characters of the font, represented as a color number. This is the color in which the the background of characters of the font will print. A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR. Color Font Profiles 1 Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance. The user can specify that different colors of fonts be used for different kinds of elements when printing in color. A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example. A FONTPROFILE such as ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) ...) would have comments print in green and clisp words print in blue while ordinairy atoms would print in red. Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set. The user should indicate what font is to be used for each font class by calling the function FONTPROFILE: (FONTPROFILE PROFILE) [Function] 1 Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts. Each element of PROFILE is a list of the form: (FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1) ... (OTHERDEVICEn OTHERFONTn)) FONTCLASS is the font class name and FONT# is the font number for that class. DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively. The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED). 1 FONTPROFILE [Variable] 1 This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE. Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 1 2 Using Color 1 The current color implementation allows display streams to operate on color bitmaps. The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function. (DSPCOLOR COLOR STREAM) [Function] sets the foreground color of a stream. It returns the previous foreground color. If COLOR is NIL, it returns the current foreground color without changing anything. The default foreground color is MINIMUMCOLOR=0, which is white in the default color maps. (DSPBACKCOLOR COLOR STREAM) [Function] sets the background color of a stream. It returns the previous background color. If COLOR is NIL, it returns the current background color without changing anything. The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps. The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream. Following are some notes about them. 2 BITBLTing in Color 1 If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level. Thus painting color 3 onto color 10 results in color 11. If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR. BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy. If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color. Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT NIL NIL NIL COLORSTR 50 75 100 200 'TEXTURE 'REPLACE 'BLUE). 2 Drawing Curves and Lines in Color 1 For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color. A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR). Also, a brush can be a bitmap (which can be a color bitmap). Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap. (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR) [Function] (DRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (RELDRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (DRAWBETWEEN POS1 POS2 WIDTH OPERATION STREAM COLOR) [Function] If the COLOR argument is NIL, the DSPCOLOR of the stream is used. 2 Printing in Color 1 Printing only works in REPLACE mode. The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with. Example of printing to an 8bpp color screen: (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) (DSPFONT (FONTCREATE 'GACHA 10 'MRR-YELLOW-GREEN 0 '8DISPLAY) FOO) (PRINT 'HELLO FOO) ; will print in green against a yellow background. 2 Operating the Cursor on the Color Screen 1 The cursor can be moved to the color screen. The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN. (CURSORPOSITION NEWPOSITION - -) [Function] 1 NEWPOSITION can be a position or a screenposition. (CURSORSCREEN SCREEN XCOORD YCOORD) [Function] 1 Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD. SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN). While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor. It is automatically taken down whenever an operation is performed that changes any bits on the color screen. The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen. While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time. 2 Miscellaneous Color Functions 1 (COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL) [Function] creates a color bitmap from a black and white bitmap. The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero. This provides a way of producing a color bitmap from a black and white bitmap. (UNCOLORIZEBITMAP BITMAP COLORMAP) [Function] creates a black and white bitmap from a color bitmap. (SHOWCOLORTESTPATTERN BARSIZE) [Function] displays a pattern of colors on the color display. This is useful when editing a color map. The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen. Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row. The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers. The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color˙˙ď%˙about 20). (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL ( PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) ( 54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) ( PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) ( HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))))7ĚĚř ˜Ôř8ĚĚř ˜ÔřT(ĚĚř1ĚřşĚ(ĚĚř)KKřT/KĚřřT(ĚĚř5ĚĚř nřT/ĚĚřřT/ĚĚřřT/ĚĚřČT/ĚĚřČT/ĚĚř řT/ř2řT/řČT/řřT/řřT.ĚĚřř.ĚĚř ř/řČT/ř2ČT.ĚĚřČ.ĚĚř Č<ř PAGEHEADING VERSOHEAD<ř PAGEHEADING RECTOHEAD;ř PAGEHEADINGFOOTINGV;ř PAGEHEADINGFOOTINGR ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +MODERNMODERN MODERNMODERNMODERN +MODERN +MODERN +MODERN + HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN HRULE.GETFNMODERN  HRULE.GETFNMODERN× ü ž ă f   • f +Ý  HRULE.GETFNMODERN. HRULE.GETFNMODERNî   @   +   W ď (   " ‚ =  HRULE.GETFNMODERN  HRULE.GETFNMODERNô É  `   HRULE.GETFNMODERN  ë   + ]  + > Ż  &           HRULE.GETFNMODERN  ż   + ¤     ?   =     Ë     "      "  HRULE.GETFNMODERN  HRULE.GETFNMODERNy    D + q  B  -  i  (  _    L    *  X = Ľ    * Ł    ?  N    ă  HRULE.GETFNMODERN _    +8 -   + Z    +& 8 ,   S       =     m + +) + +  +   + /  ę ŕ ľ ; č –  HRULE.GETFNMODERN HRULE.GETFNMODERNž      v 4       ) E ß   Ą  HRULE.GETFNMODERN HRULE.GETFN, HRULE.GETFNMODERN•  HRULE.GETFNMODERN ž      2  "  1  HRULE.GETFNMODERN +  + +    HRULE.GETFNMODERN  + Ş ' ) Ţ ) HRULE.GETFNMODERN‘    HRULE.GETFNMODERN + ë ? "  4  HRULE.GETFNMODERN + -  HRULE.GETFNMODERN + Š  ˆ ? "  a  HRULE.GETFNMODERN + C  HRULE.GETFNMODERN +  ( BMOBJ.GETFN3Í H Ę , BMOBJ.GETFN3Ü 1 @      HRULE.GETFNMODERN + '  HRULE.GETFNMODERN + đ  HRULE.GETFNMODERN +  HRULE.GETFNMODERN HRULE.GETFNMODERNď  IRM.GET.CREF ). As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display. (CREATEW REGION TITLE BORDERSIZE NOOPENFLG) [Function] 1 Creates a new window. REGION indicates where and how large the window should be by specifying the exterior screenregion of the window. In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of. This problem is solved by allowing CREATEW to take screenregion arguments as REGION. For example, (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) creates a window titled "FOO WINDOW" on the color screen. To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression. Note that it is still perfectly legal to pass in a REGION that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW. This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor. This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens. 1 (WINDOWPROP WINDOW PROP NEWVALUE) [NoSpread Function] 1 If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on. If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error. Any other PROP name is handled in the usual way. 1 (OPENWINDOWS SCREEN) [Function] 1 Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN). If SCREEN=NIL, then SCREEN will default to the screen containing the cursor. If SCREEN=T, then a list of all open windows on all screens is returned. 1 2 Color Fonts 1 The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color. Color Font Creation 1 The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts. This is made possible in some cases by there being new ways to call familiar font functions. (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) [Function] 1 In addition to creating black and white fonts, FONTCREATE can be used to create color fonts. For example, (FONTCREATE 'GACHA 10 '(BOLD REGULAR REGULAR YELLOW BLUE) 0 '8DISPLAY) will create an 8 bit per pixel font with blue letters on a yellow background. The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE. DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font. A color font face is a 5 tuple, (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR) whereas a black and white font face is just a 3 tuple, (WEIGHT SLOPE EXPANSION) The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters. Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation. A color font face can also be represented as a LITATOM. A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes. For example, MRR-YELLOW-BLUE BOLD-YELLOW-RED ITALIC-90-200 BRR-100-53 are acceptable color font faces. Hence, (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY) will create a color font. LITATOM FACE arguments fall into one of the following patterns: wse wse-backcolor-forecolor STANDARD STANDARD-backcolor-forecolor ITALIC ITALIC-backcolor-forecolor BOLD BOLD-backcolor-forecolor BOLDITALIC BOLDITALIC-backcolor-forecolor where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number. 1 (FONTPROP FONT PROP) [Function] 1 Returns the value of the PROP property of font FONT. Besides black and white font properties, the following font properties are recognized: FORECOLOR The color of the characters of the font, represented as a color number. This is the color in which the characters of the font will print. BACKCOLOR The color of the background of the characters of the font, represented as a color number. This is the color in which the the background of characters of the font will print. A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR. Color Font Profiles 1 Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance. The user can specify that different colors of fonts be used for different kinds of elements when printing in color. A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example. A FONTPROFILE such as ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) ...) would have comments print in green and clisp words print in blue while ordinairy atoms would print in red. Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set. The user should indicate what font is to be used for each font class by calling the function FONTPROFILE: (FONTPROFILE PROFILE) [Function] 1 Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts. Each element of PROFILE is a list of the form: (FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1) ... (OTHERDEVICEn OTHERFONTn)) FONTCLASS is the font class name and FONT# is the font number for that class. DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively. The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED). 1 FONTPROFILE [Variable] 1 This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE. Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 1 2 Using Color 1 The current color implementation allows display streams to operate on color bitmaps. The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function. (DSPCOLOR COLOR STREAM) [Function] sets the foreground color of a stream. It returns the previous foreground color. If COLOR is NIL, it returns the current foreground color without changing anything. The default foreground color is MINIMUMCOLOR=0, which is white in the default color maps. (DSPBACKCOLOR COLOR STREAM) [Function] sets the background color of a stream. It returns the previous background color. If COLOR is NIL, it returns the current background color without changing anything. The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps. The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream. Following are some notes about them. 2 BITBLTing in Color 1 If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level. Thus painting color 3 onto color 10 results in color 11. If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR. BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy. If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color. Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT NIL NIL NIL COLORSTR 50 75 100 200 'TEXTURE 'REPLACE 'BLUE). 2 Drawing Curves and Lines in Color 1 For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color. A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR). Also, a brush can be a bitmap (which can be a color bitmap). Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap. (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR) [Function] (DRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (RELDRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (DRAWBETWEEN POS1 POS2 WIDTH OPERATION STREAM COLOR) [Function] If the COLOR argument is NIL, the DSPCOLOR of the stream is used. 2 Printing in Color 1 Printing only works in REPLACE mode. The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with. Example of printing to an 8bpp color screen: (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) (DSPFONT (FONTCREATE 'GACHA 10 'MRR-YELLOW-GREEN 0 '8DISPLAY) FOO) (PRINT 'HELLO FOO) ; will print in green against a yellow background. 2 Operating the Cursor on the Color Screen 1 The cursor can be moved to the color screen. The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN. (CURSORPOSITION NEWPOSITION - -) [Function] 1 NEWPOSITION can be a position or a screenposition. (CURSORSCREEN SCREEN XCOORD YCOORD) [Function] 1 Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD. SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN). While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor. It is automatically taken down whenever an operation is performed that changes any bits on the color screen. The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen. While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time. 2 Miscellaneous Color Functions 1 (COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL) [Function] creates a color bitmap from a black and white bitmap. The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero. This provides a way of producing a color bitmap from a black and white bitmap. (UNCOLORIZEBITMAP BITMAP COLORMAP) [Function] creates a black and white bitmap from a color bitmap. (SHOWCOLORTESTPATTERN BARSIZE) [Function] displays a pattern of colors on the color display. This is useful when editing a color map. The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen. Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row. The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers. The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color˙˙ď%˙about 20). (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))));ĚĚř ˜Ôř<ĚĚř ˜ÔřT,ĚĚř5ĚřşĚ,ĚĚř-KKřT3KĚřřT,ĚĚř9ĚĚř nřT3ĚĚřřT3ĚĚřřT3ĚĚřČT3ĚĚřČT3ĚĚř řT3ř2řT3řČT3řřT3řřT2ĚĚřř2ĚĚř ř3řČT3ř2ČT2ĚĚřČ2ĚĚř Č@ř PAGEHEADING VERSOHEAD@ř PAGEHEADING RECTOHEAD?ř PAGEHEADINGFOOTINGV?ř PAGEHEADINGFOOTINGR ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +MODERNMODERN MODERNMODERNMODERN +MODERN +MODERN +MODERN + HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN HRULE.GETFNMODERN  HRULE.GETFNMODERN ü ž ô K f   •  HRULE.GETFNMODERN' HRULE.GETFNMODERN + @ ú š  HRULE.GETFNMODERN. HRULE.GETFNMODERNî   @   +   W ü (   " ‚ =  HRULE.GETFNMODERN  HRULE.GETFNMODERNó +Ý ô É  `   HRULE.GETFNMODERN  ë   + ]  + > Ż  &           HRULE.GETFNMODERN  ż   + ¤     ?   =     Ë     "      "  HRULE.GETFNMODERN  HRULE.GETFNMODERNy    D + q  B  -  i  (  _    L    *  X = Ľ    * Ł    ?  N    ă  HRULE.GETFNMODERN _    +8 -   + Z    +& 8 ,   S       =     m + +) + +  +   + /  ę ŕ ľ ; č –  HRULE.GETFNMODERN HRULE.GETFNMODERNž      v 4       ) E ß   Ą  HRULE.GETFNMODERN HRULE.GETFN, HRULE.GETFNMODERN•  HRULE.GETFNMODERN ž      2  "  1  HRULE.GETFNMODERN +  + +    HRULE.GETFNMODERN  + Ş ' ) Ţ ) HRULE.GETFNMODERN‘    HRULE.GETFNMODERN + ë ? "  4  HRULE.GETFNMODERN + -  HRULE.GETFNMODERN + Š  ˆ ? "  a  HRULE.GETFNMODERN + C  HRULE.GETFNMODERN +  ( BMOBJ.GETFN3Í H Ę , BMOBJ.GETFN3Ü 1 @      HRULE.GETFNMODERN + '  HRULE.GETFNMODERN + đ  HRULE.GETFNMODERN +  HRULE.GETFNMODERN HRULE.GETFNMODERNď a). Menus are a special type of window provided by the window system, used for displaying a set of items to the user, and having the user select one using the mouse and cursor. The menu facility also allows users to create and use menus in interactive programs (see ("Menus" . TERM)). As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display. (CREATEW REGION TITLE BORDERSIZE NOOPENFLG) [Function] 1 Creates a new window. REGION indicates where and how large the window should be by specifying the exterior screenregion of the window. In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of. This problem is solved by allowing CREATEW to take screenregion arguments as REGION. For example, (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) creates a window titled "FOO WINDOW" on the color screen. To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression. Note that it is still perfectly legal to pass in a REGION that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW. This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor. This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens. 1 (WINDOWPROP WINDOW PROP NEWVALUE) [NoSpread Function] 1 If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on. If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error. Any other PROP name is handled in the usual way. 1 (OPENWINDOWS SCREEN) [Function] 1 Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN). If SCREEN=NIL, then SCREEN will default to the screen containing the cursor. If SCREEN=T, then a list of all open windows on all screens is returned. 1 2 Color Fonts 1 The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color. Color Font Creation 1 The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts. This is made possible in some cases by there being new ways to call familiar font functions. (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) [Function] 1 In addition to creating black and white fonts, FONTCREATE can be used to create color fonts. For example, (FONTCREATE 'GACHA 10 '(BOLD REGULAR REGULAR YELLOW BLUE) 0 '8DISPLAY) will create an 8 bit per pixel font with blue letters on a yellow background. The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE. DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font. A color font face is a 5 tuple, (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR) whereas a black and white font face is just a 3 tuple, (WEIGHT SLOPE EXPANSION) The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters. Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation. A color font face can also be represented as a LITATOM. A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes. For example, MRR-YELLOW-BLUE BOLD-YELLOW-RED ITALIC-90-200 BRR-100-53 are acceptable color font faces. Hence, (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY) will create a color font. LITATOM FACE arguments fall into one of the following patterns: wse wse-backcolor-forecolor STANDARD STANDARD-backcolor-forecolor ITALIC ITALIC-backcolor-forecolor BOLD BOLD-backcolor-forecolor BOLDITALIC BOLDITALIC-backcolor-forecolor where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number. 1 (FONTPROP FONT PROP) [Function] 1 Returns the value of the PROP property of font FONT. Besides black and white font properties, the following font properties are recognized: FORECOLOR The color of the characters of the font, represented as a color number. This is the color in which the characters of the font will print. BACKCOLOR The color of the background of the characters of the font, represented as a color number. This is the color in which the the background of characters of the font will print. A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR. Color Font Profiles 1 Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance. The user can specify that different colors of fonts be used for different kinds of elements when printing in color. A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example. A FONTPROFILE such as ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) ...) would have comments print in green and clisp words print in blue while ordinairy atoms would print in red. Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set. The user should indicate what font is to be used for each font class by calling the function FONTPROFILE: (FONTPROFILE PROFILE) [Function] 1 Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts. Each element of PROFILE is a list of the form: (FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1) ... (OTHERDEVICEn OTHERFONTn)) FONTCLASS is the font class name and FONT# is the font number for that class. DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively. The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED). 1 FONTPROFILE [Variable] 1 This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE. Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 1 2 Using Color 1 The current color implementation allows display streams to operate on color bitmaps. The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function. (DSPCOLOR COLOR STREAM) [Function] sets the foreground color of a stream. It returns the previous foreground color. If COLOR is NIL, it returns the current foreground color without changing anything. The default foreground color is MINIMUMCOLOR=0, which is white in the default color maps. (DSPBACKCOLOR COLOR STREAM) [Function] sets the background color of a stream. It returns the previous background color. If COLOR is NIL, it returns the current background color without changing anything. The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps. The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream. Following are some notes about them. 2 BITBLTing in Color 1 If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level. Thus painting color 3 onto color 10 results in color 11. If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR. BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy. If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color. Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT NIL NIL NIL COLORSTR 50 75 100 200 'TEXTURE 'REPLACE 'BLUE). 2 Drawing Curves and Lines in Color 1 For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color. A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR). Also, a brush can be a bitmap (which can be a color bitmap). Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap. (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR) [Function] (DRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (RELDRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (DRAWBETWEEN POS1 POS2 WIDTH OPERATION STREAM COLOR) [Function] If the COLOR argument is NIL, the DSPCOLOR of the stream is used. 2 Printing in Color 1 Printing only works in REPLACE mode. The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with. Example of printing to an 8bpp color screen: (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) (DSPFONT (FONTCREATE 'GACHA 10 'MRR-YELLOW-GREEN 0 '8DISPLAY) FOO) (PRINT 'HELLO FOO) ; will print in green against a yellow background. 2 Operating the Cursor on the Color Screen 1 The cursor can be moved to the color screen. The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN. (CURSORPOSITION NEWPOSITION - -) [Function] 1 NEWPOSITION can be a position or a screenposition. (CURSORSCREEN SCREEN XCOORD YCOORD) [Function] 1 Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD. SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN). While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor. It is automatically taken down whenever an operation is performed that changes any bits on the color screen. The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen. While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time. 2 Miscellaneous Color Functions 1 (COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL) [Function] creates a color bitmap from a black and white bitmap. The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero. This provides a way of producing a color bitmap from a black and white bitmap. (UNCOLORIZEBITMAP BITMAP COLORMAP) [Function] creates a black and white bitmap from a color bitmap. (SHOWCOLORTESTPATTERN BARSIZE) [Function] displays a pattern of colors on the color display. This is useful when editing a color map. The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen. Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row. The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers. The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color˙˙ď%˙about 20). (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL ( PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) ( 54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) ( PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) ( HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))))7ĚĚř ˜Ôř8ĚĚř ˜ÔřT(ĚĚř1ĚřşĚ(ĚĚř)KKřT/KĚřřT(ĚĚř5ĚĚř nřT/ĚĚřřT/ĚĚřřT/ĚĚřČT/ĚĚřČT/ĚĚř řT/ř2řT/řČT/řřT/řřT.ĚĚřř.ĚĚř ř/řČT/ř2ČT.ĚĚřČ.ĚĚř Č<ř PAGEHEADING VERSOHEAD<ř PAGEHEADING RECTOHEAD;ř PAGEHEADINGFOOTINGV;ř PAGEHEADINGFOOTINGR ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +MODERNMODERN MODERNMODERNMODERN +MODERN +MODERN +MODERN + HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN HRULE.GETFNMODERN  HRULE.GETFNMODERN× ü ž ă f   • f +Ý  HRULE.GETFNMODERN. HRULE.GETFNMODERNî   @   +   W ď (   " ‚ =  HRULE.GETFNMODERN  HRULE.GETFNMODERNô É  `   HRULE.GETFNMODERN  ë   + ]  + > Ż  &           HRULE.GETFNMODERN  ż   + ¤     ?   =     Ë     "      "  HRULE.GETFNMODERN  HRULE.GETFNMODERNy    D + q  B  -  i  (  _    L    *  X = Ľ    * Ł    ?  N    ă  HRULE.GETFNMODERN _    +8 -   + Z    +& 8 ,   S       =     m + +) + +  +   + /  ę ŕ ľ ; č –  HRULE.GETFNMODERN HRULE.GETFNMODERNž      v 4       ) E ß   Ą  HRULE.GETFNMODERN HRULE.GETFN, HRULE.GETFNMODERN•  HRULE.GETFNMODERN ž      2  "  1  HRULE.GETFNMODERN +  + +    HRULE.GETFNMODERN  + Ş ' ) Ţ ) HRULE.GETFNMODERN‘    HRULE.GETFNMODERN + ë ? "  4  HRULE.GETFNMODERN + -  HRULE.GETFNMODERN + Š  ˆ ? "  a  HRULE.GETFNMODERN + C  HRULE.GETFNMODERN +  ( BMOBJ.GETFN3Í H Ę , BMOBJ.GETFN3Ü 1 @      HRULE.GETFNMODERN + '  HRULE.GETFNMODERN + đ  HRULE.GETFNMODERN +  HRULE.GETFNMODERN HRULE.GETFNMODERNď  IRM.GET.CREF ). As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display. (CREATEW REGION TITLE BORDERSIZE NOOPENFLG) [Function] 1 Creates a new window. REGION indicates where and how large the window should be by specifying the exterior screenregion of the window. In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of. This problem is solved by allowing CREATEW to take screenregion arguments as REGION. For example, (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) ""FOO WINDOW")) creates a window titled "FOO WINDOW" on the color screen. To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the0CREATE SCREENREGION expression. Note that it is still perfectly legal to pass in a REGION that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW. This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor. This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens. 1 (WINDOWPROP WINDOW PROP NEWVALUE) [NoSpread Function] 1 If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on. If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error. Any other PROP name is handled in the usual way. 1 (OPENWINDOWS SCREEN) [Function] 1 Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN). If SCREEN=NIL, then SCREEN will default to the screen containing the cursor. If SCREEN=T, then a list of all open windows on all screens is returned. 1 2 Color Fonts 1 The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color. Color Font Creation 1 The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts. This is made possible in some cases by there being new ways to call familiar font functions. (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) [Function] 1 In addition to creating black and white fonts, FONTCREATE can be used to create color fonts. For example, (FONTCREATE 'GACHA 10 '(BOLD REGULAR REGULAR YELLOW BLUE) 0 '8DISPLAY) will create an 8 bit per pixel font with blue letters on a yellow background. The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE. DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font. A color font face is a 5 tuple, (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR) whereas a black and white font face is just a 3 tuple, (WEIGHT SLOPE EXPANSION) The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters. Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation. A color font face can also be represented as a LITATOM. A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes. For example, MRR-YELLOW-BLUE BOLD-YELLOW-RED ITALIC-90-200 BRR-100-53 are acceptable color font faces. Hence, (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY) will create a color font. LITATOM FACE arguments fall into one of the following patterns: wse wse-backcolor-forecolor STANDARD STANDARD-backcolor-forecolor ITALIC ITALIC-backcolor-forecolor BOLD BOLD-backcolor-forecolor BOLDITALIC BOLDITALIC-backcolor-forecolor where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number. 1 (FONTPROP FONT PROP) [Function] 1 Returns the value of the PROP property of font FONT. Besides black and white font properties, the following font properties are recognized: FORECOLOR The color of the characters of the font, represented as a color number. This is the color in which the characters of the font will print. BACKCOLOR The color of the background of the characters of the font, represented as a color number. This is the color in which the the background of characters of the font will print. A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR. Color Font Profiles 1 Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance. The user can specify that different colors of fonts be used for different kinds of elements when printing in color. A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example. A FONTPROFILE such as ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) ...) would have comments print in green and clisp words print in blue while ordinairy atoms would print in red. Not all combinations of fonts will be aesthetically pleasing and the user may have to experimĺL to find a compatible set. The user should indicate what font is to be used for each font class by calling the function FONTPROFILE: (FONTPROFILE PROFILE) [Function] 1 Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts. Each element of PROFILE is a list of the form: (FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1) ... (OTHERDEVICEn OTHERFONTn)) FONTCLASS is the font class name and FONT# is the font number for that class. DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively. The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED). 1 FONTPROFILE [Variable] 1 This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE. Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 1 2 Using Color 1 The current color implementation allows display streams to operate on color bitmaps. The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function. (DSPCOLOR COLOR STREAM) [Function] sets the foreground color of a stream. It returns the previous foreground color. If COLOR is NIL, it returns the current foreground color without changing anything. The default foreground color is MINIMUMCOLOR=0, which is white in the default color maps. (DSPBACKCOLOR COLOR STREAM) [Function] sets the background color of a stream. It returns the previous background color. If COLOR is NIL, it returns the current background color without changing anything. The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps. The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream. Following are some notes about them. 2 BITBLTing in Color 1 If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level. Thus painting color 3 onto color 10 results in color 11. If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR. BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy. If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color. Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT NIL NIL NIL COLORSTR 50 75 100 200 'TEXTURE 'REPLACE 'BLUE). 2 Drawing Curves and Lines in Color 1 For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color. A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR). Also, a brush can be a bitmap (which can be a color bitmap). Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap. (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR) [Function] (DRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (RELDRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (DRAWBETWEEN POS1 POS2 WIDTH OPERATION STREAM COLOR) [Function] If the COLOR argument is NIL, the DSPCOLOR of the stream is used. 2 Printing in Color 1 Printing only works in REPLACE mode. The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with. Example of printing to an 8bpp color screen: (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) @# Ş°ŞşşşşşşşşşşşşşşşşşşžtCőcőűú˘şşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşŤěCŹŕőcőűú˘şşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşýwCýőcőűżú˘şşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşşş  D + q  B  -  i  (  _    L    *  X = Ľ    * Ł    ?  N    ă  HRULE.GETFNMODERN _    +8 -   + Z    +& 8 ,   S       =     m + +) + +  +   + /  ę ŕ ľ ; č –  HRULE.GETFNMODERN HRULE.GETFNMODERNž      v 4       ) E ß   Ą  HRULE.GETFNMODERN HRULE.GETFN, HRULE.GETFNMODERN•  HRULE.GETFNMODERN ž      2  "  1  HRULE.GETFNMODERN +  + +    HRULE.GETFNMODERN  + Ş ' ) Ţ ) HRULE.GETFNMODERN‘    HRULE.GETFNMODERN + ë ? "  4  HRULE.GETFNMODERN + -  HRULE.GETFNMODERN + Š  ˆ ? "  a IOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))));ĚĚř ˜Ôř<ĚĚř ˜ÔřT,ĚĚř5ĚřşĚ,ĚĚř-KKřT3KĚřřT,ĚĚř9ĚĚř nřT3ĚĚřřT3ĚĚřřT3ĚĚřČT3ĚĚřČT3ĚĚř řT3ř2řT3řČT3řřT3řřT2ĚĚřř2ĚĚř ř3řČT3ř2ČT2ĚĚřČ2ĚĚř Č@ř PAGEHEADING VERSOHEAD@ř PAGEHEADING RECTOHEAD?ř PAGEHEADINGFOOTINGV?ř PAGEHEADINGFOOTINGR ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +MODERNMODERN MODERNMODERNMODERN +MODERN +MODERN +MODERN + HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN +   HRULE.GETFNMODERN +    HRULE.GETFNMODERN HRULE.GETFNMODERN  HRULE.GETFNMODERN ü ž ô K f   •  HRULE.GETFNMODERN' HRULE.GETFNMODERN + @ ú š  HRULE.GETFNMODERN. HRULE.GETFNMODERNî   @   +   W ü (   " ‚ =  HRULE.GETFNMODERN  HRULE.GETFNMODERNó +Ý ô É  `   HRULE.GETFNMODERN  ë   + ]  + > Ż  &           HRULE.GETFNMODERN  ż   + ¤     ?   =     Ë     "      "  HRULE.GETFNMODERN  HRULE.GETFNMODERNy    D + q  B  -  i  (  _    L    *  X = Ľ    * Ł    ?  N    ă  HRULE.GETFNMODERN _    +8 -   + Z    +& 8 ,   S       =     m + +) + +  +   + /  ę ŕ ľ ; č –  HRULE.GETFNMODERN HRULE.GETFNMODERNž      v 4       ) E ß   Ą  HRULE.GETFNMODERN HRULE.GETFN, HRULE.GETFNMODERN•  HRULE.GETFNMODERN ž      2  "  1  HRULE.GETFNMODERN +  + +    HRULE.GETFNMODERN  + Ş ' ) Ţ ) HRULE.GETFNMODERN‘    HRULE.GETFNMODERN + ë ? "  4  HRULE.GETFNMODERN + -  HRULE.GETFNMODERN + Š  ˆ ? "  a  HRULE.GETFNMODERN + C  HRULE.GETFNMODERN +  ( BMOBJ.GETFN3Í H Ę , BMOBJ.GETFN3Ü 1 @      HRULE.GETFNMODERN + '  HRULE.GETFNMODERN + đ  HRULE.GETFNMODERN +  HRULE.GETFNMODERN HRULE.GETFNMODERNď a IRM.GET.CREF ` ). As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display. (CREATEW REGION TITLE BORDERSIZE NOOPENFLG) [Function] 1 Creates a new window. REGION indicates where and how large the window should be by specifying the exterior screenregion of the window. In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of. This problem is solved by allowing CREATEW to take screenregion arguments as REGION. For example, (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) creates a window titled "FOO WINDOW" on the color screen. To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression. Note that it is still perfectly legal to pass in a REGION that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW. This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor. This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens. 1 (WINDOWPROP WINDOW PROP NEWVALUE) [NoSpread Function] 1 If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on. If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error. Any other PROP name is handled in the usual way. 1 (OPENWINDOWS SCREEN) [Function] 1 Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN). If SCREEN=NIL, then SCREEN will default to the screen containing the cursor. If SCREEN=T, then a list of all open windows on all screens is returned. 1 2 Color Fonts 1 The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color. Color Font Creation 1 The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts. This is made possible in some cases by there being new ways to call familiar font functions. (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) [Function] 1 In addition to creating black and white fonts, FONTCREATE can be used to create color fonts. For example, (FONTCREATE 'GACHA 10 '(BOLD REGULAR REGULAR YELLOW BLUE) 0 '8DISPLAY) will create an 8 bit per pixel font with blue letters on a yellow background. The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE. DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font. A color font face is a 5 tuple, (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR) whereas a black and white font face is just a 3 tuple, (WEIGHT SLOPE EXPANSION) The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters. Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation. A color font face can also be represented as a LITATOM. A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes. For example, MRR-YELLOW-BLUE BOLD-YELLOW-RED ITALIC-90-200 BRR-100-53 are acceptable color font faces. Hence, (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY) will create a color font. LITATOM FACE arguments fall into one of the following patterns: wse wse-backcolor-forecolor STANDARD STANDARD-backcolor-forecolor ITALIC ITALIC-backcolor-forecolor BOLD BOLD-backcolor-forecolor BOLDITALIC BOLDITALIC-backcolor-forecolor where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number. 1 (FONTPROP FONT PROP) [Function] 1 Returns the value of the PROP property of font FONT. Besides black and white font properties, the following font properties are recognized: FORECOLOR The color of the characters of the font, represented as a color number. This is the color in which the characters of the font will print. BACKCOLOR The color of the background of the characters of the font, represented as a color number. This is the color in which the the background of characters of the font will print. A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR. Color Font Profiles 1 Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance. The user can specify that different colors of fonts be used for different kinds of elements when printing in color. A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example. A FONTPROFILE such as ((DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8) (4DISPLAY (GACHA 10 MRR-WHITE-RED)) (8DISPLAY (GACHA 10 MRR-WHITE-RED))) (BOLDFONT 2 (HELVETICA 10 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR) (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) (LITTLEFONT 3 (HELVETICA 8) (HELVETICA 6 MIR) (MODERN 8 MIR) (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) (BIGFONT 4 (HELVETICA 12 BRR) (HELVETICA 10 BRR) (MODERN 10 BRR) (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) (USERFONT BOLDFONT) (COMMENTFONT LITTLEFONT) (LAMBDAFONT BIGFONT) (SYSTEMFONT) (CLISPFONT BOLDFONT) ...) would have comments print in green and clisp words print in blue while ordinairy atoms would print in red. Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set. The user should indicate what font is to be used for each font class by calling the function FONTPROFILE: (FONTPROFILE PROFILE) [Function] 1 Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts. Each element of PROFILE is a list of the form: (FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1) ... (OTHERDEVICEn OTHERFONTn)) FONTCLASS is the font class name and FONT# is the font number for that class. DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively. The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED). 1 FONTPROFILE [Variable] 1 This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE. Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 1 2 Using Color 1 The current color implementation allows display streams to operate on color bitmaps. The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function. (DSPCOLOR COLOR STREAM) [Function] sets the foreground color of a stream. It returns the previous foreground color. If COLOR is NIL, it returns the current foreground color without changing anything. The default foreground color is MINIMUMCOLOR=0, which is white in the default color maps. (DSPBACKCOLOR COLOR STREAM) [Function] sets the background color of a stream. It returns the previous background color. If COLOR is NIL, it returns the current background color without changing anything. The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps. The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream. Following are some notes about them. 2 BITBLTing in Color 1 If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level. Thus painting color 3 onto color 10 results in color 11. If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR. BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy. If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color. Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT NIL NIL NIL COLORSTR 50 75 100 200 'TEXTURE 'REPLACE 'BLUE). 2 Drawing Curves and Lines in Color 1 For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color. A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR). Also, a brush can be a bitmap (which can be a color bitmap). Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap. (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR) [Function] (DRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (RELDRAWTO X Y WIDTH OPERATION STREAM COLOR) [Function] (DRAWBETWEEN POS1 POS2 WIDTH OPERATION STREAM COLOR) [Function] If the COLOR argument is NIL, the DSPCOLOR of the stream is used. 2 Printing in Color 1 Printing only works in REPLACE mode. The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with. Example of printing to an 8bpp color screen: (SETQ FOO (CREATEW (CREATE SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ 20 BOTTOM _ 210 WIDTH _ 290 HEIGHT _ 170) "FOO WINDOW")) (DSPFONT (FONTCREATE 'GACHA 10 'MRR-YELLOW-GREEN 0 '8DISPLAY) FOO) (PRINT 'HELLO FOO) ; will print in green against a yellow background. 2 Operating the Cursor on the Color Screen 1 The cursor can be moved to the color screen. The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN. (CURSORPOSITION NEWPOSITION - -) [Function] 1 NEWPOSITION can be a position or a screenposition. (CURSORSCREEN SCREEN XCOORD YCOORD) [Function] 1 Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD. SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN). While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor. It is automatically taken down whenever an operation is performed that changes any bits on the color screen. The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen. While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time. 2 Miscellaneous Color Functions 1 (COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL) [Function] creates a color bitmap from a black and white bitmap. The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero. This provides a way of producing a color bitmap from a black and white bitmap. (UNCOLORIZEBITMAP BITMAP COLORMAP) [Function] creates a black and white bitmap from a color bitmap. (SHOWCOLORTESTPATTERN BARSIZE) [Function] displays a pattern of colors on the color display. This is useful when editing a color map. The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen. Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row. The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers. The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color˙˙ď%˙about 20). (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))));ĚĚř ˜Ôř<ĚĚř ˜ÔřT,ĚĚř5ĚřşĚ,ĚĚř-KKřT3KĚřřT,ĚĚř9ĚĚř nřT3ĚĚřřT3ĚĚřřT3ĚĚřČT3ĚĚřČT3ĚĚř řT3ř2řT3řČT3řřT3řřT2ĚĚřř2ĚĚř ř3řČT3ř2ČT2ĚĚřČ2ĚĚř Č@ř PAGEHEADING VERSOHEAD@ř PAGEHEADING RECTOHEAD?ř PAGEHEADINGFOOTINGV?ř PAGEHEADINGFOOTINGROPTIMA OPTIMAOPTIMA +OPTIMA +OPTIMA +OPTIMAOPTIMAOPTIMA + HRULE.GETFNOPTIMA +- HRULE.GETFNOPTIMA +- HRULE.GETFNOPTIMA + HRULE.GETFNOPTIMA +   HRULE.GETFNOPTIMA HRULE.GETFNOPTIMA  HRULE.GETFNOPTIMAüžôKf • HRULE.GETFNOPTIMA' HRULE.GETFNOPTIMA +@úš HRULE.GETFNOPTIMA. HRULE.GETFNOPTIMAî  @  + Wü("‚= HRULE.GETFNOPTIMA  HRULE.GETFNOPTIMAó +ÝôÉ` HRULE.GETFNOPTIMA ë  +] +>Ż & HRULE.GETFNOPTIMA ż  +¤  ?=Ë  "  " HRULE.GETFNOPTIMA  HRULE.GETFNOPTIMAy   D +q B - k ( a   N  *  X = Ľ   *Ł  ? N   ă HRULE.GETFNOPTIMA _  +8 -  + Z  +&8, S  =  m + +) + +   +  + /ęŕľ;č– HRULE.GETFNOPTIMA HRULE.GETFNOPTIMAž  v 4   ) Eß  Ą HRULE.GETFNOPTIMA HRULE.GETFN, HRULE.GETFNOPTIMA• HRULE.GETFNOPTIMA ž    2 "1 HRULE.GETFNOPTIMA +Â++  HRULE.GETFNOPTIMA  +Ş')Ţ) HRULE.GETFNOPTIMA‘  HRULE.GETFNOPTIMA +ë?"4 HRULE.GETFNOPTIMA +- HRULE.GETFNOPTIMA +Š ˆ?"a HRULE.GETFNOPTIMA +C HRULE.GETFNOPTIMA +( BMOBJ.GETFN3ÍHĘ, BMOBJ.GETFN3Ü1@     HRULE.GETFNOPTIMA +' HRULE.GETFNOPTIMA +đ HRULE.GETFNOPTIMA + HRULE.GETFNOPTIMA HRULE.GETFNOPTIMAď#4 IRM.GET.CREF Á? IRM.GET.CREF€ ! HRULE.GETFNOPTIMA +-n(`SVUWEň›sâ HRULE.GETFNOPTIMA +  HRULE.GETFNOPTIMA +- (=" HRULE.GETFNOPTIMA +  HRULE.GETFNOPTIMA +&A 7@ HRULE.GETFNOPTIMA + HRULE.GETFNOPTIMA  HRULE.GETFNOPTIMAy HRULE.GETFNOPTIMA č 3 HRULE.GETFNOPTIMA +kK4D27):[81863€ HRULE.GETFNOPTIMA + +  HRULE.GETFNOPTIMA +Z Œ  HRULE.GETFNOPTIMA ý    78%"<="$!;<$"89 k{k  HRULE.GETFNOPTIMA +*p    %  ň  [ +C HRULE.GETFNOPTIMA +  HRULE.GETFNOPTIMA + EÍ HRULE.GETFNOPTIMA + HRULE.GETFNOPTIMA  HRULE.GETFNOPTIMAç  V¨ Wžœ HRULE.GETFNOPTIMA HRULE.GETFNOPTIMAÝNPä HRULE.GETFNOPTIMA" HRULE.GETFNOPTIMAç”  +&     + +-   +5 5 HRULE.GETFNOPTIMA HRULE.GETFNOPTIMAľ-(`SVUWE=M=GF HRULE.GETFNOPTIMA) HRULE.GETFNOPTIMA÷  HRULE.GETFNOPTIMA + ( HRULE.GETFNOPTIMA +5>W HRULE.GETFNOPTIMA HRULE.GETFNOPTIMA ! \a  6  J€+}éÍzş \ No newline at end of file diff --git a/library/MAIKOCOLOR b/library/MAIKOCOLOR index 3af8c6cc..ce74bd7c 100644 --- a/library/MAIKOCOLOR +++ b/library/MAIKOCOLOR @@ -1,1001 +1,428 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "15-Jun-90 17:42:22" |{DSK}local>lde>lispcore>internal>library>MAIKOCOLOR.;2| 25610 -(FILECREATED "26-Oct-2021 10:53:57" {DSK}larry>medley>library>MAIKOCOLOR.;2 60141 + |changes| |to:| (VARS MAIKOCOLORCOMS) - changes to%: (VARS MAIKOCOLORCOMS) - (MACROS \MAIKO.CGTHREEP \MAIKO.CGFOURP \MAIKO.CGSIXP \MAIKO.CGTWOP) - (FNS \MAIKO.COLORINIT \MAIKO.STARTCOLOR \MAIKO.STOPCOLOR \MAIKOCOLOR.EVENTFN - \MAIKO.SENDCOLORMAPENTRY \MAIKO.CHANGESCREEN CURSOREXIT CURSORSCREEN - WARPCURSOR \SLOWBLTCHAR \SOFTCURSORUP \BITBLT.DISPLAY \PUNT.SLOWBLTCHAR - \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP BITMAPOBJ.SNAPW \MAIKO.PUNTBLTCHAR - \MAIKO.BLTCHAR) - - previous date%: "23-Oct-91 14:43:35" {DSK}larry>medley>library>MAIKOCOLOR.;1) + |previous| |date:| "22-Mar-89 02:08:31" +|{DSK}local>lde>lispcore>internal>library>MAIKOCOLOR.;1|) -(* ; " -Copyright (c) 1988-1991 by Fuji Xerox Co., Ltd.. -") +; Copyright (c) 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT MAIKOCOLORCOMS) (RPAQQ MAIKOCOLORCOMS - [(P (MOVD? 'BITBLT 'ORG.BITBLT) - (MOVD? 'BLTSHADE 'ORG.BLTSHADE) - (MOVD? '\SLOWBLTCHAR '\OLD.SLOWBLTCHAR) + ((P (MOVD? '\\SLOWBLTCHAR '\\OLD.SLOWBLTCHAR) (MOVD? 'CURSOREXIT 'OLD.CURSOREXIT) - (MOVD? '\SOFTCURSORUP '\OLD.SOFTCURSORUP)) - (FNS \MAIKO.COLORINIT \MAIKO.STARTCOLOR \MAIKO.STOPCOLOR \MAIKOCOLOR.EVENTFN - \MAIKO.SENDCOLORMAPENTRY \MAIKO.CHANGESCREEN) - (FNS CURSOREXIT CURSORSCREEN WARPCURSOR \SLOWBLTCHAR \SOFTCURSORUP \BITBLT.DISPLAY) - (* ; - "these FNS defs. will be moved to original files,later") - (FNS \PUNT.SLOWBLTCHAR \MAIKO.PUNTBLTCHAR \MAIKO.BLTCHAR) - (FNS \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP) - (FNS BITMAPOBJ.SNAPW) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \MAIKO.CGTHREEP \MAIKO.CGFOURP \MAIKO.CGSIXP - \MAIKO.CGTWOP) - (CONSTANTS (\TO.MAIKO.MONOSCREEN 0) - (\TO.MAIKO.COLORSCREEN 1) - (\MAIKO.COLORSCREENWIDTH 1152) - (\MAIKO.COLORSCREENHEIGHT 900) - (\MAIKO.COLORPAGES 2048) - (\MAIKO.COLORBUF.ALIGN 4095)) - (FILES (LOADCOMP) - LLDISPLAY BIGBITMAPS)) - (INITVARS \MONO.PROMPTWINDOW \COLOR.PROMPTWINDOW) + (MOVD? '\\SOFTCURSORUP '\\OLD.SOFTCURSORUP)) + (FNS \\MAIKO.COLORINIT \\MAIKO.STARTCOLOR \\MAIKO.STOPCOLOR \\MAIKO.EVENTFN + \\MAIKO.SENDCOLORMAPENTRY \\MAIKO.CHANGESCREEN) + (FNS \\COLORDISPLAYBITS CURSOREXIT \\SLOWBLTCHAR \\SOFTCURSORUP) + (MACROS \\MAIKO.CGFOURP \\MAIKO.CGTWOP) + (CONSTANTS (\\TO.MAIKO.MONOSCREEN 0) + (\\TO.MAIKO.COLORSCREEN 1) + (\\MAIKO.COLORSCREENWIDTH 1152) + (\\MAIKO.COLORSCREENHEIGHT 900) + (\\MAIKO.COLORPAGES 2048) + (\\MAIKO.COLORBUF.ALIGN 4095)) (GLOBALVARS MAIKOCOLOR.BITSPERPIXEL) - (FILES COLOR BIGBITMAPS) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'CURSOREXIT 'SAVE.CURSOREXIT) - (MOVD '\MAIKO.BLTCHAR '\BILTCHAR) - (\MAIKO.COLORINIT) - (COLORDISPLAY 'ON 'MAIKOCOLOR) - (CURSORSCREEN (COLORSCREEN) - 100 100) - (CHANGEBACKGROUND 36) - (ADD-EXEC :TTY T :REGION '(0 650 370 150)) - (LOGOW]) + (INITVARS (\\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN)) + (FILES COLOR) + (DECLARE\: DONTEVAL@LOAD DOCOPY (P (\\MAIKO.COLORINIT))))) -(MOVD? 'BITBLT 'ORG.BITBLT) - -(MOVD? 'BLTSHADE 'ORG.BLTSHADE) - -(MOVD? '\SLOWBLTCHAR '\OLD.SLOWBLTCHAR) +(MOVD? '\\SLOWBLTCHAR '\\OLD.SLOWBLTCHAR) (MOVD? 'CURSOREXIT 'OLD.CURSOREXIT) -(MOVD? '\SOFTCURSORUP '\OLD.SOFTCURSORUP) +(MOVD? '\\SOFTCURSORUP '\\OLD.SOFTCURSORUP) (DEFINEQ -(\MAIKO.COLORINIT - [LAMBDA NIL - (DECLARE (GLOBALVARS \MAIKOCOLORWSOPS \MAIKOCOLORINFO)) - (* ; - "Edited 28-Apr-89 16:51 by tshimizu.fx") - (SETQ \MAIKOCOLORWSOPS (create WSOPS - STARTBOARD _ (FUNCTION NILL) - STARTCOLOR _ (FUNCTION \MAIKO.STARTCOLOR) - STOPCOLOR _ (FUNCTION \MAIKO.STOPCOLOR) - EVENTFN _ (FUNCTION \MAIKOCOLOR.EVENTFN) - SENDCOLORMAPENTRY _ (FUNCTION \MAIKO.SENDCOLORMAPENTRY) - SENDPAGE _ (FUNCTION NILL) - PILOTBITBLT _ (FUNCTION \DISPLAY.PILOTBITBLT))) - (SETQ \MAIKOCOLORINFO (create DISPLAYINFO - DITYPE _ 'MAIKOCOLOR - DIWIDTH _ \MAIKO.COLORSCREENWIDTH - DIHEIGHT _ \MAIKO.COLORSCREENHEIGHT - DIBITSPERPIXEL _ 8 - DIWSOPS _ \MAIKOCOLORWSOPS)) - (\DEFINEDISPLAYINFO \MAIKOCOLORINFO]) +(\\MAIKO.COLORINIT + (LAMBDA NIL + (DECLARE (GLOBALVARS \\MAIKOCOLORWSOPS \\MAIKOCOLORINFO)) + (* \; "Edited 2-Nov-88 11:14 by shimizu") + (SETQ \\MAIKOCOLORWSOPS (|create| WSOPS + STARTBOARD _ (FUNCTION NILL) + STARTCOLOR _ (FUNCTION \\MAIKO.STARTCOLOR) + STOPCOLOR _ (FUNCTION NILL) + EVENTFN _ (FUNCTION NILL) + SENDCOLORMAPENTRY _ (FUNCTION \\MAIKO.SENDCOLORMAPENTRY) + SENDPAGE _ (FUNCTION NILL) + PILOTBITBLT _ (FUNCTION \\DISPLAY.PILOTBITBLT))) + (SETQ \\MAIKOCOLORINFO (|create| DISPLAYINFO + DITYPE _ 'MAIKOCOLOR + DIWIDTH _ \\MAIKO.COLORSCREENWIDTH + DIHEIGHT _ \\MAIKO.COLORSCREENHEIGHT + DIBITSPERPIXEL _ 8 + DIWSOPS _ \\MAIKOCOLORWSOPS)) + (\\DEFINEDISPLAYINFO \\MAIKOCOLORINFO))) -(\MAIKO.STARTCOLOR - [LAMBDA (FDEV) (* ; - "Edited 26-Oct-2021 10:17 by larry") - (* ; - "Edited 2-Nov-88 11:13 by shimizu") +(\\MAIKO.STARTCOLOR + (LAMBDA (FDEV) (* \; "Edited 2-Nov-88 11:13 by shimizu") (PROG (DISPLAYSTATE) - (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) - (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STARTCOLOR) - (MOVD '\DISPLAY.PILOTBITBLT '\SOFTCURSORPILOTBITBLT) + (SETQ DISPLAYSTATE (|fetch| (FDEV DEVICEINFO) |of| FDEV)) + (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'STARTCOLOR) + (MOVD '\\DISPLAY.PILOTBITBLT '\\SOFTCURSORPILOTBITBLT) - (* ;; " MMAP colorbuffer") + (* |;;| " MMAP colorbuffer") - (SUBRCALL COLOR-INIT (FETCH (BITMAP BITMAPBASE) OF ColorScreenBitMap)) - (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'ON]) + ((OPCODES SUBRCALL 136 1) + (FETCH (BITMAP BITMAPBASE) OF |ColorScreenBitMap|)) + (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'ON)))) -(\MAIKO.STOPCOLOR - [LAMBDA (FDEV) (* ; - "Edited 28-Apr-89 16:51 by tshimizu.fx") - (* ; "By Take") +(\\MAIKO.STOPCOLOR + (LAMBDA (FDEV) (* \; "Edited 12-Mar-89 20:02 by takeshi") + (* \; "By Take") (PROG (DISPLAYSTATE) - (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) - (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'OFF]) + (SETQ DISPLAYSTATE (|fetch| (FDEV DEVICEINFO) |of| FDEV)) + (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'STOPCOLOR) + (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'OFF)))) -(\MAIKOCOLOR.EVENTFN - [LAMBDA (FDEV EVENT) (* ; "Edited 23-Oct-91 14:18 by jds") +(\\MAIKO.EVENTFN + (LAMBDA (FDEV EVENT) (* \; "Edited 12-Mar-89 19:52 by takeshi") + (* \; "BY take") (COND - ((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV)) + ((EQ (|fetch| (DISPLAYSTATE ONOFF) |of| (|fetch| (FDEV DEVICEINFO) |of| FDEV)) 'ON) (SELECTQ EVENT - ((AFTERSAVEVM AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS) - (\MAIKO.STARTCOLOR \COLORDISPLAYFDEV) - (SCREENCOLORMAP (SCREENCOLORMAP)) - (COND - ((EQ LASTSCREEN (COLORSCREEN)) - (CURSORSCREEN (COLORSCREEN) - 200 200)))) - NIL]) + ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS) (* |turn| |off| |display| |since| + |we| |may| |awake| |on| |different| + |machine|) + (COLORDISPLAY 'OFF)) + (AFTERSAVEVM (* |Rekick| |the| |color| + |microcode.| *) + (\\MAIKO.STARTCOLOR \\COLORDISPLAYFDEV) + (SCREENCOLORMAP (SCREENCOLORMAP))) + NIL))))) -(\MAIKO.SENDCOLORMAPENTRY - [LAMBDA (FDEV COLOR# RGB) (* ; - "Edited 26-Oct-2021 10:17 by larry") - (* ; - "Edited 1-Dec-88 18:16 by shimizu") - (SUBRCALL COLOR-MAP COLOR# (CAR RGB) - (CADR RGB) - (CADDR RGB]) +(\\MAIKO.SENDCOLORMAPENTRY + (LAMBDA (FDEV COLOR# RGB) (* \; "Edited 1-Dec-88 18:16 by shimizu") + ((OPCODES SUBRCALL 138 4) + COLOR# + (CAR RGB) + (CADR RGB) + (CADDR RGB)))) -(\MAIKO.CHANGESCREEN - [LAMBDA (TOSCREEN) (* ; - "Edited 26-Oct-2021 10:18 by larry") - (* ; - "Edited 1-Dec-88 18:32 by shimizu") - (SUBRCALL COLOR-SCREENMODE TOSCREEN]) +(\\MAIKO.CHANGESCREEN + (LAMBDA (TOSCREEN) (* \; "Edited 1-Dec-88 18:32 by shimizu") + ((OPCODES SUBRCALL 137 1) + TOSCREEN))) ) (DEFINEQ +(\\COLORDISPLAYBITS + (LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* \; "Edited 22-Mar-89 02:07 by takeshi") + (* |returns| \a |pointer| |to| |the| + |bits| |that| |the| |color| |board| + |needs.|) + (DECLARE (GLOBALVARS \\COLORDISPLAYBITS)) + (COND + ((AND (EQ (MACHINETYPE) + 'MAIKO) + (OR (\\MAIKO.CGTWOP) + (\\MAIKO.CGFOURP))) + (PROG ((DUMMY (\\ALLOCPAGEBLOCK 1)) + (ADDROFFSET ((OPCODES SUBRCALL 139 0)))) + (WHILE (NEQ (LOGAND \\MAIKO.COLORBUF.ALIGN (IPLUS (\\LOLOC DUMMY) + ADDROFFSET)) + 0) DO (SETQ DUMMY (\\ALLOCPAGEBLOCK 1))) + (RETURN (OR (SETQ \\COLORDISPLAYBITS (\\ALLOCPAGEBLOCK \\MAIKO.COLORPAGES)) + (ERROR "No room for color screen of size" \\MAIKO.COLORPAGES))))) + (T (PROG (NPAGES) + + (* TBW\: I\f |you| |come| |through| |this| |function| \a |second| |time| |with| + |different| |screen| |params| |won't| |you| |get| |screwed| |half| |the| + |time?| *) + + (COND + ((NULL \\COLORDISPLAYBITS) (* 2 |extra| |pages| |needed| |for| + DORADOCOLOR |microcode| |bug.| + *) + (SETQ NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES WIDTH BITSPERPIXEL) + BITSPERWORD) + HEIGHT) + WORDSPERPAGE) + 2)) (* \\ALLOCBLOCK |can't| |hack| + |bitmaps| |of| |the| |size| |of| + |the| 1132 |color| |screen|) + (SETQ \\COLORDISPLAYBITS (COND + ((IGREATERP (UNFOLD NPAGES CELLSPERPAGE) + |\\MaxArrayNCells|) + (OR (\\ALLOCPAGEBLOCK NPAGES) + (ERROR "No room for color screen of size" NPAGES + ))) + (T (\\ALLOCBLOCK (UNFOLD NPAGES CELLSPERPAGE) + NIL NIL CELLSPERPAGE)))))) + (RETURN \\COLORDISPLAYBITS)))))) + (CURSOREXIT - [LAMBDA NIL (* ; - "Edited 11-Aug-89 13:16 by takeshi") + (LAMBDA NIL (* \; "Edited 2-Nov-88 13:11 by shimizu") - (* * called when cursor moves off the screen edge) + (* * |called| |when| |cursor| |moves| |off| |the| |screen| |edge|) - (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY \MAIKO.CURRENT.SCREEN.MODE)) + (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY \\MAIKO.CURRENT.SCREEN.MODE)) (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2) (SETQ SCREEN LASTSCREEN) (SETQ XCOORD LASTMOUSEX) (SETQ YCOORD LASTMOUSEY) - [SETQ SCREEN2 (COND - ((EQ SCREEN \MAINSCREEN) - (PROGN \COLORSCREEN)) - (T (PROGN \MAINSCREEN] (* generalize for more than two - screens (or alternate physical - arrangement of screens.)) + (SETQ SCREEN2 (COND + ((EQ SCREEN \\MAINSCREEN) + (PROGN \\COLORSCREEN)) + (T (PROGN \\MAINSCREEN)))) (* |generalize| |for| |more| |than| + |two| |screens| (|or| |alternate| + |physical| |arrangement| |of| + |screens.|)) (COND ((EQ XCOORD 0) - (SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2) + (SETQ XCOORD2 (IDIFFERENCE (|fetch| (SCREEN SCWIDTH) |of| SCREEN2) 2))) - ((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN))) + ((EQ XCOORD (SUB1 (|fetch| (SCREEN SCWIDTH) |of| SCREEN))) (SETQ XCOORD2 1)) (T (RETURN))) - [SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2)) - ) - (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN] - (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2]) - -(CURSORSCREEN - [LAMBDA (SCREEN XCOORD YCOORD) (* ; - "Edited 19-Jun-90 16:33 by matsuda") - - (* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos - of cursor on SCREEN) - - (COND - ((NULL XCOORD) - (SETQ XCOORD 0))) - (COND - ((NULL YCOORD) - (SETQ YCOORD 0))) - (PROG (DESTINATION) - (SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN)) - (\CURSORDOWN) - (SETQ \CURSORSCREEN SCREEN) - (\CURSORDESTINATION DESTINATION) - (\CURSORUP \CURRENTCURSOR) - (\CURSORPOSITION XCOORD YCOORD) + (SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (|fetch| (SCREEN SCHEIGHT) |of| + SCREEN2))) + (SUB1 (|fetch| (SCREEN SCHEIGHT) |of| SCREEN)))) + (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2) (AND (EQUAL (MACHINETYPE) 'MAIKO) (COND - ((EQ (fetch (SCREEN SCBITSPERPIXEL) of SCREEN) - 1) - (SETQ \COLOR.PROMPTWINDOW PROMPTWINDOW) - (\MAIKO.CHANGESCREEN \TO.MAIKO.MONOSCREEN) - (SETQ PROMPTWINDOW \MONO.PROMPTWINDOW)) - (T (SETQ \MONO.PROMPTWINDOW PROMPTWINDOW) - (\MAIKO.CHANGESCREEN \TO.MAIKO.COLORSCREEN) - (SETQ PROMPTWINDOW (OR \COLOR.PROMPTWINDOW - (PROG1 (SETQ W (CREATEW '(0 800 370 80) - "Prompt Window" 2)) - (SETQ DISPLAYDATA (FETCH IMAGEDATA - OF (FETCH (WINDOW DSP) - OF W))) - (REPLACE DDOPERATION OF DISPLAYDATA - WITH 'ERASE) - (REPLACE DDTexture OF DISPLAYDATA - WITH 65535) - (CLEARW W))]) + ((EQ \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN) + (\\MAIKO.CHANGESCREEN \\TO.MAIKO.COLORSCREEN) + (SETQ \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.COLORSCREEN)) + (T (\\MAIKO.CHANGESCREEN \\TO.MAIKO.MONOSCREEN) + (SETQ \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN))))))) -(WARPCURSOR - [LAMBDA (ENABLE) (* ; - "Edited 20-Jul-90 19:02 by matsuda") - (COND - (ENABLE (MOVD 'SAVE.CURSOREXIT 'CURSOREXIT) - T) - (T (MOVD 'NILL 'CURSOREXIT) - NIL]) +(\\SLOWBLTCHAR + (LAMBDA (CHARCODE DISPLAYSTREAM) (* \; "Edited 7-Dec-88 13:00 by shimizu") -(\SLOWBLTCHAR - [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; - "Edited 26-Oct-2021 10:19 by larry") - (* ; - "Edited 7-Jun-90 14:06 by matsuda") - (SUBRCALL C-SlowBltChar CHARCODE DISPLAYSTREAM]) - -(\SOFTCURSORUP - [LAMBDA (NEWCURSOR) (* ; - "Edited 16-Jan-89 15:44 by shimizu") - (* Put soft NEWCURSOR up, assuming - soft cursor is down. - *) - (COND - ((EQ \MACHINETYPE \MAIKO) - (SETQ \CURRENTCURSOR NEWCURSOR)) - (T (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE) - (* Get cursor IMAGE & MASK. - *) - (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR)) - (SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR)) - (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE)) - (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE)) - (SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)) - (* Create new UPBM & DOWNBM caches - if necessary. *) - (COND - ((NOT (AND (type? BITMAP \SOFTCURSORUPBM) - (EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM) - WIDTH) - (EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM) - HEIGHT) - (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM) - CURSORBITSPERPIXEL))) - (SETQ \SOFTCURSORWIDTH WIDTH) - (SETQ \SOFTCURSORHEIGHT HEIGHT) - (SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) - (SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) - (SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)) - (\TEMPLOCKPAGES UPBMBASE 1) - (SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)) - (\TEMPLOCKPAGES DOWNBMBASE 1) - (SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE) - BITSPERWORD)) - (SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE) - (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))) - (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL) - (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE) - (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL) - (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE) - (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL) - (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH) - (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT) - (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE) - (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL) - (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL) - (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH) - (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT) - (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE) - (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL) - (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL) - (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH) - (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT) - (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL) - (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL))) - (* Change PILOTBBTs. - *) - (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch - (BITMAP BITMAPBASE - ) - of MASK)) - (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch - (BITMAP BITMAPBASE - ) - of IMAGE)) - (* Put up new \CURRENTCURSOR. - *) - (SETQ \CURRENTCURSOR NEWCURSOR) - (\TEMPLOCKPAGES \CURRENTCURSOR 1) - (SETQ \SOFTCURSORP T) - (\SOFTCURSORUPCURRENT]) - -(\BITBLT.DISPLAY - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM) (* ; - "Edited 24-Jan-91 11:57 by matsuda") - (DECLARE (LOCALVARS . T)) - (DECLARE (GLOBALVARS \SYSPILOTBBT \SCREENBITMAPS \BBSCRATCHTEXTURE \SOFTCURSORP - \SOFTCURSORUPP \CURSORDESTINATION)) - (PROG (stodx stody left top bottom right DESTDD DESTBITMAP DESTINATIONNBITS SOURCENBITS MAXSHADE) - (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM)) - (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) - - (* ;; "bring it to top so that its TOTOPFNs will get called before the destination information is cached in case one of them moves, reshapes, etc. the window") - - (* ;; "We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic. But we might get interrupted before we go interruptable, so we do it there too.") - - (\INSURETOPWDS DESTSTRM) - (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) - (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) - [PROGN (* ; - "compute limits based on clipping regions.") - (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) - (SETQ bottom (ffetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) - (SETQ right (ffetch (\DISPLAYDATA DDClippingRight) of DESTDD)) - (SETQ top (ffetch (\DISPLAYDATA DDClippingTop) of DESTDD)) - (COND - (CLIPPINGREGION (* ; - "hard case, two destination clipping regions: do calculations to merge them.") - (PROG (CRLEFT CRBOTTOM) - [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX - (fetch (REGION LEFT) - of CLIPPINGREGION) - DESTDD] - [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY - (ffetch (REGION BOTTOM - ) - of CLIPPINGREGION) - DESTDD] - [SETQ right (IMIN right (IPLUS CRLEFT (ffetch (REGION WIDTH) - of CLIPPINGREGION] - (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) - of CLIPPINGREGION] - (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTBITMAP)) - (SETQ SOURCENBITS (BITSPERPIXEL SOURCEBITMAP)) - [COND - ((NOT (EQ SOURCENBITS DESTINATIONNBITS)) - (COND - ((EQ SOURCENBITS 1) - (SETQ SOURCEBITMAP (COLORIZEBITMAP SOURCEBITMAP (ffetch DDBACKGROUNDCOLOR - of DESTDD) - (ffetch DDFOREGROUNDCOLOR of DESTDD) - DESTINATIONNBITS))) - [(EQ DESTINATIONNBITS 1) - (SETQ SOURCEBITMAP (UNCOLORIZEBITMAP SOURCEBITMAP (COLORMAP DESTINATIONNBITS] - (T - (* ;; "Between two color bitmaps with different bpp. It seems that NOP is better than breaking. Eventually do some kind of output here, but don't error now. ") - - (RETURN] - - (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") - - [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) - (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) - [COND - (WIDTH (* ; "WIDTH is optional") - (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) - right] - (COND - (HEIGHT (* ; "HEIGHT is optional") - (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) - top] (* ; "Clip and translate coordinates.") - (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) - (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) - - (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") - - [PROGN (* ; "compute left margin") - (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx) - 0)) (* ; "compute bottom margin") - (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody) - 0)) (* ; "compute right margin") - (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP) - (IDIFFERENCE right stodx) - (IPLUS CLIPPEDSOURCELEFT WIDTH))) - (* ; "compute top margin") - (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) - (IDIFFERENCE top stody) - (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] - (COND - ((OR (ILEQ right left) - (ILEQ top bottom)) (* ; "there is nothing to move.") - (RETURN))) - (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) - (SETQ MAXSHADE (MAXIMUMSHADE DESTINATIONNBITS)) - (SELECTQ SOURCETYPE - (MERGE (* ; - "Need to use complement of TEXTURE") - [COND - ((AND (LISTP TEXTURE) - (EQ DESTINATIONNBITS 1)) (* ; - "either a color or a (texture color) filling.") - (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE] - [SETQ TEXTURE (COND - ((NULL TEXTURE) - MAXSHADE) - ((FIXP TEXTURE) - (LOGXOR (LOGAND TEXTURE MAXSHADE) - MAXSHADE)) - [(type? BITMAP TEXTURE) - (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE - (SETQ \BBSCRATCHTEXTURE - (BITMAPCREATE 16 16] - ((NOT (EQ DESTINATIONNBITS 1)) - (COLORNUMBERP TEXTURE DESTINATIONNBITS)) - (T (\ILLEGAL.ARG TEXTURE] - [COND - ((NOT (EQ DESTINATIONNBITS 1)) - (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS]) - (TEXTURE [COND - ((EQ DESTINATIONNBITS 1) (* ; - "either a color or a (texture color) filling.") - (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE]) - NIL) - [COND - ((AND (NOT (EQ DESTINATIONNBITS 1)) - (NOT (type? BIGBM SOURCEBITMAP)) - (NOT (type? BIGBM DESTBITMAP))) - (SETQ left (ITIMES DESTINATIONNBITS left)) - (SETQ right (ITIMES DESTINATIONNBITS right)) - (SETQ stodx (ITIMES DESTINATIONNBITS stodx] - [.WHILE.TOP.DS. DESTSTRM - (COND - [(AND (NOT (type? BIGBM SOURCEBITMAP)) - (NOT (type? BIGBM DESTBITMAP))) - (PROG (HEIGHT WIDTH DTY DLX STY SLX) - (SETQ HEIGHT (IDIFFERENCE top bottom)) - (SETQ WIDTH (IDIFFERENCE right left)) - (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) - (SETQ DLX (IPLUS left stodx)) - (SETQ STY (\SFInvert SOURCEBITMAP top)) - (SETQ SLX left) - (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) - (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) - (COND - ((EQ SOURCETYPE 'MERGE) - (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY - WIDTH HEIGHT OPERATION TEXTURE)) - (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY - HEIGHT SOURCETYPE OPERATION TEXTURE] - (T (PROG (HEIGHT WIDTH DBY DLX SBY SLX) - (SETQ HEIGHT (IDIFFERENCE top bottom)) - (SETQ WIDTH (IDIFFERENCE right left)) - (SETQ DBY (IPLUS bottom stody)) - (SETQ DLX (IPLUS left stodx)) - (SETQ SBY bottom) - (SETQ SLX left) - (BITBLT.BIGBM SOURCEBITMAP SLX SBY DESTBITMAP DLX DBY WIDTH HEIGHT - SOURCETYPE OPERATION TEXTURE] - (RETURN T]) -) - - - -(* ; "these FNS defs. will be moved to original files,later") - -(DEFINEQ - -(\PUNT.SLOWBLTCHAR - [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; - "Edited 2-Jul-90 14:23 by matsuda") - - (* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset") + (* |;;| "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset") (PROG (ROTATION CHAR8CODE DD FONTDESC) - (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) - (SETQ DD (ffetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) - (SETQ FONTDESC (ffetch (\DISPLAYDATA DDFONT) of DD)) - (SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of FONTDESC)) + (SETQ CHAR8CODE (\\CHAR8CODE CHARCODE)) + (SETQ DD (|ffetch| (STREAM IMAGEDATA) |of| DISPLAYSTREAM)) + (SETQ FONTDESC (|ffetch| (\\DISPLAYDATA DDFONT) |of| DD)) + (SETQ ROTATION (|ffetch| (FONTDESCRIPTOR ROTATION) |of| FONTDESC)) (COND ((EQ 0 ROTATION) (PROG (NEWX LEFT RIGHT CURX PILOTBBT DESTBIT WIDTH SOURCEBIT CSINFO) - (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - (ffetch (\DISPLAYDATA DDFONT) of DD))) - (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) - (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))) - [COND - ((IGREATERP NEWX (ffetch (\DISPLAYDATA DDRightMargin) of DD)) - (* ; "past RIGHT margin, force eol") - (\DSPPRINTCR/LF (CHARCODE EOL) + (SETQ CSINFO (\\GETCHARSETINFO (\\CHARSET CHARCODE) + (|ffetch| (\\DISPLAYDATA DDFONT) |of| DD))) + (SETQ CURX (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| DD)) + (SETQ NEWX (IPLUS CURX (\\DSPGETCHARWIDTH CHAR8CODE DD))) + (COND + ((IGREATERP NEWX (|ffetch| (\\DISPLAYDATA |DDRightMargin|) |of| DD)) + (* \; "past RIGHT margin, force eol") + (\\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) - (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) - (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD] - (* ; "update the x position.") - (freplace (\DISPLAYDATA DDXPOSITION) of DD with NEWX) - (* SETQ CURX (\DSPTRANSFORMX CURX DD)) - (SETQ LEFT (IMAX (ffetch (\DISPLAYDATA DDClippingLeft) of DD) + (SETQ CURX (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| DD)) + (SETQ NEWX (IPLUS CURX (\\DSPGETCHARWIDTH CHAR8CODE DD))))) + (* \; "update the x position.") + (|freplace| (\\DISPLAYDATA DDXPOSITION) |of| DD |with| NEWX) + (* SETQ CURX (\\DSPTRANSFORMX CURX + DD)) + (SETQ LEFT (IMAX (|ffetch| (\\DISPLAYDATA |DDClippingLeft|) |of| DD) CURX)) - (SETQ RIGHT (IMIN (ffetch (\DISPLAYDATA DDClippingRight) of DD) - (\DSPTRANSFORMX NEWX DD))) - (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) - (\DSPGETCHAROFFSET CHAR8CODE DD) - 0 DISPLAYSTREAM CURX (IDIFFERENCE (ffetch (\DISPLAYDATA DDYPOSITION) - of DD) - (ffetch (CHARSETINFO CHARSETDESCENT) - of CSINFO)) - (\DSPGETCHARWIDTH CHAR8CODE DD) - (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) - (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) - (* ; "(SETQ PILOTBBT (|ffetch| (\\DISPLAYDATA DDPILOTBBT) |of| DD)) (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (|ffetch| (PILOTBBT PBTHEIGHT) |of| PILOTBBT) 0))) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (|ffetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|ffetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) (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| PILOTBBT |with| DESTBIT) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOTBBT |with| WIDTH) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOTBBT |with| SOURCEBIT) (\\PILOTBITBLT PILOTBBT 0)) T))") + (SETQ RIGHT (IMIN (|ffetch| (\\DISPLAYDATA |DDClippingRight|) |of| DD) + (\\DSPTRANSFORMX NEWX DD))) + (BITBLT (|ffetch| (CHARSETINFO CHARSETBITMAP) |of| CSINFO) + (\\DSPGETCHAROFFSET CHAR8CODE DD) + 0 DISPLAYSTREAM CURX (ADD1 (IDIFFERENCE (|ffetch| (\\DISPLAYDATA + DDYPOSITION) + |of| DD) + (|ffetch| (CHARSETINFO + CHARSETDESCENT) + |of| CSINFO))) + (\\DSPGETCHARWIDTH CHAR8CODE DD) + (IPLUS (|ffetch| (CHARSETINFO CHARSETASCENT) |of| CSINFO) + (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO))) + (* \; "(SETQ PILOTBBT (|ffetch| (\\\\DISPLAYDATA DDPILOTBBT) |of| DD)) (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (|ffetch| (PILOTBBT PBTHEIGHT) |of| PILOTBBT) 0))) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\\\\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (|ffetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|ffetch| (\\\\DISPLAYDATA |DDDestination|) |of| DD)) (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| PILOTBBT |with| DESTBIT) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOTBBT |with| WIDTH) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOTBBT |with| SOURCEBIT) (\\\\PILOTBITBLT PILOTBBT 0)) T))") )) - (T (* ; "handle rotated fonts") + (T (* \; "handle rotated fonts") (PROG (YPOS HEIGHTMOVED CSINFO) - (SETQ YPOS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)) - (SETQ HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD)) - (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - (ffetch (\DISPLAYDATA DDFONT) of DD))) + (SETQ YPOS (|ffetch| (\\DISPLAYDATA DDYPOSITION) |of| DD)) + (SETQ HEIGHTMOVED (\\DSPGETCHARWIDTH CHAR8CODE DD)) + (SETQ CSINFO (\\GETCHARSETINFO (\\CHARSET CHARCODE) + (|ffetch| (\\DISPLAYDATA DDFONT) |of| DD))) (COND - ((EQ ROTATION 90) (* ; - "don't force CR for rotated fonts.") - (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) - (* ; - "update the display stream x position.") - (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) + ((EQ ROTATION 90) (* \; + "don't force CR for rotated fonts.") + (\\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) + (* \; + "update the display stream x position.") + (BITBLT (|ffetch| (CHARSETINFO CHARSETBITMAP) |of| CSINFO) 0 - (\DSPGETCHAROFFSET CHAR8CODE DD) + (\\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM - (ADD1 (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) - of DD) - (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)) - ) + (ADD1 (IDIFFERENCE (|ffetch| (\\DISPLAYDATA DDXPOSITION) + |of| DD) + (|ffetch| (CHARSETINFO CHARSETASCENT) |of| + CSINFO))) YPOS - (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) - (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (IPLUS (|ffetch| (CHARSETINFO CHARSETASCENT) |of| CSINFO) + (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO)) HEIGHTMOVED)) ((EQ ROTATION 270) - (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) - (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) + (\\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) + (BITBLT (|ffetch| (CHARSETINFO CHARSETBITMAP) |of| CSINFO) 0 - (\GETBASE (ffetch (\DISPLAYDATA DDOFFSETSCACHE) of DD) + (\\GETBASE (|ffetch| (\\DISPLAYDATA DDOFFSETSCACHE) |of| + DD) CHAR8CODE) DISPLAYSTREAM - (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) - (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) - (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYSTREAM) - (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) - (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (IDIFFERENCE (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| + DD) + (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO)) + (|ffetch| (\\DISPLAYDATA DDYPOSITION) |of| DISPLAYSTREAM) + (IPLUS (|ffetch| (CHARSETINFO CHARSETASCENT) |of| CSINFO) + (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO)) HEIGHTMOVED)) - (T (ERROR "Not implemented to rotate by other than 0, 90 or 270"]) + (T (ERROR "Not implemented to rotate by other than 0, 90 or 270"))))))))) -(\MAIKO.PUNTBLTCHAR - [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; - "Edited 26-Oct-2021 10:21 by larry") - (* ; - "Edited 1-Nov-89 15:26 by takeshi") +(\\SOFTCURSORUP + (LAMBDA (NEWCURSOR) (* \; "Edited 16-Jan-89 15:44 by shimizu") + (* |Put| |soft| NEWCURSOR |up,| + |assuming| |soft| |cursor| |is| + |down.| *) + (COND + ((EQ \\MACHINETYPE \\MAIKO) + (SETQ \\CURRENTCURSOR NEWCURSOR)) + (T (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE) + " (* |Get| |cursor| IMAGE & MASK. + ( *) + (SETQ IMAGE (|fetch| (CURSOR CUIMAGE) |of| NEWCURSOR)) + (* move 4 bits from source to + destination.) + [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET + (2 (fetch (TWOOFFSETBITACCESS BITS2TO5 + ) of SBASE)) + (6 (fetch (TWOOFFSETBITACCESS BITS6TO9 + ) of SBASE)) + (10 (fetch (TWOOFFSETBITACCESS + BITS10TO13) + of SBASE)) + (LOGOR (LLSH (fetch ( + TWOOFFSETBITACCESS + BITS14TO15) + of SBASE) + 2) + (fetch (TWOOFFSETBITACCESS + BITS0TO1) + of (SETQ SBASE + (\ADDBASE SBASE 1] + (SETQ DBASE (\ADDBASE DBASE 1)) + (SETQ WIDTH (IDIFFERENCE WIDTH 4)) + (COND + ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) + 18) + + (* SBASE has already been incremented as part of fetching the last 4 bits.) - (* ;; "puts a character on a display stream. This function will be called when \maiko.bltchar failed. Punt from subr call") + (SETQ SBITOFFSET 2))) + (GO ONEWRDLP))) + LP (COND + ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.) + (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS2TO5) + of SBASE))) + (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS6TO9) + of SBASE))) + (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS10TO13) + of SBASE))) + [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (TWOOFFSETBITACCESS + BITS14TO15) + of SBASE) + 2) + (fetch (TWOOFFSETBITACCESS BITS0TO1) + of (SETQ SBASE (\ADDBASE SBASE 1] + (SETQ DBASE (\ADDBASE DBASE 4)) + (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) + (GO LP)) + (T (* finish off last less than 16 bits.) + (GO ONEWRDLP]) + (PROG NIL + + (* moving bits that are aligned with 3 extra bits in the following word of the + source.) - (DECLARE (LOCALVARS . T)) - (PROG (LOCAL1 RIGHT LEFT CURX CHAR8CODE) - (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) - CRLP - [COND - ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) - (\CHARSET CHARCODE))) - (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE] - [COND - ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA) - (RETURN (COND - ((type? STREAM DISPLAYSTREAM) - (\SLOWBLTCHAR CHARCODE DISPLAYSTREAM)) - ((type? WINDOW DISPLAYSTREAM) - (\SLOWBLTCHAR CHARCODE (FETCH DSP OF DISPLAYSTREAM))) - (T (ERROR "Not Stream or Window" DISPLAYSTREAM] - (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA)) - (SETQ RIGHT (IPLUS CURX (\DSPGETCHARIMAGEWIDTH CHAR8CODE DISPLAYDATA))) - [COND - ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA)) - (* ; - "would go past right margin, force a cr") + ONEWRDLP + (* SBITOFFSET is either 3, 7, 11 or 15) (COND - ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA)) - (* ; - "don't bother CR if position is at left margin anyway. This also serves to break the loop.") - (\DSPPRINTCR/LF (CHARCODE EOL) - DISPLAYSTREAM) (* ; - "reuse the code in the test of this conditional rather than repeat it here.") - (GO CRLP] (* ; - "update the display stream x position.") - (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX - ( - \DSPGETCHARWIDTH - CHAR8CODE - DISPLAYDATA))) - (* ; - "transforms an x coordinate into the destination coordinate.") - (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)) - (SETQ CURX (IPLUS CURX LOCAL1)) - (SETQ RIGHT (IPLUS RIGHT LOCAL1)) - (COND - ((IGREATERP RIGHT (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingRight) of - DISPLAYDATA - ))) (* ; - "character overlaps right edge of clipping region.") - (SETQ RIGHT LOCAL1))) - (SETQ LEFT (COND - ((IGREATERP CURX (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingLeft) - of DISPLAYDATA))) - CURX) - (T LOCAL1))) - (RETURN (COND - ((AND (ILESSP LEFT RIGHT) - (NOT (EQ (fetch (PILOTBBT PBTHEIGHT) of (SETQ LOCAL1 - (ffetch (\DISPLAYDATA - DDPILOTBBT) - of DISPLAYDATA))) - 0))) - (.WHILE.TOP.DS. DISPLAYSTREAM (SUBRCALL BLTCHAR LOCAL1 DISPLAYDATA CHAR8CODE - CURX LEFT RIGHT)) - T]) - -(\MAIKO.BLTCHAR - [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; - "Edited 26-Oct-2021 10:22 by larry") - (* ; - "Edited 6-Jul-90 10:14 by matsuda") - (SUBRCALL NEW-BLTCHAR CHARCODE DISPLAYSTREAM DISPLAYDATA]) + ((AND (EQ SBITOFFSET 3) + (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) + (GO LP)) + ((IGREATERP 4 WIDTH) + [PROG (SWORDCONTENTS) + (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) + (SELECTQ WIDTH + (0) + (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND + ((ZEROP (LOGAND SWORDCONTENTS + (\BITMASK + SBITOFFSET) + )) + 0COLOR) + (T 1COLOR)) + 4) + (LOGAND (\GETBASEBYTE DBASE 0) + |with| (|fetch| (BITMAP BITMAPBASE) |of| MASK)) + (|replace| (PILOTBBT PBTSOURCE) |of| \\SOFTCURSORBBT4 + |with| (|fetch| (BITMAP BITMAPBASE) |of| IMAGE)) + (* |Put| |up| |new| \\CURRENTCURSOR. + *) + (SETQ \\CURRENTCURSOR NEWCURSOR) + (\\TEMPLOCKPAGES \\CURRENTCURSOR 1) + (SETQ \\SOFTCURSORP T) + (\\SOFTCURSORUPCURRENT)))))) ) -(DEFINEQ +(DECLARE\: EVAL@COMPILE -(\PUNT.BLTSHADE.BITMAP - [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION - CLIPPINGREGION) (* ; - "Edited 5-Jun-90 12:12 by Takeshi") +(PUTPROPS \\MAIKO.CGFOURP MACRO (NIL (EQ (LOGAND 120 (|fetch| DEVCONFIG |of| + |\\InterfacePage| + )) + 64))) - (* ;; "This FNS is for a punt case of \BLTSHADE.BITMAP which is implemeted in C ") - (* ; - " Stolen from old definition of \BLTSHADE.BITMAP") - (DECLARE (LOCALVARS . T)) - (PROG (left bottom top right DESTINATIONNBITS) - (SETQ left 0) - (SETQ bottom 0) - (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTINATIONBITMAP)) - (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTINATIONBITMAP)) - (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)) - (COND - ((EQ DESTINATIONNBITS 1) (* ; - "DESTINATIONNBITS is NIL for the case of 1 bit per pixel.") - (SETQ DESTINATIONNBITS NIL))) - [COND - (CLIPPINGREGION (* ; "adjust limits") - (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) - (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) - [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) - (fetch (REGION LEFT) of CLIPPINGREGION] - (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) - (fetch (REGION HEIGHT) of CLIPPINGREGION] - (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) - (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) - - (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") - - [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) - (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) - [COND - (WIDTH (* ; "WIDTH is optional") - (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) - right] - (COND - (HEIGHT (* ; "HEIGHT is optional") - (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) - top] - (COND - ((OR (ILEQ right left) - (ILEQ top bottom)) (* ; "there is nothing to move.") - (RETURN))) - (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) - (LITATOM (* ; "includes NIL case") - (COND - [DESTINATIONNBITS (COND - (TEXTURE - (* ; "should be a color name") - (OR (COLORNUMBERP TEXTURE - DESTINATIONNBITS T) - (\ILLEGAL.ARG TEXTURE))) - (T (MAXIMUMCOLOR DESTINATIONNBITS] - (TEXTURE (\ILLEGAL.ARG TEXTURE)) - (T WHITESHADE))) - ((SMALLP FIXP) - (COND - [DESTINATIONNBITS - - (* ;; "if fixp use the low order bits as a color number. This picks up the case of BLACKSHADE being used to INVERT.") - - (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) - (LOGAND TEXTURE (MAXIMUMCOLOR DESTINATIONNBITS] - (T (LOGAND TEXTURE BLACKSHADE)))) - (BITMAP TEXTURE) - (LISTP (* ; - "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") - (COND - [DESTINATIONNBITS - - (* ;; "color case: If it is a color, use it; if it is a list that contains a color, use that; otherwise, use the texture") - - (COND - ((COLORNUMBERP TEXTURE)) - [(COLORNUMBERP (CAR (LISTP (CDR TEXTURE] - ((FIXP (CAR TEXTURE)) - (LOGAND (CAR TEXTURE) - (MAXIMUMCOLOR DESTINATIONNBITS))) - ((TEXTUREP (CAR TEXTURE))) - (T (\ILLEGAL.ARG TEXTURE] - ((TEXTUREP (CAR TEXTURE))) - ((COLORNUMBERP TEXTURE) - (TEXTUREOFCOLOR TEXTURE)) - (T (\ILLEGAL.ARG TEXTURE)))) - (\ILLEGAL.ARG TEXTURE))) (* ; "filling an area with a texture.") - [COND - (DESTINATIONNBITS (SETQ left (ITIMES DESTINATIONNBITS left)) - (SETQ right (ITIMES DESTINATIONNBITS right)) - (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS] - (* ; - "easy case of black and white bitmap into black and white or color to color or texture filling.") - (UNINTERRUPTABLY - (PROG (HEIGHT) - (SETQ HEIGHT (IDIFFERENCE top bottom)) - (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with (IDIFFERENCE right - left)) - (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) - (\BITBLTSUB \SYSPILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert - DESTINATIONBITMAP - top) - HEIGHT - 'TEXTURE OPERATION TEXTURE))) - (RETURN T]) - -(\PUNT.BITBLT.BITMAP - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM) (* ; - "Edited 5-Jun-90 11:59 by Takeshi") - - (* ;; " This FNS is for a punt case of \BITBLT.BITMAP which is implemeted in C") - - (* ;; " Stolen from old definition of \BITBLT.BITMAP") - - (DECLARE (LOCALVARS . T)) - (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) - (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP)) - (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) - (SETQ left 0) - (SETQ bottom 0) - (SETQ SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) - (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTBITMAP)) - [COND - (CLIPPINGREGION (* ; "adjust limits") - (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) - (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) - [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) - (fetch (REGION LEFT) of CLIPPINGREGION] - (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) - (fetch (REGION HEIGHT) of CLIPPINGREGION] - - (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") - - [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) - (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) - [COND - (WIDTH (* ; "WIDTH is optional") - (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) - right] - (COND - (HEIGHT (* ; "HEIGHT is optional") - (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) - top] (* ; "Clip and translate coordinates.") - (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) - (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) - - (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") - - [PROGN (* ; "compute left margin") - (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) - (* ; "compute bottom margin") - (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) - (* ; "compute right margin") - (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) - (IDIFFERENCE right stodx) - (IPLUS CLIPPEDSOURCELEFT WIDTH))) - (* ; "compute top margin") - (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) - (IDIFFERENCE top stody) - (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] - (COND - ((OR (ILEQ right left) - (ILEQ top bottom)) (* ; "there is nothing to move.") - (RETURN))) - (SELECTQ SOURCETYPE - (MERGE (* ; - "Need to use complement of TEXTURE") - (* ; "MAY NOT WORK FOR COLOR CASE.") - [SETQ TEXTURE (COND - ((NULL TEXTURE) - BLACKSHADE) - ((FIXP TEXTURE) - (LOGXOR (LOGAND TEXTURE BLACKSHADE) - BLACKSHADE)) - ((AND (NOT (EQ DESTINATIONNBITS 1)) - (COLORNUMBERP TEXTURE DESTINATIONNBITS))) - [(type? BITMAP TEXTURE) - (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE - (SETQ \BBSCRATCHTEXTURE - (BITMAPCREATE 16 16] - (T (\ILLEGAL.ARG TEXTURE]) - NIL) - (COND - [(EQ SOURCENBITS DESTINATIONNBITS) (* ; - "going from one to another of the same size.") - (SELECTQ DESTINATIONNBITS - (4 (* ; - "use UNFOLD with constant value rather than multiple because it compiles into opcodes.") - (SETQ left (UNFOLD left 4)) - (SETQ right (UNFOLD right 4)) - (SETQ stodx (UNFOLD stodx 4)) (* ; - "set texture if it will ever get looked at.") - (AND (EQ SOURCETYPE 'MERGE) - (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) - (8 (SETQ left (UNFOLD left 8)) - (SETQ right (UNFOLD right 8)) - (SETQ stodx (UNFOLD stodx 8)) - (AND (EQ SOURCETYPE 'MERGE) - (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) - (24 (SETQ left (ITIMES left 24)) - (SETQ right (ITIMES right 24)) - (SETQ stodx (ITIMES stodx 24)) - (AND (EQ SOURCETYPE 'MERGE) - (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) - NIL) (* ; - "easy case of black and white bitmap into black and white or color to color or texture filling.") - (UNINTERRUPTABLY - [PROG (HEIGHT WIDTH DTY DLX STY SLX) - (SETQ HEIGHT (IDIFFERENCE top bottom)) - (SETQ WIDTH (IDIFFERENCE right left)) - (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) - (SETQ DLX (IPLUS left stodx)) - (SETQ STY (\SFInvert SOURCEBITMAP top)) - (SETQ SLX left) - (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) - (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) - (COND - ((EQ SOURCETYPE 'MERGE) - (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH - HEIGHT OPERATION TEXTURE)) - (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT - SOURCETYPE OPERATION TEXTURE])] - [(EQ SOURCENBITS 1) (* ; - "going from a black and white bitmap to a color map") - (AND SOURCETYPE (NOT (EQ SOURCETYPE 'INPUT)) - (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) - (PROG (HEIGHT WIDTH DBOT DLFT) - (SETQ HEIGHT (IDIFFERENCE top bottom)) - (SETQ WIDTH (IDIFFERENCE right left)) - (SETQ DBOT (IPLUS bottom stody)) - (SETQ DLFT (IPLUS left stodx)) - (SELECTQ OPERATION - ((NIL REPLACE) - (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH - HEIGHT 0 (MAXIMUMCOLOR DESTINATIONNBITS) - DESTINATIONNBITS)) - (PAINT) - (INVERT) - (ERASE) - (SHOULDNT] - (T (* ; - "going from color map into black and white map.") - (ERROR "not implemented to blt between bitmaps of different pixel size."))) - (RETURN T]) -) -(DEFINEQ - -(BITMAPOBJ.SNAPW - [LAMBDA NIL (* ; - "Edited 12-Apr-90 09:09 by matsuda") - - (* * makes an image object of a prompted for region of the screen.) - - (PROG ((REG (GETREGION)) - BM) - [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REG) - (fetch (REGION HEIGHT) of REG) - (BITSPERPIXEL (SCREENBITMAP \CURSORSCREEN] - (BITBLT (SCREENBITMAP \CURSORSCREEN) - (fetch (REGION LEFT) of REG) - (fetch (REGION BOTTOM) of REG) - BM 0 0 NIL NIL 'INPUT 'REPLACE) - (COPYINSERT (BITMAPTEDITOBJ BM 1 0)) - (RETURN]) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -[PROGN (DEFMACRO \MAIKO.CGTHREEP () - (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage)) - 48)) - (PUTPROPS \MAIKO.CGTHREEP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of - - \InterfacePage - )) - 48)))] - -(PUTPROPS \MAIKO.CGFOURP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of - \InterfacePage +(PUTPROPS \\MAIKO.CGTWOP MACRO (NIL (EQ (LOGAND 120 (|fetch| DEVCONFIG |of| + |\\InterfacePage| )) - 64))) - -[PROGN (DEFMACRO \MAIKO.CGSIXP () - (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage)) - 96)) - (PUTPROPS \MAIKO.CGSIXP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of - \InterfacePage - )) - 96)))] - -(PUTPROPS \MAIKO.CGTWOP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage - )) - 24))) + 24))) ) +(DECLARE\: EVAL@COMPILE -(DECLARE%: EVAL@COMPILE +(RPAQQ \\TO.MAIKO.MONOSCREEN 0) -(RPAQQ \TO.MAIKO.MONOSCREEN 0) +(RPAQQ \\TO.MAIKO.COLORSCREEN 1) -(RPAQQ \TO.MAIKO.COLORSCREEN 1) +(RPAQQ \\MAIKO.COLORSCREENWIDTH 1152) -(RPAQQ \MAIKO.COLORSCREENWIDTH 1152) +(RPAQQ \\MAIKO.COLORSCREENHEIGHT 900) -(RPAQQ \MAIKO.COLORSCREENHEIGHT 900) +(RPAQQ \\MAIKO.COLORPAGES 2048) -(RPAQQ \MAIKO.COLORPAGES 2048) - -(RPAQQ \MAIKO.COLORBUF.ALIGN 4095) +(RPAQQ \\MAIKO.COLORBUF.ALIGN 4095) -(CONSTANTS (\TO.MAIKO.MONOSCREEN 0) - (\TO.MAIKO.COLORSCREEN 1) - (\MAIKO.COLORSCREENWIDTH 1152) - (\MAIKO.COLORSCREENHEIGHT 900) - (\MAIKO.COLORPAGES 2048) - (\MAIKO.COLORBUF.ALIGN 4095)) +(CONSTANTS (\\TO.MAIKO.MONOSCREEN 0) + (\\TO.MAIKO.COLORSCREEN 1) + (\\MAIKO.COLORSCREENWIDTH 1152) + (\\MAIKO.COLORSCREENHEIGHT 900) + (\\MAIKO.COLORPAGES 2048) + (\\MAIKO.COLORBUF.ALIGN 4095)) ) - - -(FILESLOAD (LOADCOMP) - LLDISPLAY BIGBITMAPS) -) - -(RPAQ? \MONO.PROMPTWINDOW NIL) - -(RPAQ? \COLOR.PROMPTWINDOW NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY +(DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MAIKOCOLOR.BITSPERPIXEL) ) -(FILESLOAD COLOR BIGBITMAPS) -(DECLARE%: DONTEVAL@LOAD DOCOPY +(RPAQ? \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN) -(MOVD 'CURSOREXIT 'SAVE.CURSOREXIT) +(FILESLOAD COLOR) +(DECLARE\: DONTEVAL@LOAD DOCOPY -(MOVD '\MAIKO.BLTCHAR '\BILTCHAR) - -(\MAIKO.COLORINIT) - -(COLORDISPLAY 'ON 'MAIKOCOLOR) - -(CURSORSCREEN (COLORSCREEN) - 100 100) - -(CHANGEBACKGROUND 36) - -(ADD-EXEC :TTY T :REGION '(0 650 370 150)) - -(LOGOW) +(\\MAIKO.COLORINIT) ) -(PUTPROPS MAIKOCOLOR COPYRIGHT ("Fuji Xerox Co., Ltd." 1988 1989 1990 1991)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3229 7254 (\MAIKO.COLORINIT 3239 . 4475) (\MAIKO.STARTCOLOR 4477 . 5293) ( -\MAIKO.STOPCOLOR 5295 . 5749) (\MAIKOCOLOR.EVENTFN 5751 . 6382) (\MAIKO.SENDCOLORMAPENTRY 6384 . 6842) - (\MAIKO.CHANGESCREEN 6844 . 7252)) (7255 28244 (CURSOREXIT 7265 . 8769) (CURSORSCREEN 8771 . 10877) ( -WARPCURSOR 10879 . 11194) (\SLOWBLTCHAR 11196 . 11608) (\SOFTCURSORUP 11610 . 17471) (\BITBLT.DISPLAY -17473 . 28242)) (28315 40283 (\PUNT.SLOWBLTCHAR 28325 . 35163) (\MAIKO.PUNTBLTCHAR 35165 . 39855) ( -\MAIKO.BLTCHAR 39857 . 40281)) (40284 56617 (\PUNT.BLTSHADE.BITMAP 40294 . 47386) (\PUNT.BITBLT.BITMAP - 47388 . 56615)) (56618 57426 (BITMAPOBJ.SNAPW 56628 . 57424))))) +(PUTPROPS MAIKOCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (1501 5202 (\\MAIKO.COLORINIT 1511 . 2684) (\\MAIKO.STARTCOLOR 2686 . 3306) ( +\\MAIKO.STOPCOLOR 3308 . 3797) (\\MAIKO.EVENTFN 3799 . 4791) (\\MAIKO.SENDCOLORMAPENTRY 4793 . 5021) ( +\\MAIKO.CHANGESCREEN 5023 . 5200)) (5203 24135 (\\COLORDISPLAYBITS 5213 . 8105) (CURSOREXIT 8107 . +10172) (\\SLOWBLTCHAR 10174 . 17604) (\\SOFTCURSORUP 17606 . 24133))))) STOP diff --git a/library/MAIKOCOLOR.TEDIT b/library/MAIKOCOLOR.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..56d4e665aa613a4d73ab292f99751259be09be86 GIT binary patch literal 5288 zcmd^B%W~t^5rrf_GeOD~d!H`5Dnq&?c|>V6vNthC1SLcup@87nlid|?IYb!*7(B$H zm;N9BK)xUge@Z^Ui!5^bUVsk`XELM8Vp35_AkgU3efo6YrjAVW%5rU|>kZGnYn%Gk zU}U*;Ku4zsf3^k(XJ6yKD{l{}n~QO29=)Z1-*T?JbI7-?zMO9eFS;`K}bTjnfy( zRb_ABRT{yiFXA6EYUz(UV&6KybOv_t94cgE>dPpRi)ElJRk4OuO7krLp(q8DE82%d z0q9IcIEhoRL-?7*B`s-OrK$pv#N~o{&+_axj$}kP3leEWQ5IHHc)~J|%gIY*b!-&I z#ibc~(`dPj&0>gBA*%v~rBX()WfY1ep(xH}SSE{_r1Ibw#Tq`6MVQAo;1KH)wOkE1 zRpuc##g~7p5RVBL+!QCJEN3y14RVvh?b9Nw6bll>VjaUt-JIwe1%+7xQ-sbXVnMC* z3p#1<(=4e9K=eyFtrAhftCd8OCDxqgF>3lU&B`xTLbOCcmh@l~v`?Ze<#bl6{%3@$ z>#(7iiJKVRh-Cpb2o?%{D^ikqj&x-%W{?2|jeHSDNcQ6PY7>NX|;Ygc9jp10(jie+K+cTNu&;)V860`QBWa7bu^-LRUlP-h_RHk4;^GO^|m_R`+CFB4nC|B(BfHGTFux=~Q zE6yFJKS!GSWa%0X%^*V_RsTK}@pJ~AT0O_LhpuOJ>EUW_L0@N8>T?Q}mk;zxWg5o` z8kEXV7KO+c8wXmId}xxAye@bpI*5p{tW>9#ecxXlk7-quTz|73)Cg%6)o@_Hyfk}U zowL-o*1QR@woaC%my4M+TS~XCGrV@K=k(AUY{+1$#ic};$$TnO94d$g-dQM0h*78c z9A{I?^mB9_`YZo>xcSsgF|90}E?}ICsid1~Jl1DYEe4H0G%el{yn-@}-P%gWnS)uNWbRhrFHdRo0GNKN^`3+!*m;x&Zm_zkN(*Tqz6E)yvVjQny# zE4f~P1I8D-@fOMCtxU2RZxyD62uX|{VFBN8lA0gSH`*3rN`?a^O(Iv`miMQ zoKxP!FY4CL@wJl83)A4Ay_V|?18TLdtqYq5j!U?^w*8^=SDRdk-Ir6(a~;na^gL== zzV*~OZ__Za{JC{Yx(q@ z?Oa?2)VI6NsNV*6zi)x*8hOxrd_thwIXk1{(>Ak&?b5cos7Q0JAJo@(&-1v{XByXe zLXRK65f1!^9tYCEC#Rh|$iV(SQ0bKH;KaX=P9Wo%Ce;S=t@;B0|E)ei$+vEV|F(_r z?epM%jW|2`e`&ZIpVzi?3e8#>dNDst}u(Z~1YFM~l?YCVsgB>bL73f8qz= zIrGl$R{TfJcfdNXzTbpzrQg8)EpRryXY3iD86SApfz!8)-)S!pS=oNS#r7L*tFOB_ z5r(mgDjr<=BiBB>u!G)UXD!CMzoNOPpc;6<_l@DV_l?BBjYvG5dO~r-^!VXkB$@rE z9HSx0hI>Wg0E&}t^)8~kKGI5j3i@5G!|RH9Wu%W0 z`6uSo$ntJ*GXAyBiK|qVHYEAsgS#Hgd|3t-+H1S}N z@^u4~T-J5398B&L4*6eUJK{)<#?1EdUBe&l8fJG5_PXI67$%gl!zyjmMRyHLIBRARY>COLORDEMO.;17 59524 +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 12:28:24" {DSK}local>lde>lispcore>internal>library>COLORDEMO.;2 58060 - changes to: (FNS COLORDEMO CD.RANDCOLORMAP TILEDEMO CD.INIT.COLORMAPS KINETICDEMO CD.QUITP - WELLDEMO TUNNELDEMO CD.KINETIC VINEDEMO RAINING MODARTDEMO STARBURSTDEMO - COLORPEANODEMO BUBBLEDEMO OVERPAINTDEMO CD.INIT CD.INIT.WINDOWS WALKDEMO - CD.WALKBM CD.DEMOKINETIC COLORBACKGROUND COLORMAPOF CD.CIRKIN CD.INRANGE - CD.PUTDROPS CD.DOCOLORDROP CD.RAININGCOLORMAP CD.STARBURST CD.STARSHINE - CD.BUBBLE CD.INIT.MENU CD.NEXTELEMENT CD.RANDELEMENT CD.CHOOSEDEMO - CD.MINESHAFT CD.POINTTEST CD.SQUARETUNNEL CD.CIRCULARTUNNEL CD.ROTATEIT) - (VARS COLORDEMOCOMS) + changes to%: (VARS COLORDEMOCOMS) - previous date: " 3-Sep-86 16:25:44" {ERIS}CML>COLORDEMO.;3) + previous date%: " 3-Sep-86 21:36:32" {DSK}local>lde>lispcore>internal>library>COLORDEMO.;1 +) -(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) +(* ; " +Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") (PRETTYCOMPRINT COLORDEMOCOMS) -(RPAQQ COLORDEMOCOMS - ((* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *) +(RPAQQ COLORDEMOCOMS + [(* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *) (COMS (* Color Demo. Stuff needed to run through different demos, but not the individual demos themselves. *) - (VARS (CD.DEMOS (QUOTE (KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO - COLORPEANODEMO BUBBLEDEMO OVERPAINTDEMO TILEDEMO - TUNNELDEMO POLYGONSDEMO)))) + [VARS (CD.DEMOS '(KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO + BUBBLEDEMO OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO] (INITVARS (CD.NEWDEMO NIL) (CD.STOPDATE 0) (CD.TIMECELL NIL) @@ -43,10 +39,10 @@ (FNS COLORMAPOF COLORMAPCOPY COLORFILL COLORBACKGROUND COLORFILLAREA)) (COMS (* Walk demos) (FNS WALKDEMO CD.WALKBM CD.RANDCOLORMAP) - (INITVARS CD.MAXWALK CD.MINWALK CD.RANDCOLORPROB (CD.RANDOM.COLORMAP NIL) + [INITVARS CD.MAXWALK CD.MINWALK CD.RANDCOLORPROB (CD.RANDOM.COLORMAP NIL) (CD.RAINBOW.COLORMAP NIL) (CD.8BITBMEXP (LIST (HARRAY 60))) - (CD.4BITBMEXP (LIST (HARRAY 60)))) + (CD.4BITBMEXP (LIST (HARRAY 60] (GLOBALVARS CD.8BITBMEXP CD.4BITBMEXP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP)) (COMS (* Kinetic demos *) (FNS KINETICDEMO CD.DEMOKINETIC CD.CIRKIN) @@ -83,20 +79,19 @@ (* Create color fonts now instead of later. COLOR should already be LOADed. *) (for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT) do - (FONTCREATE FONTCLASS NIL NIL NIL (QUOTE 8DISPLAY))) - (FONTCREATE (QUOTE TIMESROMAND) - 36 NIL NIL NIL (QUOTE 8DISPLAY)))))) + (FONTCREATE FONTCLASS NIL NIL NIL '8DISPLAY)) + (FONTCREATE 'TIMESROMAND 36 NIL NIL NIL '8DISPLAY]) (* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *) -(* Color Demo. Stuff needed to run through different demos, but not the individual demos -themselves. *) +(* Color Demo. Stuff needed to run through different demos, but not the individual demos themselves. + *) -(RPAQQ CD.DEMOS (KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO BUBBLEDEMO - OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO)) +(RPAQQ CD.DEMOS (KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO BUBBLEDEMO + OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO)) (RPAQ? CD.NEWDEMO NIL) @@ -115,59 +110,59 @@ themselves. *) (RPAQ? CD.MENU NIL) (RPAQ? CD.COLORMAPS NIL) -(DECLARE: DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE) ) (DEFINEQ (COLORDEMO - (LAMBDA NIL (* kbr: " 3-Sep-86 21:19") + [LAMBDA NIL (* kbr%: " 3-Sep-86 21:19") (DECLARE (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE CD.COLORMAPS)) (PROG (WINDOWS WINDOW DEMO BITSPERPIXEL BITMAP) (COND ((NULL CD.MENU) (CD.INIT))) - (COND - ((NULL (WFROMMENU CD.MENU)) + [COND + [(NULL (WFROMMENU CD.MENU)) (ADDMENU CD.MENU NIL (GETBOXPOSITION (fetch (MENU IMAGEWIDTH) of CD.MENU) - (fetch (MENU IMAGEHEIGHT) of CD.MENU)))) + (fetch (MENU IMAGEHEIGHT) of CD.MENU] ((NOT (OPENWP (WFROMMENU CD.MENU))) - (OPENW (WFROMMENU CD.MENU)))) + (OPENW (WFROMMENU CD.MENU] (SETQ WINDOWS (LIST CD.WINDOW1 CD.WINDOW2 CD.WINDOW3 CD.WINDOW4)) - (do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS)) - (SETQ DEMO (OR CD.NEWDEMO (CD.NEXTELEMENT DEMO CD.DEMOS))) - (SETQ CD.NEWDEMO NIL) - (COND - ((EQ DEMO (QUOTE STOP)) - (RETURN))) - (SETQ CD.STOPDATE (IPLUS (IDATE) - 60)) - - (* Each DEMO takes a WAIT argument telling how long to run and an optional - WINDOW argument telling which window to use. - WAIT can be defaulted to NIL. *) + [do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS)) + (SETQ DEMO (OR CD.NEWDEMO (CD.NEXTELEMENT DEMO CD.DEMOS))) + (SETQ CD.NEWDEMO NIL) + (COND + ((EQ DEMO 'STOP) + (RETURN))) + (SETQ CD.STOPDATE (IPLUS (IDATE) + 60)) - (SCREENCOLORMAP (CD.RANDELEMENT CD.COLORMAPS)) - (APPLY* DEMO NIL WINDOW) - (COND - ((ILESSP (LENGTH CD.TILEBITMAPS) - 10) - (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) - (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL)) - (BITBLT WINDOW NIL NIL BITMAP) - (push CD.TILEBITMAPS BITMAP)))) - (CLOSEW (WFROMMENU CD.MENU))))) + (* Each DEMO takes a WAIT argument telling how long to run and an optional + WINDOW argument telling which window to use. + WAIT can be defaulted to NIL. *) + + (SCREENCOLORMAP (CD.RANDELEMENT CD.COLORMAPS)) + (APPLY* DEMO NIL WINDOW) + (COND + ((ILESSP (LENGTH CD.TILEBITMAPS) + 10) + (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) + (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL)) + (BITBLT WINDOW NIL NIL BITMAP) + (push CD.TILEBITMAPS BITMAP] + (CLOSEW (WFROMMENU CD.MENU]) (CD.INIT - (LAMBDA NIL (* kbr: " 3-Sep-86 19:06") + [LAMBDA NIL (* kbr%: " 3-Sep-86 19:06") (PROG NIL (CD.INIT.COLORMAPS) (CD.INIT.WINDOWS) - (CD.INIT.MENU)))) + (CD.INIT.MENU]) (CD.INIT.COLORMAPS - (LAMBDA NIL (* kbr: " 3-Sep-86 20:39") + [LAMBDA NIL (* kbr%: " 3-Sep-86 20:39") (PROG (BITSPERPIXEL MAXCOLOR) (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) @@ -181,22 +176,22 @@ themselves. *) NIL)) (SETQ CD.RANDOM.COLORMAP (COLORMAPCREATE (for COLOR from 0 to MAXCOLOR collect (create RGB - RED _ (RAND 0 255) - GREEN _ (RAND 0 255) - BLUE _ (RAND 0 255))) + RED _ (RAND 0 255) + GREEN _ (RAND 0 255) + BLUE _ (RAND 0 255))) BITSPERPIXEL)) - (PROGN (SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP BITSPERPIXEL)) + [PROGN (SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP BITSPERPIXEL)) (for COLOR from (RAND 0 15) to MAXCOLOR by 16 do (SETA CD.RAINBOW.COLORMAP COLOR (create RGB - RED _ (RAND 0 255) - GREEN _ (RAND 0 255) - BLUE _ (RAND 0 255))))) + RED _ (RAND 0 255) + GREEN _ (RAND 0 255) + BLUE _ (RAND 0 255] (SETQ CD.COLORMAPS (LIST CD.CMYCOLORMAP CD.RGBCOLORMAP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP)) - (RETURN CD.COLORMAPS)))) + (RETURN CD.COLORMAPS]) (CD.INIT.WINDOWS - (LAMBDA NIL (* kbr: " 3-Sep-86 18:34") + [LAMBDA NIL (* kbr%: " 3-Sep-86 18:34") (PROG (CSWIDTH CSHEIGHT TAB NORTHWEST NORTHEAST SOUTHWEST SOUTHEAST NORTH EAST SOUTH WEST WIDTH HEIGHT) (SETQ CSWIDTH (BITMAPWIDTH (COLORSCREENBITMAP))) @@ -218,10 +213,10 @@ themselves. *) (SETQ SOUTHEAST (create POSITION XCOORD _ (IPLUS TAB WIDTH TAB) YCOORD _ TAB)) - (SETQ NORTH (create POSITION + [SETQ NORTH (create POSITION XCOORD _ (IQUOTIENT (IDIFFERENCE CSWIDTH WIDTH) 2) - YCOORD _ (IDIFFERENCE CSHEIGHT (IPLUS TAB HEIGHT)))) + YCOORD _ (IDIFFERENCE CSHEIGHT (IPLUS TAB HEIGHT] (SETQ EAST (create POSITION XCOORD _ (IDIFFERENCE CSWIDTH (IPLUS WIDTH TAB)) YCOORD _ (IQUOTIENT (IDIFFERENCE CSHEIGHT HEIGHT) @@ -240,59 +235,59 @@ themselves. *) BOTTOM _ (fetch (POSITION YCOORD) of NORTHWEST) WIDTH _ WIDTH HEIGHT _ HEIGHT) - (QUOTE WINDOW1))) + 'WINDOW1)) (SETQ CD.WINDOW2 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of NORTHEAST) BOTTOM _ (fetch (POSITION YCOORD) of NORTHEAST) WIDTH _ WIDTH HEIGHT _ HEIGHT) - (QUOTE WINDOW2))) + 'WINDOW2)) (SETQ CD.WINDOW3 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of SOUTHWEST) BOTTOM _ (fetch (POSITION YCOORD) of SOUTHWEST) WIDTH _ WIDTH HEIGHT _ HEIGHT) - (QUOTE WINDOW3))) + 'WINDOW3)) (SETQ CD.WINDOW4 (CREATEW (create SCREENREGION SCREEN _ (COLORSCREEN) LEFT _ (fetch (POSITION XCOORD) of SOUTHEAST) BOTTOM _ (fetch (POSITION YCOORD) of SOUTHEAST) WIDTH _ WIDTH HEIGHT _ HEIGHT) - (QUOTE WINDOW4)))))) + 'WINDOW4]) (CD.INIT.MENU - (LAMBDA NIL (* kbr: "11-Aug-85 15:05") + [LAMBDA NIL (* kbr%: "11-Aug-85 15:05") (SETQ CD.MENU (create MENU TITLE _ "Color Demos" - ITEMS _ (APPEND CD.DEMOS (QUOTE (STOP))) - WHENSELECTEDFN _ (QUOTE CD.CHOOSEDEMO))))) + ITEMS _ (APPEND CD.DEMOS '(STOP)) + WHENSELECTEDFN _ 'CD.CHOOSEDEMO]) (CD.NEXTELEMENT - (LAMBDA (ELEMENT LIST) (* kbr: "10-Jul-85 18:12") + [LAMBDA (ELEMENT LIST) (* kbr%: "10-Jul-85 18:12") (* Pick element after ELEMENT in - rotating LIST. *) + rotating LIST. *) (PROG (TAIL ANSWER) (SETQ TAIL (FMEMB ELEMENT LIST)) - (SETQ ANSWER (COND + [SETQ ANSWER (COND ((CDR TAIL) (CADR TAIL)) - (T (CAR LIST)))) - (RETURN ANSWER)))) + (T (CAR LIST] + (RETURN ANSWER]) (CD.RANDELEMENT - (LAMBDA (LIST) (* kbr: "31-Jan-86 16:24") - (CAR (NTH LIST (RAND 1 (LENGTH LIST)))))) + [LAMBDA (LIST) (* kbr%: "31-Jan-86 16:24") + (CAR (NTH LIST (RAND 1 (LENGTH LIST]) (CD.CHOOSEDEMO - (LAMBDA (NEW) - (DECLARE (GLOBALVARS CD.NEWDEMO)) (* bas: " 5-JUN-82 13:07") - (SETQ CD.NEWDEMO NEW))) + [LAMBDA (NEW) + (DECLARE (GLOBALVARS CD.NEWDEMO)) (* bas%: " 5-JUN-82 13:07") + (SETQ CD.NEWDEMO NEW]) (CD.QUITP - (LAMBDA (N) (* kbr: " 3-Sep-86 20:05") + [LAMBDA (N) (* kbr%: " 3-Sep-86 20:05") (DECLARE (GLOBALVARS CD.NEWDEMO CD.STOPDATE)) (BLOCK) (OR CD.TIMECELL (SETQ CD.TIMECELL (CREATECELL \FIXP))) @@ -301,7 +296,7 @@ themselves. *) (SETQ CD.STOPDATE (IPLUS (ITIMES N 1000) (CLOCK 0 CD.TIMECELL))) NIL) - (T (AND CD.STOPDATE (ILESSP CD.STOPDATE (CLOCK 0 CD.TIMECELL)))))))) + (T (AND CD.STOPDATE (ILESSP CD.STOPDATE (CLOCK 0 CD.TIMECELL]) ) @@ -311,47 +306,46 @@ themselves. *) (DEFINEQ (CD.MINESHAFT - (LAMBDA (WINDOW N OUTFLG) (* kbr: "20-Jun-91 11:02") + [LAMBDA (WINDOW N OUTFLG) (* kbr%: "20-Jun-91 11:02") (* Draws a mineshaft on WINDOW.) (PROG (COLOR WIDTH HEIGHT MAXCOLOR) - (WINDOWPROP WINDOW (QUOTE TITLE) - (QUOTE CD.MINESHAFT)) + (WINDOWPROP WINDOW 'TITLE 'CD.MINESHAFT) (COND ((NULL N) (SETQ N 1))) (SETQ COLOR 0) - (SETQ WIDTH (WINDOWPROP WINDOW (QUOTE WIDTH))) - (SETQ HEIGHT (WINDOWPROP WINDOW (QUOTE HEIGHT))) + (SETQ WIDTH (WINDOWPROP WINDOW 'WIDTH)) + (SETQ HEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) - (for LEFT from 0 by (ITIMES N 4) as BOTTOM from 0 by (ITIMES N 3) - to (IQUOTIENT HEIGHT 2) do (BLTSHADE COLOR WINDOW LEFT BOTTOM (IDIFFERENCE WIDTH - (ITIMES LEFT 2)) - (IDIFFERENCE HEIGHT (ITIMES BOTTOM 2))) - (COND - (OUTFLG (SETQ COLOR (SUB1 COLOR)) - (COND - ((ILESSP COLOR 0) - (SETQ COLOR MAXCOLOR)))) - (T (SETQ COLOR (ADD1 COLOR)) - (COND - ((IGREATERP COLOR MAXCOLOR) - (SETQ COLOR 0))))))))) + (for LEFT from 0 by (ITIMES N 4) as BOTTOM from 0 + by (ITIMES N 3) to (IQUOTIENT HEIGHT 2) + do (BLTSHADE COLOR WINDOW LEFT BOTTOM (IDIFFERENCE WIDTH (ITIMES LEFT 2)) + (IDIFFERENCE HEIGHT (ITIMES BOTTOM 2))) + (COND + [OUTFLG (SETQ COLOR (SUB1 COLOR)) + (COND + ((ILESSP COLOR 0) + (SETQ COLOR MAXCOLOR] + (T (SETQ COLOR (ADD1 COLOR)) + (COND + ((IGREATERP COLOR MAXCOLOR) + (SETQ COLOR 0]) (CD.POINTTEST - (LAMBDA (WINDOW) (* kbr: " 8-Jul-85 09:44") + [LAMBDA (WINDOW) (* kbr%: " 8-Jul-85 09:44") (* randomly puts points in a region) (PROG (MAXX MAXY MAXCOLOR) - (SETQ MAXX (SUB1 (WINDOWPROP WINDOW (QUOTE WIDTH)))) - (SETQ MAXY (SUB1 (WINDOWPROP WINDOW (QUOTE HEIGHT)))) + [SETQ MAXX (SUB1 (WINDOWPROP WINDOW 'WIDTH] + [SETQ MAXY (SUB1 (WINDOWPROP WINDOW 'HEIGHT] (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (for I from 1 to 100 do (BITMAPBIT WINDOW (RAND 0 MAXX) - (RAND 0 MAXY) - (RAND 0 MAXCOLOR)))))) + (RAND 0 MAXY) + (RAND 0 MAXCOLOR]) ) (DEFINEQ (WELLDEMO - (LAMBDA (WAIT) (* kbr: " 3-Sep-86 20:08") + [LAMBDA (WAIT) (* kbr%: " 3-Sep-86 20:08") (PROG (STARTCOLOR THRUCOLOR) (SETQ STARTCOLOR 1) (SETQ THRUCOLOR 14) @@ -360,10 +354,10 @@ themselves. *) (CD.CIRCULARTUNNEL CD.WINDOW3 4 THRUCOLOR STARTCOLOR) (CD.CIRCULARTUNNEL CD.WINDOW4 4 STARTCOLOR THRUCOLOR) (CD.QUITP (OR WAIT 120)) - (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR))))) + (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR]) (TUNNELDEMO - (LAMBDA (WAIT) (* kbr: " 3-Sep-86 20:08") + [LAMBDA (WAIT) (* kbr%: " 3-Sep-86 20:08") (PROG (STARTCOLOR THRUCOLOR) (SETQ STARTCOLOR 1) (SETQ THRUCOLOR 14) @@ -372,18 +366,18 @@ themselves. *) (CD.CIRCULARTUNNEL CD.WINDOW3 THRUCOLOR STARTCOLOR) (CD.CIRCULARTUNNEL CD.WINDOW4 STARTCOLOR THRUCOLOR) (CD.QUITP (OR WAIT 120)) - (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR))))) + (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR]) (CD.SQUARETUNNEL - (LAMBDA (WINDOW STARTCOLOR THRUCOLOR) (* kbr: "24-Feb-86 12:16") + [LAMBDA (WINDOW STARTCOLOR THRUCOLOR) (* kbr%: "24-Feb-86 12:16") (* Draws a CD.SQUARETUNNEL on the - WINDOW.) + WINDOW.) (PROG (LEFT BOTTOM MAXBOTTOM FACTOR LEFTFACTOR BOTTOMFACTOR INCR DELTA COLOR) (SETQ LEFT 0.0) (SETQ BOTTOM 0.0) (SETQ MAXBOTTOM (FQUOTIENT (BITMAPHEIGHT WINDOW) 2.0)) - (SETQ FACTOR .2) + (SETQ FACTOR 0.2) (SETQ LEFTFACTOR (FTIMES 4.0 FACTOR)) (SETQ BOTTOMFACTOR (FTIMES 3.0 FACTOR)) (COND @@ -392,24 +386,24 @@ themselves. *) (T (SETQ DELTA -1))) (SETQ COLOR STARTCOLOR) (do (BLTSHADE COLOR WINDOW (FIX LEFT) - (FIX BOTTOM) - (IDIFFERENCE (BITMAPWIDTH WINDOW) - (FTIMES LEFT 2)) - (IDIFFERENCE (BITMAPHEIGHT WINDOW) - (FTIMES BOTTOM 2))) - (SETQ INCR (FPLUS 1.0 (FTIMES .1 (FDIFFERENCE MAXBOTTOM BOTTOM)))) - (SETQ LEFT (FPLUS LEFT (FTIMES INCR LEFTFACTOR))) - (SETQ BOTTOM (FPLUS BOTTOM (FTIMES INCR BOTTOMFACTOR))) - (COND - ((FGREATERP BOTTOM MAXBOTTOM) - (RETURN))) - (COND - ((EQ COLOR THRUCOLOR) - (SETQ COLOR STARTCOLOR)) - (T (SETQ COLOR (IPLUS COLOR DELTA)))))))) + (FIX BOTTOM) + (IDIFFERENCE (BITMAPWIDTH WINDOW) + (FTIMES LEFT 2)) + (IDIFFERENCE (BITMAPHEIGHT WINDOW) + (FTIMES BOTTOM 2))) + [SETQ INCR (FPLUS 1.0 (FTIMES 0.1 (FDIFFERENCE MAXBOTTOM BOTTOM] + (SETQ LEFT (FPLUS LEFT (FTIMES INCR LEFTFACTOR))) + (SETQ BOTTOM (FPLUS BOTTOM (FTIMES INCR BOTTOMFACTOR))) + (COND + ((FGREATERP BOTTOM MAXBOTTOM) + (RETURN))) + (COND + ((EQ COLOR THRUCOLOR) + (SETQ COLOR STARTCOLOR)) + (T (SETQ COLOR (IPLUS COLOR DELTA]) (CD.CIRCULARTUNNEL - (LAMBDA (WINDOW STARTCOLOR THRUCOLOR) (* kbr: "24-Feb-86 12:23") + [LAMBDA (WINDOW STARTCOLOR THRUCOLOR) (* kbr%: "24-Feb-86 12:23") (PROG (N WIDTH HEIGHT SIZE DELTA COLOR) (SETQ N 4) (SETQ WIDTH (BITMAPWIDTH WINDOW)) @@ -423,22 +417,21 @@ themselves. *) (T (SETQ DELTA -1))) (SETQ COLOR STARTCOLOR) (for I from 1 to SIZE by N do - - (* Have to make the brush a little bit thicker than the amount by which we are - incrementing the radius to avoid cracks appearing between circles. - *) - (DRAWCIRCLE (IQUOTIENT WIDTH 2) - (IQUOTIENT HEIGHT 2) - I - (LIST (QUOTE ROUND) - (IPLUS N 2) - COLOR) - NIL WINDOW) - (COND - ((EQ COLOR THRUCOLOR) - (SETQ COLOR STARTCOLOR)) - (T (SETQ COLOR (IPLUS COLOR DELTA)))))))) + (* Have to make the brush a little bit thicker than the amount by which we are + incrementing the radius to avoid cracks appearing between circles. + *) + + (DRAWCIRCLE (IQUOTIENT WIDTH 2) + (IQUOTIENT HEIGHT 2) + I + (LIST 'ROUND (IPLUS N 2) + COLOR) + NIL WINDOW) + (COND + ((EQ COLOR THRUCOLOR) + (SETQ COLOR STARTCOLOR)) + (T (SETQ COLOR (IPLUS COLOR DELTA]) ) @@ -448,53 +441,54 @@ themselves. *) (DEFINEQ (CD.ROTATEIT - (LAMBDA (BEGINCOLOR ENDCOLOR WAIT) (* kbr: "23-Feb-86 17:30") + [LAMBDA (BEGINCOLOR ENDCOLOR WAIT) (* kbr%: "23-Feb-86 17:30") (PROG NIL (do (ROTATECOLORMAP BEGINCOLOR ENDCOLOR) - (COND - ((NULL WAIT)) - ((SMALLP WAIT) - (DISMISS WAIT)) - (T (GETMOUSESTATE) - (DISMISS (LRSH LASTMOUSEX 3)))))))) + (COND + ((NULL WAIT)) + ((SMALLP WAIT) + (DISMISS WAIT)) + (T (GETMOUSESTATE) + (DISMISS (LRSH LASTMOUSEX 3]) ) (DEFINEQ (COLORMAPOF - (LAMBDA (NEWCM BITSPERPIXEL) (* kbr: " 3-Sep-86 16:24") + [LAMBDA (NEWCM BITSPERPIXEL) (* kbr%: " 3-Sep-86 16:24") (COND - ((COLORMAPP NEWCM) + [(COLORMAPP NEWCM) (COND ((EQ BITSPERPIXEL (COLORMAPBITS NEWCM)) NEWCM) - (T (COLORMAPCOPY NEWCM BITSPERPIXEL)))) + (T (COLORMAPCOPY NEWCM BITSPERPIXEL] ((EQ NEWCM T) (COLORMAPCREATE NIL BITSPERPIXEL)) - (T (COLORMAPCREATE NEWCM BITSPERPIXEL))))) + (T (COLORMAPCREATE NEWCM BITSPERPIXEL]) (COLORMAPCOPY - (LAMBDA (COLORMAP BITSPERPIXEL) (* rrb "21-OCT-82 18:32") - - (* makes a copy of a color map If COLORMAP is not a color map, it returns a new - color map with default values. If the colormaps are different sizes, the first - 16 entries will be the same and the rest will be black) + [LAMBDA (COLORMAP BITSPERPIXEL) (* rrb "21-OCT-82 18:32") + + (* makes a copy of a color map If COLORMAP is not a color map, it returns a new + color map with default values. If the colormaps are different sizes, the first + 16 entries will be the same and the rest will be black) (COLORMAPCREATE (AND (COLORMAPP COLORMAP BITSPERPIXEL) (INTENSITIESFROMCOLORMAP COLORMAP)) - BITSPERPIXEL))) + BITSPERPIXEL]) (COLORFILL - (LAMBDA (REGION COLOR# COLORBM OPERATION) (* rrb "21-DEC-82 20:54") - (* fills a region in a color bitmap - with a color. Calls the standard - BITBLT with a texture.) + [LAMBDA (REGION COLOR# COLORBM OPERATION) (* rrb "21-DEC-82 20:54") + + (* fills a region in a color bitmap with a color. + Calls the standard BITBLT with a texture.) + (PROG (COLORBM) - (SETQ COLORBM (COND - ((TYPENAMEP COLORBM (QUOTE BITMAP)) + [SETQ COLORBM (COND + ((TYPENAMEP COLORBM 'BITMAP) COLORBM) ((NULL COLORBM) (COLORSCREENBITMAP)) - (T (\ILLEGAL.ARG COLORBM)))) + (T (\ILLEGAL.ARG COLORBM] (COND ((NULL REGION) (COLORFILLAREA 0 0 NIL NIL COLOR# COLORBM OPERATION)) @@ -502,21 +496,21 @@ themselves. *) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) - COLOR# COLORBM OPERATION)))))) + COLOR# COLORBM OPERATION]) (COLORBACKGROUND - (LAMBDA (TEXTURE) (* kbr: " 3-Sep-86 16:30") - (CHANGEBACKGROUND TEXTURE (COLORSCREEN)))) + [LAMBDA (TEXTURE) (* kbr%: " 3-Sep-86 16:30") + (CHANGEBACKGROUND TEXTURE (COLORSCREEN]) (COLORFILLAREA - (LAMBDA (LEFT BOTTOM WIDTH HEIGHT COLOR# COLORBM OPERATION)(* kbr: " 8-Jul-85 08:53") + [LAMBDA (LEFT BOTTOM WIDTH HEIGHT COLOR# COLORBM OPERATION) + (* kbr%: " 8-Jul-85 08:53") (* fills an area of a color bitmap - with color.) - (COND + with color.) + [COND ((NULL COLORBM) - (SETQ COLORBM (COLORSCREENBITMAP)))) - (BITBLT NIL NIL NIL COLORBM LEFT BOTTOM WIDTH HEIGHT (QUOTE TEXTURE) - OPERATION COLOR#))) + (SETQ COLORBM (COLORSCREENBITMAP] + (BITBLT NIL NIL NIL COLORBM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE OPERATION COLOR#]) ) @@ -526,96 +520,102 @@ themselves. *) (DEFINEQ (WALKDEMO - (LAMBDA (WINDOW WAIT SPEED WORD1 WORDS) (* kbr: " 3-Sep-86 18:50") + [LAMBDA (WINDOW WAIT SPEED WORD1 WORDS) (* kbr%: " 3-Sep-86 18:50") (DECLARE (GLOBALVARS CD.STOPDATE)) (PROG NIL (CLEARW WINDOW) - (for I in (COND - (CD.OVERPAINTBITMAPS) - (T (SETQ CD.OVERPAINTBITMAPS (LIST (BITMAPFROMSTRING "Interlisp-D"))))) + (for I in [COND + (CD.OVERPAINTBITMAPS) + (T (SETQ CD.OVERPAINTBITMAPS (LIST (BITMAPFROMSTRING "Interlisp-D"] until (CD.QUITP (OR WAIT 10)) do (CD.WALKBM WINDOW I NIL SPEED) - (OR (CD.QUITP 10) - (CD.WALKBM WINDOW NIL NIL SPEED)))))) + (OR (CD.QUITP 10) + (CD.WALKBM WINDOW NIL NIL SPEED]) (CD.WALKBM - (LAMBDA (WINDOW BM FONT SPEED) (* kbr: " 3-Sep-86 18:52") + [LAMBDA (WINDOW BM FONT SPEED) (* kbr%: " 3-Sep-86 18:52") (PROG (BITSPERPIXEL EBM SCR MAXX MAXY MAXCOLOR) (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (OR SPEED (SETQ SPEED 5)) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ EBM (CACHEBITMAP BM FONT BITSPERPIXEL)) (SETQ SCR (BITMAPCOPY EBM)) - (SETQ MAXX (IDIFFERENCE (WINDOWPROP WINDOW (QUOTE WIDTH)) + (SETQ MAXX (IDIFFERENCE (WINDOWPROP WINDOW 'WIDTH) (BITMAPWIDTH EBM))) - (SETQ MAXY (IDIFFERENCE (WINDOWPROP WINDOW (QUOTE HEIGHT)) + (SETQ MAXY (IDIFFERENCE (WINDOWPROP WINDOW 'HEIGHT) (BITMAPHEIGHT EBM))) (SCREENCOLORMAP (CD.RANDCOLORMAP)) (bind (X _ -1) - (Y _ -1) - (DX _ 0) - (DY _ 0) - (I _ 1) - (J _ 0) - (COLORCOUNTER _ 0) until (CD.QUITP) do (COND - ((EQ I MAXCOLOR) - (SETQ I 1)) - (T (SETQ I (ADD1 I)))) - (add X DX) - (add Y DY) - (COND - ((OR (ILEQ J 0) - (ILESSP X 0) - (IGEQ X MAXX) - (ILESSP Y 0) - (IGEQ Y MAXY)) - (SETQ X (RAND 0 MAXX)) - (SETQ Y (RAND 0 MAXY)) - (SETQ DX (RAND (IMINUS SPEED) - SPEED)) - (SETQ DY (RAND (IMINUS SPEED) - SPEED)) - (SETQ J (RAND CD.MINWALK CD.MAXWALK))) - (T (SETQ J (SUB1 J)))) - (OVERPAINT EBM (COLORSCREENBITMAP) - X Y (COLORTEXTUREFROMCOLOR# I) - SCR) - (COND - ((IGREATERP (SETQ COLORCOUNTER (ADD1 - COLORCOUNTER - )) - 300) - (SETQ COLORCOUNTER 0) - (SCREENCOLORMAP (CD.RANDCOLORMAP))) - (T (ROTATECOLORMAP 1 MAXCOLOR))) - (DISMISS 15))))) + (Y _ -1) + (DX _ 0) + (DY _ 0) + (I _ 1) + (J _ 0) + (COLORCOUNTER _ 0) until (CD.QUITP) do [COND + ((EQ I MAXCOLOR) + (SETQ I 1)) + (T (SETQ I (ADD1 I] + (add X DX) + (add Y DY) + [COND + ((OR (ILEQ J 0) + (ILESSP X 0) + (IGEQ X MAXX) + (ILESSP Y 0) + (IGEQ Y MAXY)) + (SETQ X (RAND 0 MAXX)) + (SETQ Y (RAND 0 MAXY)) + (SETQ DX (RAND (IMINUS SPEED) + SPEED)) + (SETQ DY (RAND (IMINUS SPEED) + SPEED)) + (SETQ J (RAND CD.MINWALK + CD.MAXWALK))) + (T (SETQ J (SUB1 J] + (OVERPAINT EBM (COLORSCREENBITMAP) + X Y (COLORTEXTUREFROMCOLOR# + I) + SCR) + (COND + ((IGREATERP (SETQ COLORCOUNTER + (ADD1 COLORCOUNTER + )) + 300) + (SETQ COLORCOUNTER 0) + (SCREENCOLORMAP ( + CD.RANDCOLORMAP + ))) + (T (ROTATECOLORMAP 1 MAXCOLOR)) + ) + (DISMISS 15]) (CD.RANDCOLORMAP - (LAMBDA NIL (* kbr: " 3-Sep-86 21:16") + [LAMBDA NIL (* kbr%: " 3-Sep-86 21:16") (PROG (MAXCOLOR) (SETQ MAXCOLOR (BITSPERPIXEL (SCREENCOLORMAP))) (SELECTQ (RAND 1 2) - (1 (COND + (1 [COND ((NULL CD.RANDOM.COLORMAP) (SETQ CD.RANDOM.COLORMAP (COLORMAPCREATE)) - (for COLOR from 0 to MAXCOLOR do (SETA (ELT CD.RANDOM.COLORMAP COLOR) - (create RGB - RED _ (RAND 0 255) - GREEN _ (RAND 0 255) - BLUE _ (RAND 0 255)))))) + (for COLOR from 0 to MAXCOLOR + do (SETA (ELT CD.RANDOM.COLORMAP COLOR) + (create RGB + RED _ (RAND 0 255) + GREEN _ (RAND 0 255) + BLUE _ (RAND 0 255] (RETURN CD.RANDOM.COLORMAP)) (2 (COND ((NULL CD.RAINBOW.COLORMAP) - (SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP (COLORMAPBITS (SCREENCOLORMAP)))) + [SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP (COLORMAPBITS (SCREENCOLORMAP] (* make every 16th color random) - (for COLOR from (RAND 0 15) to MAXCOLOR by 16 + [for COLOR from (RAND 0 15) to MAXCOLOR by 16 do (SETA (ELT CD.RAINBOW.COLORMAP COLOR) - (create RGB - RED _ (RAND 0 255) - GREEN _ (RAND 0 255) - BLUE _ (RAND 0 255)))) + (create RGB + RED _ (RAND 0 255) + GREEN _ (RAND 0 255) + BLUE _ (RAND 0 255] (RETURN CD.RAINBOW.COLORMAP))) CD.RAINBOW.COLORMAP) - NIL)))) + NIL]) ) (RPAQ? CD.MAXWALK NIL) @@ -631,7 +631,7 @@ themselves. *) (RPAQ? CD.8BITBMEXP (LIST (HARRAY 60))) (RPAQ? CD.4BITBMEXP (LIST (HARRAY 60))) -(DECLARE: DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.8BITBMEXP CD.4BITBMEXP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP) ) @@ -643,29 +643,28 @@ themselves. *) (DEFINEQ (KINETICDEMO - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:12") (* test example (KINETICDEMO)) (PROG (MAXCOLOR MAXX MAXY X Y) - (WINDOWPROP WINDOW (QUOTE TITLE) - "KINETIC") + (WINDOWPROP WINDOW 'TITLE "KINETIC") (CLEARW WINDOW) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (SETQ X (RAND 0 MAXX)) - (SETQ Y (RAND 0 MAXY)) - (BLTSHADE (RAND 0 MAXCOLOR) - WINDOW X Y (RAND 2 (IDIFFERENCE MAXX X)) - (RAND 2 (IDIFFERENCE MAXY Y)) - (SELECTQ (RAND 0 5) - (0 (QUOTE PAINT)) - (1 (QUOTE ERASE)) - (2 (QUOTE INVERT)) - (QUOTE REPLACE))))))) + (SETQ Y (RAND 0 MAXY)) + (BLTSHADE (RAND 0 MAXCOLOR) + WINDOW X Y (RAND 2 (IDIFFERENCE MAXX X)) + (RAND 2 (IDIFFERENCE MAXY Y)) + (SELECTQ (RAND 0 5) + (0 'PAINT) + (1 'ERASE) + (2 'INVERT) + 'REPLACE]) (CD.DEMOKINETIC - (LAMBDA (WINDOW FIRSTCOLOR LASTCOLOR) (* kbr: " 3-Sep-86 18:40") + [LAMBDA (WINDOW FIRSTCOLOR LASTCOLOR) (* kbr%: " 3-Sep-86 18:40") (* test example (CD.DEMOKINETIC)) (PROG (BITSPERPIXEL LEFT RIGHT BOTTOM TOP X Y COLOR# ROTATETIME KINROTATETIME HALFWIDTH HALFHEIGHT) @@ -678,9 +677,9 @@ themselves. *) ((IGREATERP FIRSTCOLOR LASTCOLOR) (swap FIRSTCOLOR LASTCOLOR))) (SETQ LEFT 0) - (SETQ RIGHT (WINDOWPROP WINDOW (QUOTE WIDTH))) + (SETQ RIGHT (WINDOWPROP WINDOW 'WIDTH)) (SETQ BOTTOM 0) - (SETQ TOP (WINDOWPROP WINDOW (QUOTE HEIGHT))) + (SETQ TOP (WINDOWPROP WINDOW 'HEIGHT)) (SETQ COLOR# FIRSTCOLOR) (SETQ ROTATETIME (CLOCK 0)) (SETQ KINROTATETIME (CLOCK 0)) @@ -688,87 +687,86 @@ themselves. *) (SETQ HALFHEIGHT (IQUOTIENT TOP 2)) (BLTSHADE FIRSTCOLOR WINDOW) BLTLP - (COND + [COND ((IGREATERP (CLOCKDIFFERENCE ROTATETIME) CD.LOGOWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP 1 (MAXIMUMCOLOR BITSPERPIXEL)) - (SETQ ROTATETIME (CLOCK0 ROTATETIME)))) - (COND + (SETQ ROTATETIME (CLOCK0 ROTATETIME] + [COND ((IGREATERP (CLOCKDIFFERENCE KINROTATETIME) CD.KINWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR) - (SETQ KINROTATETIME (CLOCK0 KINROTATETIME)))) + (SETQ KINROTATETIME (CLOCK0 KINROTATETIME] (SETQ X (RAND LEFT RIGHT)) (SETQ Y (RAND BOTTOM TOP)) - (BLTSHADE (COND + (BLTSHADE [COND ((EQ COLOR# LASTCOLOR) (SETQ COLOR# FIRSTCOLOR)) - (T (SETQ COLOR# (ADD1 COLOR#)))) + (T (SETQ COLOR# (ADD1 COLOR#] WINDOW X Y (RAND 2 (IMIN (IDIFFERENCE RIGHT X) HALFWIDTH)) (RAND 2 (IMIN (IDIFFERENCE TOP Y) HALFHEIGHT)) - (QUOTE REPLACE)) + 'REPLACE) MOUSELP (COND ((MOUSESTATE MIDDLE) - (SELECTQ (CAR (ERSETQ (MENU (PROGN (COND - ((NOT (TYPENAMEP CD.KINETICMENU (QUOTE MENU))) + (SELECTQ [CAR (ERSETQ (MENU (PROGN (COND + ((NOT (TYPENAMEP CD.KINETICMENU 'MENU)) (INIT/COLORDEMO/MENUS))) - CD.KINETICMENU)))) + CD.KINETICMENU] (EditColorMap (EDITCOLORMAP)) (IncreaseLogoSpeed - (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME .8)))) + (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME 0.8)))) (DecreaseLogoSpeed (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME 1.3)))) (IncreaseColorFlip - (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME .8)))) + (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME 0.8)))) (DecreaseColorFlip (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME 1.3)))) (STOP (RETURN)) NIL)) ((MOUSESTATE LEFT) (* on left rotate colormap) (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR) - (COND + [COND ((IGREATERP (CLOCKDIFFERENCE ROTATETIME) CD.LOGOWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP 1 (MAXIMUMCOLOR BITSPERPIXEL)) - (SETQ ROTATETIME (CLOCK0 ROTATETIME)))) - (COND + (SETQ ROTATETIME (CLOCK0 ROTATETIME] + [COND ((IGREATERP (CLOCKDIFFERENCE KINROTATETIME) CD.KINWAITTIME) (* cycle the colors in the logo) (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR) - (SETQ KINROTATETIME (CLOCK0 KINROTATETIME)))) + (SETQ KINROTATETIME (CLOCK0 KINROTATETIME] (DISMISS (IMIN CD.KINETICWAITTIME CD.LOGOWAITTIME)) (GO MOUSELP))) - (GO BLTLP)))) + (GO BLTLP]) (CD.CIRKIN - (LAMBDA (WINDOW) (* kbr: " 8-Jul-85 15:18") + [LAMBDA (WINDOW) (* kbr%: " 8-Jul-85 15:18") (PROG (MAXX MAXY MAXRAD MAXCOLOR) - (WINDOWPROP WINDOW (QUOTE TITLE) - (QUOTE CD.CIRKIN)) + (WINDOWPROP WINDOW 'TITLE 'CD.CIRKIN) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) - (SETQ MAXX (SUB1 (WINDOWPROP WINDOW (QUOTE WIDTH)))) - (SETQ MAXY (SUB1 (WINDOWPROP WINDOW (QUOTE HEIGHT)))) + [SETQ MAXX (SUB1 (WINDOWPROP WINDOW 'WIDTH] + [SETQ MAXY (SUB1 (WINDOWPROP WINDOW 'HEIGHT] (SETQ MAXRAD (IQUOTIENT (IMIN MAXX MAXY) 3)) LP (for I from 1 to 4 do (FILLCIRCLE (RAND 0 MAXX) - (RAND 0 MAXY) - (RAND 0 MAXRAD) - (RAND 0 MAXCOLOR) - WINDOW)) + (RAND 0 MAXY) + (RAND 0 MAXRAD) + (RAND 0 MAXCOLOR) + WINDOW)) (DSPOPERATION (SELECTQ (RAND 0 3) - (0 (QUOTE REPLACE)) - (1 (QUOTE PAINT)) - (2 (QUOTE INVERT)) - (QUOTE ERASE)) + (0 'REPLACE) + (1 'PAINT) + (2 'INVERT) + 'ERASE) WINDOW) - (GO LP)))) + (GO LP]) ) (RPAQQ CD.KINETICWAITTIME 150) -(DECLARE: DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CD.KINETICWAITTIME) ) @@ -780,10 +778,9 @@ themselves. *) (DEFINEQ (VINEDEMO - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:12") (PROG (MAXX MAXY X1 Y1 DX DY X2 Y2 COLOR MAXCOLOR WIDTH MAXWIDTH) - (WINDOWPROP WINDOW (QUOTE TITLE) - "VINE") + (WINDOWPROP WINDOW 'TITLE "VINE") (CLEARW WINDOW) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) @@ -798,56 +795,56 @@ themselves. *) (SETQ DY 0) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) - do (* Update velocity. *) - (SETQ DX (CD.INRANGE (IQUOTIENT (IMINUS X1) - 2) - (IQUOTIENT (IDIFFERENCE MAXX X1) - 2) - (IPLUS DX (RAND (IQUOTIENT (IMINUS X1) - 24) - (IQUOTIENT (IDIFFERENCE MAXX X1) - 24))))) - (SETQ DY (CD.INRANGE (IQUOTIENT (IMINUS Y1) - 2) - (IQUOTIENT (IDIFFERENCE MAXY Y1) - 2) - (IPLUS DY (RAND (IQUOTIENT (IMINUS Y1) - 24) - (IQUOTIENT (IDIFFERENCE MAXY Y1) - 24))))) - - (* Knowing current (X1 Y1) and last WIDTH and COLOR, compute the point we draw - to (X2 Y2) and new WIDTH and COLOR. *) + do (* Update velocity. + *) + [SETQ DX (CD.INRANGE (IQUOTIENT (IMINUS X1) + 2) + (IQUOTIENT (IDIFFERENCE MAXX X1) + 2) + (IPLUS DX (RAND (IQUOTIENT (IMINUS X1) + 24) + (IQUOTIENT (IDIFFERENCE MAXX X1) + 24] + [SETQ DY (CD.INRANGE (IQUOTIENT (IMINUS Y1) + 2) + (IQUOTIENT (IDIFFERENCE MAXY Y1) + 2) + (IPLUS DY (RAND (IQUOTIENT (IMINUS Y1) + 24) + (IQUOTIENT (IDIFFERENCE MAXY Y1) + 24] - (SETQ X2 (CD.INRANGE 0 MAXX (IPLUS X1 DX))) - (COND - ((OR (EQ X2 0) - (EQ X2 MAXX)) - (SETQ DX (IMINUS DX)))) - (SETQ Y2 (CD.INRANGE 0 MAXY (IPLUS Y1 DY))) - (COND - ((OR (EQ Y2 0) - (EQ Y2 MAXY)) - (SETQ DY (IMINUS DY)))) - (SETQ WIDTH - (CD.INRANGE 1 MAXWIDTH - (IPLUS WIDTH - (ITIMES (CAR (NTH (QUOTE (-1 0 0 0 0 0 0 1)) - (RAND 1 8))) - (ADD1 (IQUOTIENT WIDTH 3)))))) - (SETQ COLOR - (IMOD (IPLUS COLOR (CAR (NTH (QUOTE (-1 0 0 0 0 0 0 1)) - (RAND 1 8)))) - MAXCOLOR)) (* Drawline and update position - (X1 Y1) *) - (DRAWLINE X1 Y1 X2 Y2 WIDTH (QUOTE REPLACE) - WINDOW COLOR) - (SETQ X1 X2) - (SETQ Y1 Y2))))) + (* Knowing current (X1 Y1) and last WIDTH and COLOR, compute the point we draw + to (X2 Y2) and new WIDTH and COLOR. *) + + (SETQ X2 (CD.INRANGE 0 MAXX (IPLUS X1 DX))) + [COND + ((OR (EQ X2 0) + (EQ X2 MAXX)) + (SETQ DX (IMINUS DX] + (SETQ Y2 (CD.INRANGE 0 MAXY (IPLUS Y1 DY))) + [COND + ((OR (EQ Y2 0) + (EQ Y2 MAXY)) + (SETQ DY (IMINUS DY] + [SETQ WIDTH + (CD.INRANGE 1 MAXWIDTH + (IPLUS WIDTH + (ITIMES (CAR (NTH '(-1 0 0 0 0 0 0 1) + (RAND 1 8))) + (ADD1 (IQUOTIENT WIDTH 3] + (SETQ COLOR + (IMOD [IPLUS COLOR (CAR (NTH '(-1 0 0 0 0 0 0 1) + (RAND 1 8] + MAXCOLOR)) (* Drawline and update position + (X1 Y1) *) + (DRAWLINE X1 Y1 X2 Y2 WIDTH 'REPLACE WINDOW COLOR) + (SETQ X1 X2) + (SETQ Y1 Y2]) (CD.INRANGE - (LAMBDA (MIN MAX VALUE) (* kbr: " 4-Mar-85 14:12") - (IMAX MIN (IMIN MAX VALUE)))) + [LAMBDA (MIN MAX VALUE) (* kbr%: " 4-Mar-85 14:12") + (IMAX MIN (IMIN MAX VALUE]) ) @@ -857,10 +854,9 @@ themselves. *) (DEFINEQ (RAINING - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:12") (PROG (N MAXCOLOR WIDTH HEIGHT COLOR#) - (WINDOWPROP WINDOW (QUOTE TITLE) - "RAINING") + (WINDOWPROP WINDOW 'TITLE "RAINING") (CLEARW WINDOW) (SETQ N 3) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) @@ -868,14 +864,16 @@ themselves. *) (SETQ HEIGHT (BITMAPHEIGHT WINDOW)) (SETQ COLOR# (RAND 0 MAXCOLOR)) (CD.QUITP (OR WAIT 120)) - (until (CD.QUITP NIL) do (SETQ COLOR# (CD.DOCOLORDROP (RAND 10 (IDIFFERENCE WIDTH 10)) - (RAND 10 (IDIFFERENCE HEIGHT 10)) - N - (ITIMES N 3) - 8 COLOR# MAXCOLOR WINDOW)))))) + (until (CD.QUITP NIL) do (SETQ COLOR# (CD.DOCOLORDROP (RAND 10 + (IDIFFERENCE + WIDTH 10)) + (RAND 10 (IDIFFERENCE HEIGHT 10)) + N + (ITIMES N 3) + 8 COLOR# MAXCOLOR WINDOW]) (CD.PUTDROPS - (LAMBDA (WINDOW N) (* kbr: " 8-Jul-85 10:53") + [LAMBDA (WINDOW N) (* kbr%: " 8-Jul-85 10:53") (PROG (POS MAXCOLOR) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) LP (SETQ POS (GETPOSITION WINDOW)) @@ -890,35 +888,39 @@ themselves. *) (RAND 8 15)) (T (RAND 10 20))) 6 0 MAXCOLOR WINDOW) - (GO LP)))) + (GO LP]) (CD.DOCOLORDROP - (LAMBDA (X Y WIDTH RADIUSINCR NCIRCLES COLOR# MAXCOLOR WINDOW) - (* kbr: " 8-Jul-85 10:32") + [LAMBDA (X Y WIDTH RADIUSINCR NCIRCLES COLOR# MAXCOLOR WINDOW) + (* kbr%: " 8-Jul-85 10:32") (* draws a series of concentric - circles.) + circles.) (for I from 1 to NCIRCLES do (DRAWCIRCLE X Y (ITIMES I RADIUSINCR) - (LIST (QUOTE ROUND) - WIDTH - (COND - ((ILESSP (SETQ COLOR# (ADD1 COLOR#)) - MAXCOLOR) - COLOR#) - (T (SETQ COLOR# 0)))) - NIL WINDOW)) - COLOR#)) + [LIST 'ROUND WIDTH (COND + ((ILESSP (SETQ COLOR# + (ADD1 COLOR#) + ) + MAXCOLOR) + COLOR#) + (T (SETQ COLOR# 0] + NIL WINDOW)) + COLOR#]) (CD.RAININGCOLORMAP - (LAMBDA (BITSPERPIXEL) (* kbr: " 8-Jul-85 11:13") + [LAMBDA (BITSPERPIXEL) (* kbr%: " 8-Jul-85 11:13") (COLORMAPCREATE (SELECTQ BITSPERPIXEL - (4 (NCONC (LIST (QUOTE (0 0 0))) - (for I from 100 to 255 by 50 collect (LIST 0 0 I)) - (for I from 0 to 11 collect (QUOTE (0 0 0))))) - (8 (NCONC (LIST (QUOTE (0 0 0))) - (for I from 100 to 255 by 50 collect (LIST 0 0 I)) - (for I from 0 to 11 collect (QUOTE (0 0 0))))) + (4 [NCONC (LIST '(0 0 0)) + (for I from 100 to 255 by 50 + collect (LIST 0 0 I)) + (for I from 0 to 11 + collect '(0 0 0]) + (8 [NCONC (LIST '(0 0 0)) + (for I from 100 to 255 by 50 + collect (LIST 0 0 I)) + (for I from 0 to 11 + collect '(0 0 0]) (\ILLEGAL.ARG BITSPERPIXEL)) - BITSPERPIXEL))) + BITSPERPIXEL]) ) @@ -928,29 +930,29 @@ themselves. *) (DEFINEQ (MODARTDEMO - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:12") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:12") (PROG (WIDTH HEIGHT MAXCOLOR W H L B) - (WINDOWPROP WINDOW (QUOTE TITLE) - "MODART") + (WINDOWPROP WINDOW 'TITLE "MODART") (CLEARW WINDOW) (SETQ WIDTH (BITMAPWIDTH WINDOW)) (SETQ HEIGHT (BITMAPHEIGHT WINDOW)) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (SETQ W (RAND 0 WIDTH)) - (SETQ H (RAND 0 HEIGHT)) - (SETQ L (RAND 0 (IDIFFERENCE WIDTH W))) - (SETQ B (RAND 0 (IDIFFERENCE HEIGHT H))) - (BITBLT WINDOW 0 0 WINDOW L B W H (SELECTQ (RAND 0 2) - (0 (QUOTE INPUT)) - (1 (QUOTE INVERT)) - (QUOTE TEXTURE)) - (SELECTQ (RAND 0 3) - (0 (QUOTE REPLACE)) - (1 (QUOTE PAINT)) - (2 (QUOTE INVERT)) - (QUOTE ERASE)) - (RAND 0 MAXCOLOR)))))) + (SETQ H (RAND 0 HEIGHT)) + (SETQ L (RAND 0 (IDIFFERENCE WIDTH W))) + (SETQ B (RAND 0 (IDIFFERENCE HEIGHT H))) + (BITBLT WINDOW 0 0 WINDOW L B W H + (SELECTQ (RAND 0 2) + (0 'INPUT) + (1 'INVERT) + 'TEXTURE) + (SELECTQ (RAND 0 3) + (0 'REPLACE) + (1 'PAINT) + (2 'INVERT) + 'ERASE) + (RAND 0 MAXCOLOR]) ) @@ -960,10 +962,9 @@ themselves. *) (DEFINEQ (STARBURSTDEMO - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:11") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:11") (PROG (MAXX MAXY MAXCOLOR MAXWIDTH MINWIDTH) - (WINDOWPROP WINDOW (QUOTE TITLE) - "STARBURST") + (WINDOWPROP WINDOW 'TITLE "STARBURST") (CLEARW WINDOW) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) @@ -972,103 +973,102 @@ themselves. *) 2)) (SETQ MINWIDTH (IQUOTIENT MAXWIDTH 6)) (CD.QUITP (OR WAIT 120)) - (until (CD.QUITP) do (CD.STARBURST MAXX MAXY MINWIDTH MAXWIDTH WINDOW))))) + (until (CD.QUITP) do (CD.STARBURST MAXX MAXY MINWIDTH MAXWIDTH WINDOW]) (CD.STARBURST - (LAMBDA (MAXX MAXY MINWIDTH MAXWIDTH WINDOW) (* kbr: "23-Feb-86 17:15") - (PROG (BITSPERPIXEL NCOLORS RADIUS C S CX1 CY1 COLOR1 DELTA1 CX2 CY2 COLOR2 DELTA2 CX3 CY3 COLOR3 - DELTA3) (* Do several starbursts at once to - help minimize calls to COS and SIN - which are slow. *) + [LAMBDA (MAXX MAXY MINWIDTH MAXWIDTH WINDOW) (* kbr%: "23-Feb-86 17:15") + (PROG (BITSPERPIXEL NCOLORS RADIUS C S CX1 CY1 COLOR1 DELTA1 CX2 CY2 COLOR2 DELTA2 CX3 CY3 COLOR3 + DELTA3) + + (* Do several starbursts at once to help minimize calls to COS and SIN which + are slow. *) + (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (SETQ NCOLORS (ADD1 (MAXIMUMCOLOR BITSPERPIXEL))) (SETQ RADIUS (RAND MINWIDTH MAXWIDTH)) - (PROGN (SETQ CX1 (RAND 0 MAXX)) + [PROGN (SETQ CX1 (RAND 0 MAXX)) (SETQ CY1 (RAND 0 MAXY)) (SETQ COLOR1 (RAND 0 (SUB1 NCOLORS))) - (SETQ DELTA1 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL))))) - (PROGN (SETQ CX2 (RAND 0 MAXX)) + (SETQ DELTA1 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL] + [PROGN (SETQ CX2 (RAND 0 MAXX)) (SETQ CY2 (RAND 0 MAXY)) (SETQ COLOR2 (RAND 0 (SUB1 NCOLORS))) - (SETQ DELTA2 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL))))) - (PROGN (SETQ CX3 (RAND 0 MAXX)) + (SETQ DELTA2 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL] + [PROGN (SETQ CX3 (RAND 0 MAXX)) (SETQ CY3 (RAND 0 MAXY)) (SETQ COLOR3 (RAND 0 (SUB1 NCOLORS))) - (SETQ DELTA3 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL))))) - (for THETA from 0 to 44 by 5 do (SETQ C (FTIMES RADIUS (COS THETA))) - (SETQ S (FTIMES RADIUS (SIN THETA))) - (PROGN (CD.STARSHINE CX1 CY1 C S WINDOW COLOR1) - (SETQ COLOR1 (IMOD (IPLUS COLOR1 DELTA1) - NCOLORS))) - (PROGN (CD.STARSHINE CX2 CY2 C S WINDOW COLOR2) - (SETQ COLOR2 (IMOD (IPLUS COLOR2 DELTA2) - NCOLORS))) - (PROGN (CD.STARSHINE CX3 CY3 C S WINDOW COLOR3) - (SETQ COLOR3 (IMOD (IPLUS COLOR3 DELTA3) - NCOLORS))))))) + (SETQ DELTA3 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL] + (for THETA from 0 to 44 by 5 + do (SETQ C (FTIMES RADIUS (COS THETA))) + (SETQ S (FTIMES RADIUS (SIN THETA))) + (PROGN (CD.STARSHINE CX1 CY1 C S WINDOW COLOR1) + (SETQ COLOR1 (IMOD (IPLUS COLOR1 DELTA1) + NCOLORS))) + (PROGN (CD.STARSHINE CX2 CY2 C S WINDOW COLOR2) + (SETQ COLOR2 (IMOD (IPLUS COLOR2 DELTA2) + NCOLORS))) + (PROGN (CD.STARSHINE CX3 CY3 C S WINDOW COLOR3) + (SETQ COLOR3 (IMOD (IPLUS COLOR3 DELTA3) + NCOLORS]) (CD.STARSHINE - (LAMBDA (CX1 CY1 C S WINDOW COLOR) (* kbr: "23-Feb-86 16:57") + [LAMBDA (CX1 CY1 C S WINDOW COLOR) (* kbr%: "23-Feb-86 16:57") (PROG NIL (DRAWLINE (IDIFFERENCE CX1 C) (IDIFFERENCE CY1 S) (IPLUS CX1 C) (IPLUS CY1 S) 1 - (QUOTE REPLACE) - WINDOW COLOR) + 'REPLACE WINDOW COLOR) (DRAWLINE (IDIFFERENCE CX1 C) (IPLUS CY1 S) (IPLUS CX1 C) (IDIFFERENCE CY1 S) 1 - (QUOTE REPLACE) - WINDOW COLOR) + 'REPLACE WINDOW COLOR) (DRAWLINE (IDIFFERENCE CX1 S) (IPLUS CY1 C) (IPLUS CX1 S) (IDIFFERENCE CY1 C) 1 - (QUOTE REPLACE) - WINDOW COLOR) + 'REPLACE WINDOW COLOR) (DRAWLINE (IPLUS CX1 S) (IPLUS CY1 C) (IDIFFERENCE CX1 S) (IDIFFERENCE CY1 C) 1 - (QUOTE REPLACE) - WINDOW COLOR)))) + 'REPLACE WINDOW COLOR]) ) (* Peano demo *) -(FILESLOAD (FROM LISPUSERS) + +(FILESLOAD (FROM LISPUSERS) PEANO) (DEFINEQ (COLORPEANODEMO - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:13") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:13") (PROG (BITSPERPIXEL MAXCOLOR MAXSHADE LEVEL SCALE) - (WINDOWPROP WINDOW (QUOTE TITLE) - "PEANO") + (WINDOWPROP WINDOW 'TITLE "PEANO") (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW)) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ MAXSHADE (MAXIMUMSHADE BITSPERPIXEL)) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (DSPCOLOR (RAND 0 MAXCOLOR) - WINDOW) - (DSPTEXTURE (RAND 0 MAXSHADE) - WINDOW) - (DSPBACKCOLOR (RAND 0 MAXCOLOR) - WINDOW) - (SETQ LEVEL (RAND 4 6)) - (SETQ SCALE (IQUOTIENT (IMAX (BITMAPWIDTH WINDOW) - (BITMAPHEIGHT WINDOW)) - (EXPT 2 LEVEL))) - (SETQ PEANOWINDOW WINDOW) - (PEANODEMO LEVEL SCALE))))) + WINDOW) + (DSPTEXTURE (RAND 0 MAXSHADE) + WINDOW) + (DSPBACKCOLOR (RAND 0 MAXCOLOR) + WINDOW) + (SETQ LEVEL (RAND 4 6)) + (SETQ SCALE (IQUOTIENT (IMAX (BITMAPWIDTH WINDOW) + (BITMAPHEIGHT WINDOW)) + (EXPT 2 LEVEL))) + (SETQ PEANOWINDOW WINDOW) + (PEANODEMO LEVEL SCALE]) ) @@ -1078,10 +1078,9 @@ themselves. *) (DEFINEQ (BUBBLEDEMO - (LAMBDA (WAIT WINDOW) (* kbr: " 3-Sep-86 20:13") + [LAMBDA (WAIT WINDOW) (* kbr%: " 3-Sep-86 20:13") (PROG (MAXX MAXY MAXCOLOR MAXWIDTH MINWIDTH HOLLOW) - (WINDOWPROP WINDOW (QUOTE TITLE) - "BUBBLE") + (WINDOWPROP WINDOW 'TITLE "BUBBLE") (CLEARW WINDOW) (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW))) (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW))) @@ -1095,19 +1094,19 @@ themselves. *) (SETQ HOLLOW T))) (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) do (CD.BUBBLE (RAND 0 MAXX) - (RAND 0 MAXY) - (RAND MINWIDTH MAXWIDTH) - HOLLOW WINDOW))))) + (RAND 0 MAXY) + (RAND MINWIDTH MAXWIDTH) + HOLLOW WINDOW]) (CD.BUBBLE - (LAMBDA (CENTERX CENTERY RADIUS HOLLOW WINDOW) (* kbr: "29-Jul-85 18:09") + [LAMBDA (CENTERX CENTERY RADIUS HOLLOW WINDOW) (* kbr%: "29-Jul-85 18:09") (PROG (MAXCOLOR) (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW))) (FILLCIRCLE CENTERX CENTERY RADIUS (RAND 0 MAXCOLOR) WINDOW) (COND (HOLLOW (FILLCIRCLE CENTERX CENTERY (SUB1 RADIUS) - 0 WINDOW)))))) + 0 WINDOW]) ) @@ -1117,47 +1116,37 @@ themselves. *) (DEFINEQ (OVERPAINTDEMO - (LAMBDA (WAIT) (* kbr: " 3-Sep-86 20:14") + [LAMBDA (WAIT) (* kbr%: " 3-Sep-86 20:14") (PROG (BITMAP BITSPERPIXEL MAXCOLOR WIDTH HEIGHT X Y) - (WINDOWPROP CD.WINDOW1 (QUOTE TITLE) - "MASK") - (WINDOWPROP CD.WINDOW2 (QUOTE TITLE) - "BACKGROUND") - (WINDOWPROP CD.WINDOW3 (QUOTE TITLE) - "INPUT") - (WINDOWPROP CD.WINDOW4 (QUOTE TITLE) - "OUTPUT") + (WINDOWPROP CD.WINDOW1 'TITLE "MASK") + (WINDOWPROP CD.WINDOW2 'TITLE "BACKGROUND") + (WINDOWPROP CD.WINDOW3 'TITLE "INPUT") + (WINDOWPROP CD.WINDOW4 'TITLE "OUTPUT") (SETQ BITSPERPIXEL (BITSPERPIXEL CD.WINDOW1)) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ WIDTH (BITMAPWIDTH CD.WINDOW1)) (SETQ HEIGHT (BITMAPHEIGHT CD.WINDOW1)) - (COND + [COND ((NULL CD.OVERPAINTBITMAPS) - (SETQ CD.OVERPAINTBITMAPS (for STRING in (QUOTE ("Interlisp-D" "Xerox" "Color")) - collect (BITMAPFROMSTRING STRING (FONTCREATE (QUOTE - TIMESROMAND - ) - 36) - BITSPERPIXEL))))) + (SETQ CD.OVERPAINTBITMAPS (for STRING in '("Interlisp-D" "Xerox" "Color") + collect (BITMAPFROMSTRING STRING (FONTCREATE + 'TIMESROMAND 36) + BITSPERPIXEL] (CD.QUITP (OR WAIT 120)) - (until (CD.QUITP) do (BITBLT CD.WINDOW2 NIL NIL CD.WINDOW4) - (for I from 1 to (RAND 6 20) - do (SETQ BITMAP (CD.NEXTELEMENT BITMAP CD.OVERPAINTBITMAPS)) - (SETQ X (RAND 0 (IDIFFERENCE WIDTH (BITMAPWIDTH BITMAP)))) - (SETQ Y (RAND 0 (IDIFFERENCE HEIGHT (BITMAPHEIGHT BITMAP)))) - (CLEARW CD.WINDOW1) - (BITBLT BITMAP NIL NIL CD.WINDOW1 X Y) - (BLTSHADE (RAND 0 MAXCOLOR) - CD.WINDOW3) - (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW3 NIL NIL NIL NIL - (QUOTE INVERT) - (QUOTE ERASE)) - (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW4 NIL NIL NIL NIL - (QUOTE INPUT) - (QUOTE ERASE)) - (BITBLT CD.WINDOW3 NIL NIL CD.WINDOW4 NIL NIL NIL NIL - (QUOTE INPUT) - (QUOTE PAINT))))))) + (until (CD.QUITP) + do (BITBLT CD.WINDOW2 NIL NIL CD.WINDOW4) + (for I from 1 to (RAND 6 20) + do (SETQ BITMAP (CD.NEXTELEMENT BITMAP CD.OVERPAINTBITMAPS)) + [SETQ X (RAND 0 (IDIFFERENCE WIDTH (BITMAPWIDTH BITMAP] + [SETQ Y (RAND 0 (IDIFFERENCE HEIGHT (BITMAPHEIGHT BITMAP] + (CLEARW CD.WINDOW1) + (BITBLT BITMAP NIL NIL CD.WINDOW1 X Y) + (BLTSHADE (RAND 0 MAXCOLOR) + CD.WINDOW3) + (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW3 NIL NIL NIL NIL 'INVERT + 'ERASE) + (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW4 NIL NIL NIL NIL 'INPUT 'ERASE) + (BITBLT CD.WINDOW3 NIL NIL CD.WINDOW4 NIL NIL NIL NIL 'INPUT 'PAINT]) ) (RPAQQ CD.OVERPAINTBITMAPS NIL) @@ -1171,50 +1160,48 @@ themselves. *) (DEFINEQ (TILEDEMO - (LAMBDA (WAIT) (* kbr: " 3-Sep-86 21:19") + [LAMBDA (WAIT) (* kbr%: " 3-Sep-86 21:19") (PROG (WINDOWS WINDOW BITSPERPIXEL BITMAP) (SETQ WINDOWS (LIST CD.WINDOW1 CD.WINDOW2 CD.WINDOW3 CD.WINDOW4)) - (COND + [COND ((ILESSP (LENGTH CD.TILEBITMAPS) 4) (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP))) (for WINDOW in WINDOWS do (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL)) - (BITBLT WINDOW NIL NIL BITMAP) - (push CD.TILEBITMAPS BITMAP)))) + (BITBLT WINDOW NIL NIL BITMAP) + (push CD.TILEBITMAPS BITMAP] (CHANGEBACKGROUND (CD.RANDELEMENT CD.TILEBITMAPS) (COLORSCREEN)) - (WINDOWPROP CD.WINDOW1 (QUOTE TITLE) - "WINDOW1") - (WINDOWPROP CD.WINDOW2 (QUOTE TITLE) - "WINDOW2") - (WINDOWPROP CD.WINDOW3 (QUOTE TITLE) - "WINDOW3") - (WINDOWPROP CD.WINDOW4 (QUOTE TITLE) - "WINDOW4") + (WINDOWPROP CD.WINDOW1 'TITLE "WINDOW1") + (WINDOWPROP CD.WINDOW2 'TITLE "WINDOW2") + (WINDOWPROP CD.WINDOW3 'TITLE "WINDOW3") + (WINDOWPROP CD.WINDOW4 'TITLE "WINDOW4") (CD.QUITP (OR WAIT 120)) (until (CD.QUITP) do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS)) - (SETQ BITMAP (CD.RANDELEMENT CD.TILEBITMAPS)) - (TILE BITMAP WINDOW))))) + (SETQ BITMAP (CD.RANDELEMENT CD.TILEBITMAPS)) + (TILE BITMAP WINDOW]) ) (* Polygons demo *) -(FILESLOAD (FROM LISPUSERS) + +(FILESLOAD (FROM LISPUSERS) COLORPOLYGONS) (DEFINEQ (POLYGONSDEMO - (LAMBDA (WAIT) (* kbr: " 6-Jun-86 00:27") + [LAMBDA (WAIT) (* kbr%: " 6-Jun-86 00:27") (PROG NIL (CD.QUITP (OR WAIT 120)) (until (CD.QUITP NIL) do (COLORPOLYGON CD.WINDOW1) - (COLORPOLYGON CD.WINDOW2) - (COLORPOLYGON CD.WINDOW3) - (COLORPOLYGON CD.WINDOW4) - (COLORPOLYGONS.ROTATECOLORMAP))))) + (COLORPOLYGON CD.WINDOW2) + (COLORPOLYGON CD.WINDOW3) + (COLORPOLYGON CD.WINDOW4) + (COLORPOLYGONS.ROTATECOLORMAP]) ) + (FILESLOAD COLOR) @@ -1222,72 +1209,77 @@ themselves. *) (* Color font profile *) -(RPAQQ COLORFONTPROFILE ((DEFAULTFONT 1 (GACHA 10) - (GACHA 8) - (TERMINAL 8) - (4DISPLAY (GACHA 10 MRR-WHITE-RED)) - (8DISPLAY (GACHA 10 MRR-WHITE-RED)) - (24DISPLAY (GACHA 10 MRR-WHITE-RED))) - (BOLDFONT 2 (HELVETICA 10 BRR) - (HELVETICA 8 BRR) - (MODERN 8 BRR) - (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) - (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) - (24DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) - (LITTLEFONT 3 (HELVETICA 8) - (HELVETICA 6 MIR) - (MODERN 8 MIR) - (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) - (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) - (24DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) - (BIGFONT 4 (HELVETICA 12 BRR) - (HELVETICA 10 BRR) - (MODERN 10 BRR) - (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) - (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) - (24DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) - (USERFONT BOLDFONT) - (COMMENTFONT LITTLEFONT) - (LAMBDAFONT BIGFONT) - (SYSTEMFONT) - (CLISPFONT BOLDFONT) - (CHANGEFONT) - (PRETTYCOMFONT BOLDFONT) - (FONT1 DEFAULTFONT) - (FONT2 BOLDFONT) - (FONT3 LITTLEFONT) - (FONT4 BIGFONT) - (FONT5 5 (HELVETICA 10 BIR) - (HELVETICA 8 BIR) - (MODERN 8 BIR)) - (FONT6 6 (HELVETICA 10 BRR) - (HELVETICA 8 BRR) - (MODERN 8 BRR)) - (FONT7 7 (GACHA 12) - (GACHA 12) - (TERMINAL 12)))) +(RPAQQ COLORFONTPROFILE + ((DEFAULTFONT 1 (GACHA 10) + (GACHA 8) + (TERMINAL 8) + (4DISPLAY (GACHA 10 MRR-WHITE-RED)) + (8DISPLAY (GACHA 10 MRR-WHITE-RED)) + (24DISPLAY (GACHA 10 MRR-WHITE-RED))) + (BOLDFONT 2 (HELVETICA 10 BRR) + (HELVETICA 8 BRR) + (MODERN 8 BRR) + (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) + (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)) + (24DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))) + (LITTLEFONT 3 (HELVETICA 8) + (HELVETICA 6 MIR) + (MODERN 8 MIR) + (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) + (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)) + (24DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))) + (BIGFONT 4 (HELVETICA 12 BRR) + (HELVETICA 10 BRR) + (MODERN 10 BRR) + (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) + (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)) + (24DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))) + (USERFONT BOLDFONT) + (COMMENTFONT LITTLEFONT) + (LAMBDAFONT BIGFONT) + (SYSTEMFONT) + (CLISPFONT BOLDFONT) + (CHANGEFONT) + (PRETTYCOMFONT BOLDFONT) + (FONT1 DEFAULTFONT) + (FONT2 BOLDFONT) + (FONT3 LITTLEFONT) + (FONT4 BIGFONT) + (FONT5 5 (HELVETICA 10 BIR) + (HELVETICA 8 BIR) + (MODERN 8 BIR)) + (FONT6 6 (HELVETICA 10 BRR) + (HELVETICA 8 BRR) + (MODERN 8 BRR)) + (FONT7 7 (GACHA 12) + (GACHA 12) + (TERMINAL 12)))) + (FONTPROFILE COLORFONTPROFILE) -(* Create color fonts now instead of later. COLOR should already be LOADed. *) -(for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT) - do - (FONTCREATE FONTCLASS NIL NIL NIL (QUOTE 8DISPLAY))) -(FONTCREATE (QUOTE TIMESROMAND) - 36 NIL NIL NIL (QUOTE 8DISPLAY)) -(PUTPROPS COLORDEMO COPYRIGHT ("Xerox Corporation" 1985 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (5128 14880 (COLORDEMO 5138 . 6924) (CD.INIT 6926 . 7146) (CD.INIT.COLORMAPS 7148 . 9003 -) (CD.INIT.WINDOWS 9005 . 13127) (CD.INIT.MENU 13129 . 13458) (CD.NEXTELEMENT 13460 . 14003) ( -CD.RANDELEMENT 14005 . 14166) (CD.CHOOSEDEMO 14168 . 14330) (CD.QUITP 14332 . 14878)) (14908 17153 ( -CD.MINESHAFT 14918 . 16512) (CD.POINTTEST 16514 . 17151)) (17154 21488 (WELLDEMO 17164 . 17758) ( -TUNNELDEMO 17760 . 18348) (CD.SQUARETUNNEL 18350 . 19917) (CD.CIRCULARTUNNEL 19919 . 21486)) (21513 -21915 (CD.ROTATEIT 21523 . 21913)) (21916 24640 (COLORMAPOF 21926 . 22326) (COLORMAPCOPY 22328 . 22858 -) (COLORFILL 22860 . 23996) (COLORBACKGROUND 23998 . 24161) (COLORFILLAREA 24163 . 24638)) (24664 -30332 (WALKDEMO 24674 . 25293) (CD.WALKBM 25295 . 28716) (CD.RANDCOLORMAP 28718 . 30330)) (30729 36945 - (KINETICDEMO 30739 . 31911) (CD.DEMOKINETIC 31913 . 35878) (CD.CIRKIN 35880 . 36943)) (37075 40482 ( -VINEDEMO 37085 . 40333) (CD.INRANGE 40335 . 40480)) (40510 43827 (RAINING 40520 . 41436) (CD.PUTDROPS -41438 . 42110) (CD.DOCOLORDROP 42112 . 43064) (CD.RAININGCOLORMAP 43066 . 43825)) (43854 45278 ( -MODARTDEMO 43864 . 45276)) (45308 49308 (STARBURSTDEMO 45318 . 46022) (CD.STARBURST 46024 . 48286) ( -CD.STARSHINE 48288 . 49306)) (49376 50561 (COLORPEANODEMO 49386 . 50559)) (50588 51968 (BUBBLEDEMO -50598 . 51560) (CD.BUBBLE 51562 . 51966)) (51998 54683 (OVERPAINTDEMO 52008 . 54681)) (54777 56090 ( -TILEDEMO 54787 . 56088)) (56169 56673 (POLYGONSDEMO 56179 . 56671))))) + + (* Create color fonts now instead of + later. COLOR should already be + LOADed. *) + +(for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT) + do (FONTCREATE FONTCLASS NIL NIL NIL '8DISPLAY)) + +(FONTCREATE 'TIMESROMAND 36 NIL NIL NIL '8DISPLAY) +(PUTPROPS COLORDEMO COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (4477 14158 (COLORDEMO 4487 . 6282) (CD.INIT 6284 . 6499) (CD.INIT.COLORMAPS 6501 . 8371 +) (CD.INIT.WINDOWS 8373 . 12458) (CD.INIT.MENU 12460 . 12770) (CD.NEXTELEMENT 12772 . 13305) ( +CD.RANDELEMENT 13307 . 13461) (CD.CHOOSEDEMO 13463 . 13617) (CD.QUITP 13619 . 14156)) (14186 16102 ( +CD.MINESHAFT 14196 . 15454) (CD.POINTTEST 15456 . 16100)) (16103 20567 (WELLDEMO 16113 . 16701) ( +TUNNELDEMO 16703 . 17285) (CD.SQUARETUNNEL 17287 . 18892) (CD.CIRCULARTUNNEL 18894 . 20565)) (20592 +21003 (CD.ROTATEIT 20602 . 21001)) (21004 23542 (COLORMAPOF 21014 . 21405) (COLORMAPCOPY 21407 . 21915 +) (COLORFILL 21917 . 22864) (COLORBACKGROUND 22866 . 23024) (COLORFILLAREA 23026 . 23540)) (23566 +29925 (WALKDEMO 23576 . 24222) (CD.WALKBM 24224 . 28377) (CD.RANDCOLORMAP 28379 . 29923)) (30323 36512 + (KINETICDEMO 30333 . 31545) (CD.DEMOKINETIC 31547 . 35463) (CD.CIRKIN 35465 . 36510)) (36643 40114 ( +VINEDEMO 36653 . 39970) (CD.INRANGE 39972 . 40112)) (40142 43978 (RAINING 40152 . 41258) (CD.PUTDROPS +41260 . 41927) (CD.DOCOLORDROP 41929 . 43103) (CD.RAININGCOLORMAP 43105 . 43976)) (44005 45460 ( +MODARTDEMO 44015 . 45458)) (45490 48976 (STARBURSTDEMO 45500 . 46174) (CD.STARBURST 46176 . 48055) ( +CD.STARSHINE 48057 . 48974)) (49049 50326 (COLORPEANODEMO 49059 . 50324)) (50353 51732 (BUBBLEDEMO +50363 . 51331) (CD.BUBBLE 51333 . 51730)) (51762 53772 (OVERPAINTDEMO 51772 . 53770)) (53866 55118 ( +TILEDEMO 53876 . 55116)) (55202 55744 (POLYGONSDEMO 55212 . 55742))))) STOP diff --git a/lispusers/COLORDEMO.TEDIT b/lispusers/COLORDEMO.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..e4b388c0f484320f0271510b12706d7a6b2f9f97 GIT binary patch literal 5671 zcmcgvO>ZN|5gp00lg)++5*SG?P8y2@D+RLP*aosNV8E0#(h{aff~58XK@QECCOOv3 z^tgM56!)Bykz0Pn0{I2G=Hg@S`7c3U)l9cYX{C(}BLpOpHQn{`>ecJ!i*VR~@!+W6 z?GKN`vwrL2R_oJN>kqBgl?h*9I+ICW;!nlmaP^rGCr0KMVl+?YVwe6OsC=RA7cZ32 zmj{u~_FCsw+0Vp3k94Zdz8EN(>wO{k>p-Wgna*u%JWs5MbyQ_4FGVVCDO8-42%>W# zo_yHTiw~bXY4Ij;tTOB=jVu#99T+_`G9w>KOm&*-Ws=Xtw8|rTZiO_8yiAjn-+e&` z-J|~5L2K6=_8$D{q}lc7*2KVz6;&amKvI>^QxQ=KBHjpJG~o|~paks7mMRm`DoT|V z<=p6MHpjaXD9j|VAr<<{K4n$v3}r+zO;`H@|Lf$HjIc=yQz37Jl)`3sxQ`+(fr-p? z1(=XgnPf`rmaC$6AwK;`SQY6!wtGluq*4VCfQHUdJC?8Ik*wtr$qG#pNl8I%DGff% zWht8C97tbwdf~WpB%VvGe4ga7UT$E9bOCn*(?S_b{b|C&YaUAzi!Z?)RLn36BvJcm z;3I6sQkx4aCM$8+9gm*2k3*^eG>dg6N_AOQhM?8WPR6NzXw-~5j*zuiQQ5V<{XsZv zk30RI70aZYBhyJD$fS>Ydl{&*M;y6vM7bw5MNG!VDe92>c$qRVAs8R`Y<* zGM^Ewgme;Ju~HwMfjVn3GPod(;^o zbxBA1&%)sVgM8KU4drC{&7{5HE~sdpCtp{!$`v?>&=KkyWr-64pG-2Fm(7^gn#pR6 zgnAm{+6d5B6=sMw72qd|YGx0*L{Py^l1UP%nWAAt7-}ChDcAKjw7B$}dG>N`=pX_I zD}$pAYsvj}hp2blSwnoI)KXp`Y7d*dMpYVQ0MG=m1XvFia){m;y^df-@YRIKWTFq9^)Qd6Le)Yq^|jkM!=2D(evI zWkMxULp?Yfm^e33AiB^omg)dEIMnfdRQ^2dcD-!$C+ zRO>>R^$5*G)wolj`i9KkalKO|&ZB%in)C zLHjg(8n%ydmku5dp~3h--|N*I|6MJN)LUZG#vS1Me()adz~QhL{J8eD9jw`?()#uD zV5i$Z?FYYdhP72cs%>b>mAA&$tlnnK-lcEU4sIU;1-y#QLA_)f&mKM}9KRNfBh}(ej?i8-TZK`)0-ImKtUO= z2RAIAIE#1liyM}GCY+gDqJ`#bmfx{1-;XZzSmEP~rx$%}8k!W5y^nD`z z)ot>A7tZ34@r}EW-~U|q@>6HHkC#Volgs5h)ks8QV0?|woW=R|+40&pGVfp4_juL0 zbIpu-+`g&xK0=s)-wja4YoB}QRjk9TKa7kJShp#T5? literal 0 HcmV?d00001 diff --git a/lispusers/COLORNNCC.TEDIT b/lispusers/COLORNNCC.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..46174f4cb3935731492a5bbf271da629ca6e5529 GIT binary patch literal 6245 zcmcgwTXP#p6&`!DyII0Ou}~D3qUb8JSX#Uy4(r9FT&a?!iLFJJj3lq)0;*_@TGEiw zw3v$(?K8#0KJ&y2|ASwUf5T4*-`72(o3&0}*h$%*Ieq%{xqjz#o_n44^ABq6X1mjB z)oSiz*ZtIW4_tRi!Usqv^Cv<)eR{34ShVCs9UqHQ{u!xM$iX01NpgH#cAq|Nr(+e1 zsq|mSkxE3Qd@RX$E>bPxEE4HBNQ90c!|m~Pp#5y3qEv)3Nrf5&sTyD%$JMJn4_u8_ zuhXty)_RS0%Wlbq3+%>W;<<|TOVJFHsYvuNoyk~$F6bxVh|dMbmMbvMo8Da^WAKQcw3TVo&4!`*IY2j3nWYZ}s8`yyG zOJox&n_R{&9AzZYdU*b`JZh`Bw*}y=+t;F)AHB_J$o*|D*CJyMOm9kqqcXrVR!9P- zLSiZcIkGQCAV#*>`e8;(Mlh`KjWuZ10#-hKV=P@$q2gAfIU=2>89sG6 zp|I}SCoV6vD6+#MIvgtpf6ahflr&^3P?0}Ja6@DXGI(pakZHvjC%WxtJ=1x65U?Z{ zQ`0ooH-JMsJ54Zua4;IEDLXO7FpNc}15?>znzH4@VNS7ILq#)RZAlw}h%H+bC$TJ{ ze~~%{@QsI;I+?0wm=^Gkva=H;&WuE}U9A@hwA@u#!i@~{*K@#E_I%^ZymqWl>gaLJ z>NOw;{SgyvK&yd3!<v$j$+Z zN@WQukbVVCqr{-h09}H3VC7g2E&x4q-7qz)#E*kMbU^c^9IHX0n;C2?ZW|+q4bm#^ zXy7hEjr9!Ue9mS#+hUxRQ(znEYq$lSuCX--6f=S>PUjt>@BzFUBjx8Nf{;Iq^~6eQ zHcmR653Q9tUd*3a}a2o))E4O5J=h-Lr+AXoy@xH*dLkWG(Ik#C=TpX&g*dk|$SU;RSR2P~Z|ke1_*ty(6yw z*VciK^^G-+^=>BF@>4W^R-3Qk8X^cIPLTJJL* zb5wx%Ge#8pVpPC%5(->dF&>*6Vl*-Ul*aQXF7FzpuGjm6sC9AAvKia0bv&|LETdY)mwwbb$I+ZRqLaQo6p^Kwm^QKsG%rF!=Qdf-0>?7sZ4 zdZ&8TY_vS_2>%Wr*`I?)tSn%B%@f$VckMNs?W@fl5a67Z-jUZmMw>99&>(zpXcivtAtqJEyYm7R$hXU^z zPlE=r9>sD}gjKwL?fmy6N4$1Qjph>zq6=x2Cb5&6A{BF+ERx~e6Wo(>%p;O4HZ3}# z={Ba@p&6OduQj>4ryDTg8Knh--i34 z^ANJ%j=RJY!TmkT-hGE(Tc48imGjlkk@Fr_--eGu?(NdP?N6O#oNJy94?MW2o_c3q zwcco*IuAORtrlMRZMhe}3*C*Scbvry_u%y(I`?~C=e*IXHl1%Rr2N2n@4Q|2I<11X z>o`l=w=LfqjXto?ht9ob`?T%+s35HD{Enrq?Y!gET*9vNKHlEt7k`Y~@lCpa?MAxq zWBeG;(tZ*?StZ=Z$1gVtrdkm_JiAC9XXoF1C94UFO#-vxe4i_;tiLCLtodH2!PkO7 zi$2;U9B&d9$595iTy1jveUtEflW@367_Jhi&%X-7Eu%i;3KM5-g;xHeSjny1{cb^6 zW2N{_&+HnG!V&np^H1(wAvixH!LV7s@BU+zg9{H=IY{{FCgI1Mgj*ax+2r{7CgJfW e;n6CA8owfeFYuBr$~h@Tv0>%I$ob2c|M?#Xd5ro1 literal 0 HcmV?d00001 diff --git a/lispusers/COLOROBJ b/lispusers/COLOROBJ index 956171b3..b4b09e9d 100644 --- a/lispusers/COLOROBJ +++ b/lispusers/COLOROBJ @@ -1,63 +1,67 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 4-Feb-87 23:58:42" {ERIS}LYRIC>COLOROBJ.;2 7868 +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "14-Jun-90 21:02:08" {DSK}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}LYRIC>COLOROBJ.;1) + previous date%: " 4-Feb-87 23:58:42" {DSK}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 diff --git a/lispusers/COLOROBJ.TEDIT b/lispusers/COLOROBJ.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..9be15d91ceb00c1c2d10f67dd6e45d6472021733 GIT binary patch literal 2501 zcmeHI!EW0|5M9Y~3e{zS76sDd04WgiU_w$=Sus$cG`W=6P+XNFT_-^fG_|oAQ=}o% zP2GDg`J{Y7J}a|JQIZWi&8bC!F2LR8%$u1vZu_1Q_=WG?gB(XUERQTmF~Rg|>_ z_h>n~J_Hyo`5Aau*E}mgtycXq`sIW#^FQ@CUueoz!HYwXvFi+Qxy=7a=DdI?11Br_ zGEIuheG8IBbjI`3*E}xa&3O`^LzJfZn*z#n4so95ODJ5fP^I) zk^=He0gh7aXQco4cpZ6kC8T~^fBV&1ev`^9mzOrq12zf>%a(k_w=YYWav zmXrxrST`P3+lq-*%T@qNq$>&#F?LkfnFXM#Q)5KIb6iku<~q#rYzC^~8%K_*!7MQR z!0|=`^a#2ds2%9Qpxc9kCp~cZ!IvxdP+sMFoo>CSD@-6fbvGKWVO0la^=o&u! zPMy&>fC;snaH4_D{E30wx7tC%-Ge^-IDp=8h>IqOqj5|P3!ALkSiJ<#MC#D<&>>6+ z8}{L#--kXvo7jM!1Ts)ch>#}(=>If;L8nut*D!Leu>}2BBt+u9VGsIv*uAZe|5xkI z3-|A+rD^hO-X&iUUF;ek$XB@R?zC{<_|TBvyCzi_YjktxE{L?<#9`KZMveOh{jE>t zdq>_ihUCF#;zYSt^ZvS)0AL?--0FHye0QtsO7^xs<_djdZjoK`khI6tJ*I(U8sy8h z`#bWW`enM)CgjG^BxHjV%~j)D(sJ2|k?(7RT$^}Yct~O|CV5Jt#kR0uCOHd86McJQ zKXj=+qJix-wu)>Bt}@htqWV7@D4LMmt9#UxU44qeMzj_8I`Hqf-y108dyLOoK4FmP zS{6~_?KVO>;L-C*H|2xvz<&BezLIBRARY>DORADOCOLOR.;27 15311 +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "15-Jun-90 13:56:37" {DSK}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}LIBRARY>DORADOCOLOR.;26) + previous date%: "24-Feb-86 12:32:26" +{DSK}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 diff --git a/lispusers/DORADOCOLOR.TEDIT b/lispusers/DORADOCOLOR.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..f7886f34bbd40e3426869ae9ae2b24ece0ab4b30 GIT binary patch literal 7134 zcmcgwOK%&=5gvKHyVy7rAdgJ~1PD3{FGK|8>Tl*EK0wL{9bfLw+%O>)-5 z=}GsDX!@Ar9s=ao1jr%h%@4@W2$Fjao3E;8$RXuNPN5-#?5VD<$5&rf&x?*Xc=1Vl z;5FNW)}S}=+(Xy>(sd79x4MX*SiJC~B*UK!#mVxi5U1KtUW(x?nu!|y-;l|TGQW8t zwR+VE)V%I?`=gH6Z}!|PBh6D`PZ-T2BSIDAbD3l!_Dv>a7-i6^5^=oWS2z2|#|_%+ z4cb?&QFqXHc~9yGFa4<$*q+U#;B!PTGN~|Xk}Z5KMW~}2sl`NT7HKQ(hf36}=)u9m z!@3AmjHe;C#s0G4_B*Z4aM<*&#d*_fKW};+_gdv5k+8=v&Y+EA5oNPtbKvVx2tOf- zY!=~1>g#N|rCNx~So%g{8DR@Du~fM(G-{b@Y2d$~!Cq~1&Blrmga8G2pPDGTkh)SS= z6FHZDV%*w6T_Dt2aCmW$&J%XKNNjg_*>G#f*ji}j8-(3%uzBQEM2X2@gbX47u#n$K zGeIVe^XU|!ir^%?OVvVBag4wbe(-QlOtF~k@rH4nOJSmE;>Q%# zL?WXUQMSHfOs05w!W2sg* zQHW5Gi*rAiq3lH{QvidiHdQ)<7le_ODcKC*q4SV=1Qv1NYP3FWghTjM3=#NpV^MCS z$)&axS43g}Td1yqfZm|lrX6J6o6M&S6ZYOE1M}^%q-2sO0ei$8)du!@&1(b|h31D~ zCpe3|mr{Nlq1*{nHcUw4l0j0^8vJJ`NHuFL1Ir}<;Bm<%YQy+aI|aR{!`#4Q3MkeT z&OHk8(ZbhsFsz;iMM?BuIJrtH2&FO$}s z_}P$`zL>^p4F7L@9Z`jd-&ca(=ygs<7ftW1+b0wU#F9y-6)d8oQ>i0m*(3sTX{iKf zAs54gq8b)H$O1Ki0)%LhKqQKGSqM$@#K85p8L+~8yd=V;s2x4}wTKEXyYZ=t10PWX zJ%%A_(&RC`T$VUtqSf5$>UB>%>a7;E zN?X)2Pq1OT+&=8)P=R8I-OzR5a~!>tqITNtb%s>!)pP4Gtx4=l6{s+jP>Y%SOCnQX z3Vkdhl7d4M6(b*3as&M^S>cdXk#0UD{#^BV)URzSynAt?qK5%Q9F*C~MjpfZ8zMaQHHXmR3+Y9PtbIqpgE|{VcP4Oj#5drGJ^dElY%6OfUzY4WDC3G85G;P9r-jpKn2zL zB#wfYgzLoSbA!hBitr-iz$#2c^=Ig0#8QERAtmbHv5R7x(p*Wh<-}3Z!wGtai|~-P z*%KBx6zNh^KuBuq`HE^6Mdys>DIB9X8qOKjAZA3w*nk(!WXYZy853mysT(yxY`9SR zC9H+|b0TuA_`;yW#(*r6W1UE*%-G*WKDl zZ!|n_wmV|?`FVHLVbP6cuhYK0ct%QYFQ4?TRvP%=_E6N?!%LjmEOkS9+iO1Wb^9Ih z0RN62*uR4ZV%O`S^|d+z+jg%zz24w?RhlHr9oy2a>t?^co)0M^G_Xynt``!&5aV^t zT4E|-N9afKGUiAMMMm2R9q;XG<;b#8!UgPY8FnrPE2`pjO%*zl!R%=Z!WNZQQ|-^o zw2AM&bN=!!>THOJ5~vOizBoQcR|2x_^k7iO8ioE6!ArzA2jW(A zX6qqPA>9bt+MiC#TAVBNKIkKKOQF%WGGqyM$`I7U;9WOpKTV~tIV40)yv5$Bptczs zwO3T$1O!Ak1)>gcjhs_#s8B==ZD)+U5;=3^47mIp@f6>86tL@a3BsO(FP#VKZs*;dWiCGIR0QWF%KO;yL(?6Hc zn#^x08(#NYU!1qS?z7Gtlwd?4x;OAUn1Nao`HK6fHG}O^z{6U9F=IVG5^6R#4fj+d zp{oFqT_;}m?0m$%327T?y6*$BW3=wv%(%Z|vMsKuAZETkMH-_uF31EXzV+gQljdLq zm1mqBKm0m38BM4~rCUx#8D!b!?F#JxBQ6HeJmcySt@CET-{}>i6<;cn4HrEWiW%aYTiLyC_;P9^j(BO5f_5WNj#0f2b(Ps2N*n1%PO_TPA^J zNSbT-Z3H5NoB)2L6dltVSH=e`1{XGdSXe`m!6gih4Rs2h0h$rPQkRxwN4fyFZ)dfxE1@(D8sx4Fr#4Z3c5R2EmM@R5y5rs%n&3k-|A2Z24tLA-) zA2<7aP|Z8!9{~)e@Oy{!aJIkt{p0~(kvNGJXq4@ghk_wWZZm-okMx9kf$>P+QqAY6w&A37g7ht7TH z{?50~J^a4=!ClAM+4**dpT6zCJ$g{?xPu+<_>{6ggv{MLAG|}-arT^VoNsoHVblLE zOA7D4$A)tfg1!9N^6=he^Q?2;X|}ulGv}Un)$ijA{kGD#{=e&d?EJ*}=wi^uTWRNe z_W2#BviAKqtdU3d^CRbOZ*VqneqJtAcK*PwZD=b_z>{0278>qwygsB~lnPEA#hLA} z2V0Rlcy{mHyXtisXPwb$f9EYKSwp#z^!|T0k`rt@;=qT~!n;gZ2fXmU-1t7*-@1{) zcSwhqQJ{rSwih-6OlR&^C1`<*%+}H!xZpU~B=Ir+c#(64b$aq+dQuVH`6VroC^=6O zUHV!skmTpv3lFvzjH;bKW4Un4pik*Z#h?%VUWyh5?fhwL!4X>vJO8XMkgg30 zTKL(v1Rq=V@|MI;x3~Oad!eztuvc9mx0ws*6#UuZc(pCUg-0gR-wFuWyh94A3s$1E znV#M!3Eo%aj^j>X;=R=;