diff --git a/run-medley b/run-medley index 87ae41de..beac3c66 100755 --- a/run-medley +++ b/run-medley @@ -159,6 +159,6 @@ echo "start $LDEINIT" export INMEDLEY=1 -$prog $geometry $screensize -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT" +$prog $geometry $screensize -m 256 -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT" diff --git a/scripts/loadup-lisp-from-mid.sh b/scripts/loadup-lisp-from-mid.sh index 043e244d..1721ea5d 100755 --- a/scripts/loadup-lisp-from-mid.sh +++ b/scripts/loadup-lisp-from-mid.sh @@ -9,19 +9,8 @@ fi scr="-sc 1024x768 -g 1042x790" -echo '"' > ~/rem.cm -echo '(PROGN(LOAD(QUOTE {DSK}'$MEDLEYDIR'/sources/LOADUP.LISP))(HARDRESET))' >> ~/rem.cm -echo 'SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS (QUOTE {DSK}'$MEDLEYDIR'/loadups/lisp.sysout)))' >> ~/rem.cm -echo '(IL:LOGOUT T)' >> ~/rem.cm -echo '"' >> ~/rem.cm -echo -----rem.cm ----- -cat ~/rem.cm -echo ---------------- - -./run-medley $scr -greet $MEDLEYDIR/sources/LOADUP-GREET tmp/init-mid.sysout - -rm ~/rem.cm +./run-medley $scr -greet $MEDLEYDIR/sources/YREM.CM tmp/init-mid.sysout echo ----- created: ------- ls -l loadups/lisp.sysout diff --git a/scripts/loadup-mid-from-init.sh b/scripts/loadup-mid-from-init.sh index 4c045e73..481a7139 100755 --- a/scripts/loadup-mid-from-init.sh +++ b/scripts/loadup-mid-from-init.sh @@ -10,9 +10,7 @@ fi mkdir -p "$MEDLEYDIR/tmp" scr="-sc 1024x768 -g 1042x790" -cp sources/XREM.CM ~/rem.cm - -./run-medley -prog ldeinit $scr -vmem tmp/init-mid.sysout loadups/init.dlinit +./run-medley -prog ldeinit -greet $MEDLEYDIR/sources/XREM.CM $scr -vmem tmp/init-mid.sysout loadups/init.dlinit echo ---- made ---- ls -l tmp/ diff --git a/sources/ADIR b/sources/ADIR index 35819d67..98808193 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "14-Oct-2020 11:14:03" {DSK}kaplan>Local>medley3.5>lispcore>sources>ADIR.;7 48306 changes to%: (FNS SYSOUT) previous date%: "14-Oct-2020 10:54:03" {DSK}kaplan>Local>medley3.5>lispcore>sources>ADIR.;6) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ADIRCOMS) (RPAQQ ADIRCOMS [[COMS (* ; "user-level i/o routines") (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP RENAMEFILE SIMPLE.FINDFILE) (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP] (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING) (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY PACKFILENAME.ASSEMBLE UNPACKFILE1)) (VARS \FILENAME.SYNTAX) (GLOBALVARS \FILENAME.SYNTAX)) (COMS (* ;  "saving and restoring system state") (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT) (ADDVARS (AROUNDEXITFNS)) (INITVARS (HERALDSTRING "") (\USERNAME)) (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS) (FNS USERNAME SETUSERNAME)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) FILEIO)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PACKFILENAME.STRING PACKFILENAME]) (* ; "user-level i/o routines") (DEFINEQ (DELFILE (LAMBDA (FILE) (* bvm%: "23-Oct-85 11:20") (AND FILE (NEQ FILE T) (\DELETEFILE FILE)))) (FULLNAME (LAMBDA (X RECOG) (* rmk%: "22-AUG-83 13:33") (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T (SELECTQ RECOG (NIL (SETQQ RECOG OLD)) ((OLD OLD/NEW NEW OLDEST)) (\ILLEGAL.ARG RECOG)) (\GETFILENAME X RECOG)))) ) (INFILE (LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:23") (INPUT (OPENFILE FILE (QUOTE INPUT) (QUOTE OLD))))) (INFILEP (LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE (QUOTE OLD)))) (IOFILE (LAMBDA (FILE) (* rmk%: " 5-SEP-81 13:54") (OPENFILE FILE (QUOTE BOTH) (QUOTE OLD)))) (OPENFILE [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL) (* ; "Edited 23-May-91 19:12 by jds") (if MULTIPLE.STREAMS.PER.FILE.ALLOWED then (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL) else (fetch (STREAM FULLNAME) of (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL]) (OPENSTREAM (LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE) (* hdj "28-Aug-86 14:50") (PROG (REC OLDSTREAM STREAM) (SELECTQ ACCESS ((INPUT OUTPUT BOTH APPEND)) (\ILLEGAL.ARG ACCESS)) (SETQ REC (SELECTQ RECOG ((EXACT NEW OLD OLD/NEW OLDEST) RECOG) (NIL (SELECTQ ACCESS (INPUT (QUOTE OLD)) (OUTPUT (QUOTE NEW)) (QUOTE OLD/NEW))) (\ILLEGAL.ARG RECOG))) (if (OR (LISTP OBSOLETE) (AND PARAMETERS (NLISTP PARAMETERS))) then (* ;; "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS. Now it will take PARAMETERS, and generally ignore the BYTESIZE") (SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS (7 (QUOTE ((TYPE TEXT)))) (8 (QUOTE ((TYPE BINARY)))) NIL) OBSOLETE))) (COND ((OR (EQ FILE T) (NULL FILE)) (* ;; "Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary and the \ADDOFD shouldn't be done.") (SETQ STREAM (\GETSTREAM FILE ACCESS)) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (RETURN STREAM))) (* ;; "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything") (* ;; "Pavel changed a call to (PATHNAMEP FILE) into (TYPEP FILE `PATHNAME) because PATHNAMEP didn't have a NILL defn early in the loadup and TYPEP has an optimizer on it that compiles away the call to TYPEP which also has no defn early in the loadup.") (* ;; "Pavel also added the call to MKSTRING below as a temporary hack to get around the fact that the Interlisp string functions can't yet handle Common Lisp simple-strings.") (if (TYPEP FILE (QUOTE PATHNAME)) then (SETQ FILE (\CONVERT-PATHNAME FILE))) (* ;; "We open the file before looking to see whether it is already open. This guarantees that we acquire the opening rights at the time we lookup the name. We then check to see if it is currently open in Lisp. If it is, we return the previous stream, which has the file's current state. ") (* ;; "There are still potential problems: First, an interrupt can happen while we are doing the search which causes the file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES. Second, a network device might not allow multiple openings of the file, even by the same guy with the same mode.") (SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS)) (COND ((AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM)))) (* ;; "There is already a stream open on the file. Check that there is no conflict. Eventually all this registration belongs in the device, so that we can have multiple streams open per file") (COND ((AND (EQ ACCESS (QUOTE INPUT)) (EQ (fetch ACCESS of OLDSTREAM) (QUOTE INPUT))) (* ; "Dispose of the newly-obtained stream, This might be a noop, but a network device (LEAF) cares") (OR (EQ STREAM OLDSTREAM) (\CLOSEFILE STREAM)) (\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS) (* ; "Do parameters on the old stream") (RETURN OLDSTREAM)) (T (LISPERROR "FILE WON'T OPEN" FILE)))) (T (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (\ADDOFD STREAM)) (* ; "Parameters done on new stream by \OPENFILE") (RETURN STREAM))))) ) (OUTFILE (LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:24") (OUTPUT (OPENFILE FILE (QUOTE OUTPUT) (QUOTE NEW))))) (OUTFILEP (LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE (QUOTE NEW)))) (RENAMEFILE (LAMBDA (OLDFILE NEWFILE) (* hdj " 4-Sep-86 16:56") (SETQ OLDFILE (\CONVERT-PATHNAME OLDFILE)) (SETQ NEWFILE (\CONVERT-PATHNAME NEWFILE)) (AND OLDFILE NEWFILE (NEQ OLDFILE T) (NEQ NEWFILE T) (\RENAMEFILE OLDFILE NEWFILE))) ) (SIMPLE.FINDFILE (LAMBDA (FILE DUMMY DIRLST) (* bvm%: "23-Oct-85 11:22") (OR (for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME.STRING (QUOTE DIRECTORY) DIR (QUOTE BODY) FILE))) do (RETURN $$VAL)) (AND (NOT (MEMB NIL DIRLST)) (INFILEP FILE)))) ) ) (DECLARE%: EVAL@COMPILE (RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED T) (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) ) (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP) ) (DEFINEQ (UNPACKFILENAME (LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:") (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T)) ) (UNPACKFILENAME.STRING (LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm") (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (PROG ((POS 1) (LEN (NCHARS FILE)) TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) (COND ((NULL FILE) (RETURN NIL)) ((OR (LITATOM FILE) (STRINGP FILE) (NUMBERP FILE))) ((TYPEP FILE (QUOTE PATHNAME)) (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG))) ((STREAMP FILE) (* ; "For streams, use full name. If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (COND (ONEFIELDFLG (AND (EQ ONEFIELDFLG (QUOTE NAME)) FILE)) (T (LIST (QUOTE NAME) FILE))))))) (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ; "some Xerox and Arpanet systems use '[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ; "this is the 'proposed standard' for Xerox servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (UNPACKFILE1 (QUOTE HOST) 2 TEM) (COND ((EQ TEM -1) (* ; "Started with the host field delimiter, but there was no corresponding terminating delimiter .") (* ; "I'm not sure why the name is dealt with the host name.") (RETURN (DREVERSE VAL)))) (SETQ POS (IPLUS TEM 2)) (if (EQ OSTYPE T) then (* ; "Use actual host to determine os type") (SETQ OSTYPE (GETHOSTINFO (CAR VAL) (QUOTE OSTYPE)))) (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (* ; "all device returned have DEVICE.END on it so that NIL: will work") (UNPACKFILE1 (QUOTE DEVICE) POS (if CLFLG then (SUB1 TEM) else TEM)) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (COND ((EQ DIRFLG (QUOTE RETURN)) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.") (LET ((TYPE (QUOTE DIRECTORY)) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (* ; "just host, return") (RETURN (DREVERSE VAL))) ((/ <) (* ; "Started with the initial directory delimiter.") (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) (COND ((EQ START POS) (* ; "Didn't start with a directory delimiter,") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory") (SETQ TYPE (QUOTE SUBDIRECTORY))) (T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE (QUOTE RELATIVEDIRECTORY)))))) (COND ((EQ LEN POS) (* ; "Only the initial directory is specified (i.e. %"{DSK}/%").") (SETQ START POS) -1) (T -2))) (PROGN (COND ((EQ START POS) (* ; "Both of the initial and trail delimiters are omitted.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory") (SETQ TYPE (QUOTE SUBDIRECTORY))) (T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE (QUOTE RELATIVEDIRECTORY))))) (T (COND ((EQ LEN POS) (* ; "Only the initial directory is specified (i.e. %"{DSK}<%").") (SETQ START POS))))) -1))) (UNPACKFILE1.DIRECTORY TYPE START END)) (RETURN (DREVERSE VAL))) ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ; "unix and the 'xerox standard' use / for delimiter") (* ; "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.") (SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE (ADD1 POS))) T) ((< >) (* ; "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") (* ; "In the case of the {DSK} /)) FILE (ADD1 POS))) T) NIL) (* ;; "allow {DSK}/etc to be a directory specification.") (if TEM then (UNPACKFILE1.DIRECTORY (QUOTE DIRECTORY) (ADD1 POS) (SUB1 TEM)) (SETQ POS (ADD1 TEM)) else (* ;; "{DSK}/foo: the directory is /, the name is foo") (UNPACKFILE1.DIRECTORY (QUOTE DIRECTORY) POS POS) (SETQ POS (ADD1 POS))) (SETQ HOSTP T)) ((SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE POS)) (* ; " {eris}abc> relative") (* ;; " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case.") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG (QUOTE FIELD)) then (QUOTE DIRECTORY) else (QUOTE SUBDIRECTORY)) POS (SUB1 TEM))) (T (* ; "True %"relative pathname%".") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG (QUOTE FIELD)) then (QUOTE DIRECTORY) else (QUOTE RELATIVEDIRECTORY)) POS (SUB1 TEM)))) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (DREVERSE VAL))) (if (EQ OSTYPE T) then (* ; "There wasn't a host field in the name, so we have no clue") (SETQ OSTYPE NIL)) NAMELP (* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.") (SELCHARQ CODE (%. (* ; "Note position for later--we only want to deal with the last set of dots") (if BEYONDNAME then (* ; "no longer of interest (probably a bad name, too)") elseif FIRSTDOT then (* ; "We're recording the second dot") (if SECONDDOT then (* ; "Note only the two most recent dots") (SETQ FIRSTDOT SECONDDOT)) (SETQ SECONDDOT TEM) else (SETQ FIRSTDOT TEM))) ((! ; NIL) (* ; "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now") (if (SELCHARQ CODE (! (* ; "! is only a delimiter on IFS, so ignore it if we know the ostype is something else") (AND OSTYPE (NEQ OSTYPE (QUOTE IFS)))) (; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S") (AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM))))) NIL) then (GO NEXTCHAR)) (if FIRSTDOT then (* ; "Have a name and/or extension to parse now") (if (AND SECONDDOT (NOT (if OSTYPE then (* ; "Known OS type must be Tops20 for second dot to mean version") (EQ OSTYPE (QUOTE TOPS20)) else (* ; "Unknown OS type, so check that %"version%" is numeric or wildcard") (AND (for I from (ADD1 SECONDDOT) to (SUB1 TEM) bind CH always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I))) (EQ CH (CHARCODE *)))) (SELCHARQ CODE (NIL (* ; "end of file name, ok") T) (; (* ; "This semi-colon better not be introducing a version") (\UPF.TEMPFILEP FILE (ADD1 TEM))) NIL))))) then (* ; "Second dot is not intoducing a version") (SETQ FIRSTDOT SECONDDOT) (SETQ SECONDDOT NIL)) (UNPACKFILE1 (QUOTE NAME) POS (SUB1 FIRSTDOT)) (SETQ POS (ADD1 (if SECONDDOT then (UNPACKFILE1 (QUOTE EXTENSION) (ADD1 FIRSTDOT) (SUB1 SECONDDOT)) (SETQ BEYONDEXT T) SECONDDOT else FIRSTDOT))) (SETQ BEYONDNAME T) (SETQ FIRSTDOT NIL)) (UNPACKFILE1 (COND ((NOT BEYONDNAME) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) (QUOTE EXTENSION)) ((AND (EQ BEYONDEXT (CHARCODE ";")) (\UPF.TEMPFILEP FILE POS))) (T (* ; "Everything after the semi was version") (QUOTE VERSION))) POS (SUB1 TEM)) (if (NULL CODE) then (* ; "End of string") (RETURN (DREVERSE VAL))) (SETQ BEYONDEXT CODE) (* ; "Note the character that terminated the name/ext") (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP))) ) (LASTCHPOS (LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER") (PROG (RESULT NC) (OR START (SETQ START 1)) (while (SETQ NC (NTHCHARCODE STR START)) do (COND ((EQMEMB NC CH) (SETQ RESULT START)) ((EQ NC (CHARCODE %')) (add START 1))) (add START 1)) (RETURN RESULT))) ) (\UPF.NEXTPOS (LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41") (bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND ((EQMEMB NCH CHAR) (RETURN POS)) ((EQ NCH (CHARCODE %')) (add POS 1))) (add POS 1))) ) (\UPF.TEMPFILEP (LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:") (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.") (SELCHARQ (NTHCHARCODE FILENAME START) ((T S) (* ; "Funny temp stuff") (AND (EQ START (NCHARS FILENAME)) (QUOTE TEMPORARY))) NIL)) ) (FILENAMEFIELD (LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm") (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME ((VERSION GENERATION) (QUOTE VERSION)) ((DEVICE STRUCTURE) (QUOTE DEVICE)) FIELDNAME) (QUOTE FIELD) NIL T)) ) (PACKFILENAME (LAMBDA N (* bvm%: " 5-Jul-85 15:40") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME) (ARG N 1))) (T (PACK (PACKFILENAME.ASSEMBLE))))) ) (PACKFILENAME.STRING (LAMBDA N (* bvm%: " 5-Jul-85 15:41") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME.STRING) (ARG N 1))) (T (CONCATLIST (PACKFILENAME.ASSEMBLE))))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS CANONICAL.DIRECTORY MACRO (OPENLAMBDA (SRCSTRING) (AND SRCSTRING (LET ((LEN (NCHARS SRCSTRING))) (COND ((EQ LEN 1) (if (STREQUAL SRCSTRING "/") then "<" else SRCSTRING)) (T (LET* ((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING)) (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T))) (DSTBASE (ffetch (STRINGP BASE) of DSTSTRING)) (DSTPOS 0) (NEXTPOS -1)) (if (NOT FATP) then [for SRCPOS from 1 to LEN bind CODE first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) (CHARCODE (< / >))) do (add SRCPOS 1)) (if (> SRCPOS LEN) then (RETURN "<")) do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) ((> /) (if (> DSTPOS NEXTPOS) then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >)) (SETQ NEXTPOS (add DSTPOS 1)))) (%' (\PUTBASETHIN DSTBASE DSTPOS CODE) (add DSTPOS 1) (if (NEQ SRCPOS LEN) then (\PUTBASETHIN DSTBASE DSTPOS (NTHCHARCODE SRCSTRING (add SRCPOS 1))) (add DSTPOS 1))) (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE) (add DSTPOS 1))) finally (RETURN (if (EQ DSTPOS LEN) then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 -2) else DSTSTRING) elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) else (SUBSTRING DSTSTRING 1 DSTPOS] else (for SRCPOS from 1 to LEN bind CODE first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) (CHARCODE (< / >))) do (add SRCPOS 1)) do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) ((> /) (if (> DSTPOS NEXTPOS) then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >)) (SETQ NEXTPOS (add DSTPOS 1)))) (%' (\PUTBASEFAT DSTBASE DSTPOS CODE) (add DSTPOS 1) (if (NEQ SRCPOS LEN) then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE SRCSTRING (add SRCPOS 1))) (add DSTPOS 1))) (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE) (add DSTPOS 1))) finally (RETURN (if (EQ DSTPOS LEN) then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 -2) else DSTSTRING) elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) else (SUBSTRING DSTSTRING 1 DSTPOS] [PUTPROPS UNPACKFILE1.DIRECTORY MACRO (OPENLAMBDA (NAM ST END) (LET* ((OLDDIR (SUBSTRING FILE ST END)) (NEWDIR (CANONICAL.DIRECTORY OLDDIR))) (COND [(NOT ONEFIELDFLG) (SETQ VAL (CONS (COND (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) (T (OR NEWDIR ""))) (CONS NAM VAL] ((EQMEMB NAM ONEFIELDFLG) (RETURN (COND (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) (T (OR NEWDIR ""] [PUTPROPS PACKFILENAME.ASSEMBLE MACRO (NIL (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((<= I N) (* ;; "Grab the next field-name / value pair and fold it into the filename:") (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((<= (SETQ I (ADD1 I)) N) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (EQ VAR 'BODY) (\ILLEGAL.ARG VAL)) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (PACKFILENAME.STRING VAL)) (T VAL)) NIL 'OK) [FUNCTION (LAMBDA (X) (SELECTQ (CAR X) (HOST (OR HOST (SETQ HOST (OR (CADR X) BLIP)))) (DEVICE (OR DEVICE (SETQ DEVICE (OR (CADR X) BLIP)))) (DIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR (CADR X) BLIP)))) (RELATIVEDIRECTORY [OR RELATIVEDIRECTORY (COND (DIRECTORY (SETQ RELATIVEDIRECTORY BLIP)) (T (SETQ RELATIVEDIRECTORY (OR (CADR X) BLIP]) (NAME (OR NAME (SETQ NAME (OR (CADR X) BLIP)))) (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR (CADR X) BLIP)))) (VERSION (OR VERSION (SETQ VERSION (OR (CADR X) BLIP)))) (SHOULDNT] (FUNCTION CDDR))) (HOST [OR HOST (SETQ HOST (COND (VAL (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL)) (T BLIP]) ((PATHNAME DIRECTORY) [COND (VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL 'RETURN)) by (CDDR X) do (SELECTQ (CAR X) (HOST [COND ((NOT HOST) (SETQ HOST (OR (CADR X) BLIP]) (DEVICE [COND ((NOT DEVICE) (SETQ DEVICE (OR (CADR X) BLIP]) (SUBDIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (RELATIVEDIRECTORY (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS") (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR (CADR X) BLIP)))) (DIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (ERROR "Illegal field in DIRECTORY slot" VAL))) (for X on VAL by (CDDR X) do (SELECTQ (CAR X) (HOST (OR DEVICE (SETQ DEVICE BLIP)) (OR DIRECTORY (SETQ DIRECTORY BLIP))) (DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP))) NIL))) (T (OR DIRECTORY (SETQ DIRECTORY BLIP]) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP)))) (RELATIVEDIRECTORY (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS") (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP)))) (DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP)))) (NAME (OR NAME (SETQ NAME (OR VAL BLIP)))) (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR VAL BLIP)))) (VERSION (OR VERSION (SETQ VERSION (OR VAL BLIP)))) (TEMPORARY (OR TEMPORARY (SETQ TEMPORARY (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (COND ((EQ HOST BLIP) (SETQ HOST NIL))) (COND ((EQ DEVICE BLIP) (SETQ DEVICE NIL))) (COND ((EQ DIRECTORY BLIP) (SETQ DIRECTORY NIL))) [COND ((EQ SUBDIRECTORY BLIP) (SETQ SUBDIRECTORY NIL)) ((AND NIL SUBDIRECTORY) (COND ((AND (NULL DIRECTORY) (OR HOST DEVICE)) (SETQ DIRECTORY SUBDIRECTORY) (SETQ SUBDIRECTORY NIL] (COND ((EQ RELATIVEDIRECTORY BLIP) (SETQ RELATIVEDIRECTORY NIL))) (RETURN (NCONC (AND HOST (LIST "{" HOST "}")) [AND DEVICE (COND ((AND (SETQ TEMP (LASTCHPOS (CHARCODE %:) DEVICE 1)) (EQ TEMP (NCHARS DEVICE))) (LIST DEVICE)) (T (LIST DEVICE ":"] [COND (DIRECTORY (COND [[OR (STREQUAL DIRECTORY "<") (AND (SETQ TEMP (LASTCHPOS (CHARCODE (> /)) DIRECTORY 1)) (EQ TEMP (NCHARS DIRECTORY] (COND ((EQMEMB (NTHCHARCODE DIRECTORY 1) (CHARCODE (< /))) (LIST DIRECTORY)) (T (LIST (CL:FIRST \FILENAME.SYNTAX) DIRECTORY] (T (LIST (CL:FIRST \FILENAME.SYNTAX) DIRECTORY (CL:SECOND \FILENAME.SYNTAX] [COND (RELATIVEDIRECTORY (COND ((AND (SETQ TEMP (LASTCHPOS (CHARCODE (> /)) RELATIVEDIRECTORY 1)) (EQ TEMP (NCHARS RELATIVEDIRECTORY))) (LIST RELATIVEDIRECTORY)) (T (LIST RELATIVEDIRECTORY (CL:SECOND \FILENAME.SYNTAX ] [COND (SUBDIRECTORY (LIST SUBDIRECTORY (CL:SECOND \FILENAME.SYNTAX] (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) BLIP) (T '%.)) (OR EXTENSION BLIP))) (AND VERSION (NEQ VERSION BLIP) (LIST (CL:THIRD \FILENAME.SYNTAX) (COND ((FIXP VERSION) VERSION) (T (SELCHARQ (CHCON1 VERSION) ((%. ! ;) (SUBSTRING VERSION 2 -1)) VERSION] [PUTPROPS UNPACKFILE1 MACRO (OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21") (COND [(NOT ONEFIELDFLG) (SETQ VAL (CONS (COND (PACKFLG (SUBATOM FILE ST END)) (T (OR (SUBSTRING FILE ST END) ""))) (CONS NAM VAL] ((EQMEMB NAM ONEFIELDFLG) (RETURN (COND (PACKFLG (SUBATOM FILE ST END)) (T (OR (SUBSTRING FILE ST END) ""] ) ) (RPAQQ \FILENAME.SYNTAX ("<" ">" ";")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FILENAME.SYNTAX) ) (* ; "saving and restoring system state") (DEFINEQ (LOGOUT (LAMBDA (FAST) (* hdj "23-May-86 16:20") (\USEREVENT (QUOTE BEFORELOGOUT)) (COND ((OR (EQ FAST T) (\FLUSHVMOK? (QUOTE LOGOUT))) (* ; "Check that we have a vmem file before allowing LOGOUT") (\PROCESS.BEFORE.LOGOUT) (\DEVICEEVENT (QUOTE BEFORELOGOUT)) (\SETTOTALTIME) (* ; "update the total time that this sysout has been running.") (\LOGOUT0 FAST) (* ;; "Must re-establish the state of devices and of previously open files that might have been modified at the EXEC.") (\RESETKEYBOARD) (\DEVICEEVENT (QUOTE AFTERLOGOUT)) (\OPENLINEBUF) (\PROCESS.AFTER.EXIT (QUOTE AFTERLOGOUT)) (\USEREVENT (QUOTE AFTERLOGOUT)) (INTERPRET.REM.CM) NIL))) ) (MAKESYS [LAMBDA (FILE NAME) (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE NAME)) (* ; "Edited 13-Oct-2020 22:51 by rmk:") (* ; "Edited 28-Jul-88 18:16 by drc:") (\FLUSHVMOK? 'MAKESYS) (\USEREVENT 'BEFOREMAKESYS) (HERALD (CONCAT (OR NAME (CL:STRING-CAPITALIZE MAKESYSNAME)) " " (SUBSTRING (SETQ MAKESYSDATE (DATE)) 1 11) " ...")) (\DEVICEEVENT 'BEFOREMAKESYS) (* ;; "RMK: make sysout on a temp file, then rename it in order to get version numbers") (LET [(NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE)) "-TEMP"] (COND ((NLISTP NEWFILE) (* ;  "Coming back from doing the MAKESYS, so just set up to keep going.,") (\DEVICEEVENT 'AFTERDOMAKESYS) (\USEREVENT 'AFTERDOMAKESYS) (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE))) FILE) (T (* ;  "Coming back in the MAKESYS'd sysout, so restart the world.") (\DEVICEEVENT 'AFTERMAKESYS) (\PROCESS.AFTER.EXIT 'AFTERMAKESYS) (PRIN1 HERALDSTRING T) (\USEREVENT 'AFTERMAKESYS) (INTERPRET.REM.CM) (* ;  "Run the commands in the file REM.CM") (RESET]) (SYSOUT [LAMBDA (FILE) (* ; "Edited 14-Oct-2020 11:13 by rmk:") (* hdj "29-Sep-86 12:14") (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE)) (* ;  "FILE is special so that BEFORESYSOUTFORMS can alter it") (\FLUSHVMOK? 'SYSOUT) (\USEREVENT 'BEFORESYSOUT) (\DEVICEEVENT 'BEFORESYSOUT) (* ;;  "RMK: Fix it so that sysouts are versioned. Temp file goes to same place as eventual sysout.") (LET ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS)) NEWFILE) (* ;  "update the total time field so that the run time in the sysout will be right.") (\SETTOTALTIME) (SETQ NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE)) "-TEMP"))) (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE))) [COND ((NLISTP NEWFILE) (* ;; "Continuing in same sysout; reset TOTALTIME in misc stats page to not include the time before the sysout.") (replace TOTALTIME of \MISCSTATS with TOTALTIMESAVE) (\DEVICEEVENT 'AFTERDOSYSOUT) (\USEREVENT 'AFTERDOSYSOUT)) (T (* ; "restarting") (\DEVICEEVENT 'AFTERSYSOUT) (\PROCESS.AFTER.EXIT 'AFTERSYSOUT) (INTERPRET.REM.CM) (\USEREVENT 'AFTERSYSOUT] FILE]) (SAVEVM (LAMBDA (RELEASEFLG) (* hdj "23-May-86 16:20") (* ;; "Save the virtual memory. This is similar to logging out, then back in, but is much faster, since it doesn't lose any pages. Conceptually, this is like doing a sysout to Lisp.virtualmem") (\FLUSHVMOK? (QUOTE SAVEVM)) (\USEREVENT (QUOTE BEFORESAVEVM)) (\DEVICEEVENT (QUOTE BEFORESAVEVM)) (COND ((\FLUSHVM) (\RESETKEYBOARD) (* ; "Returns T when starting up fresh") (\DEVICEEVENT (QUOTE AFTERSAVEVM)) (\PROCESS.AFTER.EXIT (QUOTE AFTERSAVEVM)) (\USEREVENT (QUOTE AFTERSAVEVM)) T) (T (\DEVICEEVENT (QUOTE AFTERDOSAVEVM)) (\USEREVENT (QUOTE AFTERDOSAVEVM))))) ) (HERALD (LAMBDA (STR) (* wt%: " 2-MAY-79 15:38") (AND STR (SETQ HERALDSTRING STR)) HERALDSTRING)) (INTERPRET.REM.CM [LAMBDA (RETFLG) (* ; "Edited 29-Jun-2017 15:36 by rmk:") (DECLARE (GLOBALVARS STARTUPFORM)) (* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote. If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP, among others. If RETFLG is true, the expression read is simply returned") (PROG ([FILE (CAR (NLSETQ (OPENSTREAM '{DSK}REM.CM;1 'BOTH 'OLD] COM AUXFILE) (OR FILE (RETURN)) [COND ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH) 0) (SELECTQ (SKIPSEPRS FILE T) ((%( %") T) NIL) (SETQ COM (PROGN (SETFILEINFO FILE 'ENDOFSTREAMOP (FUNCTION ERROR!)) (CAR (NLSETQ (READ FILE T] (COND (RETFLG (* ; "Save it to return")) ((LISTP COM) (* ; "make it happen at next prompt") (SETQ STARTUPFORM (LIST 'PROGN '(SETQ PROMPTCHARFORMS (DREMOVE STARTUPFORM PROMPTCHARFORMS)) (LIST 'PRINT (LIST 'LISPXEVAL (KWOTE COM)) T T))) (SETQ PROMPTCHARFORMS (CONS STARTUPFORM PROMPTCHARFORMS))) (T (* ; "Unread a string") (* ;  "RMK: Replace CR and LF by space to avoid EOL convention issues") (FOR I FROM 1 TO (NCHARS COM) WHEN (FMEMB (NTHCHARCODE COM I) (CHARCODE (CR LF EOL))) DO (RPLCHARCODE COM I (CHARCODE SPACE))) (BKSYSBUF COM))) (* ;; "Eat up the command terminator") (WHILE (FMEMB (\PEEKBIN FILE T) (CHARCODE (CR LF EOL ;))) DO (\BIN FILE)) (COND ((\EOFP FILE) (* ;  "Nothing left, get rid of the file") (CLOSEF FILE) (DELFILE FILE) (\SETEOFPTR FILE 0)) (T (* ;; "Need to rewrite REM.CM with remainder of text") (SETQ AUXFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) (COPYBYTES FILE AUXFILE) (SETFILEPTR FILE 0) (COPYBYTES AUXFILE FILE 0 (GETFILEPTR AUXFILE)) (CLOSEF AUXFILE) (\SETEOFPTR FILE (GETFILEPTR FILE)) (CLOSEF FILE] (RETURN (COND (RETFLG COM) (COM T]) (\USEREVENT (LAMBDA (EVENT) (DECLARE (GLOBALVARS AROUNDEXITFNS)) (* bvm%: "16-Dec-83 15:27") (for FN in (SELECTQ EVENT ((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS) AROUNDEXITFNS) (REVERSE AROUNDEXITFNS)) do (APPLY* FN EVENT))) ) ) (ADDTOVAR AROUNDEXITFNS ) (RPAQ? HERALDSTRING "") (RPAQ? \USERNAME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS) ) (DEFINEQ (USERNAME (LAMBDA (FLG STRPTR PRESERVECASE) (* lmm "28-MAR-82 14:10") (* ; "On 10, USERNAME can take a user number as arg") (PROG (ADDR NAME) (SETQ NAME (COND (FLG NIL) ((NEQ 0 (SETQ ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (GetBcplString (\ADDBASE (EMADDRESS 0) ADDR) (EQ STRPTR T))) (T \USERNAME))) (OR PRESERVECASE (NULL NAME) (SETQ NAME (U-CASE NAME))) (RETURN (COND ((NULL NAME) NIL) ((STRINGP STRPTR) (SUBSTRING NAME 1 -1 STRPTR)) (T NAME))))) ) (SETUSERNAME (LAMBDA (NAME) (* lmm "28-MAR-82 14:11") (* ; "Changed interpretation of UserName0") (COND (NAME (PROG ((ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (RETURN (COND ((NEQ ADDR 0) (SetBcplString (\ADDBASE (EMADDRESS 0) ADDR) NAME) (SETQ USERNAME (USERNAME NIL T))) (T (SETQ \USERNAME (CONCAT NAME))))))))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) FILEIO) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME) ) (PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1920 2017 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2794 7673 (DELFILE 2804 . 2904) (FULLNAME 2906 . 3140) (INFILE 3142 . 3248) (INFILEP 3250 . 3339) (IOFILE 3341 . 3438) (OPENFILE 3440 . 3840) (OPENSTREAM 3842 . 6967) (OUTFILE 6969 . 7078 ) (OUTFILEP 7080 . 7170) (RENAMEFILE 7172 . 7412) (SIMPLE.FINDFILE 7414 . 7671)) (8045 17409 ( UNPACKFILENAME 8055 . 8204) (UNPACKFILENAME.STRING 8206 . 15792) (LASTCHPOS 15794 . 16079) ( \UPF.NEXTPOS 16081 . 16298) (\UPF.TEMPFILEP 16300 . 16732) (FILENAMEFIELD 16734 . 16971) (PACKFILENAME 16973 . 17179) (PACKFILENAME.STRING 17181 . 17407)) (38426 46850 (LOGOUT 38436 . 39085) (MAKESYS 39087 . 40854) (SYSOUT 40856 . 42599) (SAVEVM 42601 . 43223) (HERALD 43225 . 43326) (INTERPRET.REM.CM 43328 . 46603) (\USEREVENT 46605 . 46848)) (47032 47847 (USERNAME 47042 . 47511) (SETUSERNAME 47513 . 47845))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Feb-2021 15:32:34" {DSK}larry>medley>sources>ADIR.;11 61717 changes to%: (FNS INTERPRET.REM.CM) previous date%: "21-Feb-2021 21:49:20" {DSK}larry>medley>sources>ADIR.;10) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017, 2020, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT ADIRCOMS) (RPAQQ ADIRCOMS [[COMS (* ; "user-level i/o routines") (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP RENAMEFILE SIMPLE.FINDFILE) (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP] (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING) (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY PACKFILENAME.ASSEMBLE UNPACKFILE1)) (VARS \FILENAME.SYNTAX) (GLOBALVARS \FILENAME.SYNTAX)) (COMS (* ;  "saving and restoring system state") (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT) (ADDVARS (AROUNDEXITFNS)) (INITVARS (HERALDSTRING "") (\USERNAME)) (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS) (FNS USERNAME SETUSERNAME)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) FILEIO)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PACKFILENAME.STRING PACKFILENAME]) (* ; "user-level i/o routines") (DEFINEQ (DELFILE [LAMBDA (FILE) (* bvm%: "23-Oct-85 11:20") (AND FILE (NEQ FILE T) (\DELETEFILE FILE]) (FULLNAME [LAMBDA (X RECOG) (* rmk%: "22-AUG-83 13:33") (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T (SELECTQ RECOG (NIL (SETQQ RECOG OLD)) ((OLD OLD/NEW NEW OLDEST)) (\ILLEGAL.ARG RECOG)) (\GETFILENAME X RECOG]) (INFILE [LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:23") (INPUT (OPENFILE FILE 'INPUT 'OLD]) (INFILEP [LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE 'OLD]) (IOFILE [LAMBDA (FILE) (* rmk%: " 5-SEP-81 13:54") (OPENFILE FILE 'BOTH 'OLD]) (OPENFILE [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL) (* ; "Edited 23-May-91 19:12 by jds") (if MULTIPLE.STREAMS.PER.FILE.ALLOWED then (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL) else (fetch (STREAM FULLNAME) of (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL]) (OPENSTREAM [LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE) (* hdj "28-Aug-86 14:50") (PROG (REC OLDSTREAM STREAM) (SELECTQ ACCESS ((INPUT OUTPUT BOTH APPEND)) (\ILLEGAL.ARG ACCESS)) (SETQ REC (SELECTQ RECOG ((EXACT NEW OLD OLD/NEW OLDEST) RECOG) (NIL (SELECTQ ACCESS (INPUT 'OLD) (OUTPUT 'NEW) 'OLD/NEW)) (\ILLEGAL.ARG RECOG))) (if (OR (LISTP OBSOLETE) (AND PARAMETERS (NLISTP PARAMETERS))) then (* ;; "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS. Now it will take PARAMETERS, and generally ignore the BYTESIZE") (SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS (7 '((TYPE TEXT))) (8 '((TYPE BINARY))) NIL) OBSOLETE))) (COND ((OR (EQ FILE T) (NULL FILE)) (* ;; "Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary and the \ADDOFD shouldn't be done.") (SETQ STREAM (\GETSTREAM FILE ACCESS)) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (RETURN STREAM))) (* ;; "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything") (* ;; "Pavel changed a call to (PATHNAMEP FILE) into (TYPEP FILE `PATHNAME) because PATHNAMEP didn't have a NILL defn early in the loadup and TYPEP has an optimizer on it that compiles away the call to TYPEP which also has no defn early in the loadup.") (* ;; "Pavel also added the call to MKSTRING below as a temporary hack to get around the fact that the Interlisp string functions can't yet handle Common Lisp simple-strings.") (if (TYPEP FILE 'PATHNAME) then (SETQ FILE (\CONVERT-PATHNAME FILE))) (* ;; "We open the file before looking to see whether it is already open. This guarantees that we acquire the opening rights at the time we lookup the name. We then check to see if it is currently open in Lisp. If it is, we return the previous stream, which has the file's current state. ") (* ;; "There are still potential problems: First, an interrupt can happen while we are doing the search which causes the file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES. Second, a network device might not allow multiple openings of the file, even by the same guy with the same mode.") (SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS)) (COND [[AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM] (* ;; "There is already a stream open on the file. Check that there is no conflict. Eventually all this registration belongs in the device, so that we can have multiple streams open per file") (COND ((AND (EQ ACCESS 'INPUT) (EQ (fetch ACCESS of OLDSTREAM) 'INPUT)) (* ;  "Dispose of the newly-obtained stream, This might be a noop, but a network device (LEAF) cares") (OR (EQ STREAM OLDSTREAM) (\CLOSEFILE STREAM)) (\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS) (* ; "Do parameters on the old stream") (RETURN OLDSTREAM)) (T (LISPERROR "FILE WON'T OPEN" FILE] (T (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (\ADDOFD STREAM)) (* ;  "Parameters done on new stream by \OPENFILE") (RETURN STREAM]) (OUTFILE [LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:24") (OUTPUT (OPENFILE FILE 'OUTPUT 'NEW]) (OUTFILEP [LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE 'NEW]) (RENAMEFILE [LAMBDA (OLDFILE NEWFILE) (* hdj " 4-Sep-86 16:56") (SETQ OLDFILE (\CONVERT-PATHNAME OLDFILE)) (SETQ NEWFILE (\CONVERT-PATHNAME NEWFILE)) (AND OLDFILE NEWFILE (NEQ OLDFILE T) (NEQ NEWFILE T) (\RENAMEFILE OLDFILE NEWFILE]) (SIMPLE.FINDFILE [LAMBDA (FILE DUMMY DIRLST) (* bvm%: "23-Oct-85 11:22") (OR (for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME.STRING 'DIRECTORY DIR 'BODY FILE))) do (RETURN $$VAL)) (AND (NOT (MEMB NIL DIRLST)) (INFILEP FILE]) ) (DECLARE%: EVAL@COMPILE (RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED T) (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) ) (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP) ) (DEFINEQ (UNPACKFILENAME [LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:") (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T]) (UNPACKFILENAME.STRING [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm") (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (PROG ((POS 1) (LEN (NCHARS FILE)) TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) (COND ((NULL FILE) (RETURN NIL)) ((OR (LITATOM FILE) (STRINGP FILE) (NUMBERP FILE))) ((TYPEP FILE 'PATHNAME) (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG))) [(STREAMP FILE) (* ;  "For streams, use full name. If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (COND (ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME) FILE)) (T (LIST 'NAME FILE] (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ;  "some Xerox and Arpanet systems use '[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ;  "this is the 'proposed standard' for Xerox servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (UNPACKFILE1 'HOST 2 TEM) [COND ((EQ TEM -1) (* ;  "Started with the host field delimiter, but there was no corresponding terminating delimiter .") (* ;  "I'm not sure why the name is dealt with the host name.") (RETURN (DREVERSE VAL] (SETQ POS (IPLUS TEM 2)) [if (EQ OSTYPE T) then (* ;  "Use actual host to determine os type") (SETQ OSTYPE (GETHOSTINFO (CAR VAL) 'OSTYPE] (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (* ;  "all device returned have DEVICE.END on it so that NIL: will work") (UNPACKFILE1 'DEVICE POS (if CLFLG then (SUB1 TEM) else TEM)) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (COND ((EQ DIRFLG 'RETURN) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.") (LET ((TYPE 'DIRECTORY) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (* ; "just host, return") (RETURN (DREVERSE VAL))) ((/ <) (* ;  "Started with the initial directory delimiter.") (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) [COND ((EQ START POS) (* ;  "Didn't start with a directory delimiter,") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory") (SETQ TYPE 'SUBDIRECTORY)) (T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE 'RELATIVEDIRECTORY] (COND ((EQ LEN POS) (* ;  "Only the initial directory is specified (i.e. %"{DSK}/%").") (SETQ START POS) -1) (T -2))) (PROGN [COND [(EQ START POS) (* ;  "Both of the initial and trail delimiters are omitted.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory") (SETQ TYPE 'SUBDIRECTORY)) (T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE 'RELATIVEDIRECTORY] (T (COND ((EQ LEN POS) (* ;  "Only the initial directory is specified (i.e. %"{DSK}<%").") (SETQ START POS] -1))) (UNPACKFILE1.DIRECTORY TYPE START END)) (RETURN (DREVERSE VAL))) ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ;  "unix and the 'xerox standard' use / for delimiter") (* ;  "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.") (SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE (ADD1 POS))) T) ((< >) (* ;  "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") (* ;  "In the case of the {DSK} /)) FILE (ADD1 POS))) T) NIL) (* ;; "allow {DSK}/etc to be a directory specification.") (if TEM then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS) (SUB1 TEM)) (SETQ POS (ADD1 TEM)) else (* ;; "{DSK}/foo: the directory is /, the name is foo") (UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS) (SETQ POS (ADD1 POS))) (SETQ HOSTP T)) ((SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE POS)) (* ; " {eris}abc> relative") (* ;;  " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.") [COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case.") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD) then 'DIRECTORY else 'SUBDIRECTORY) POS (SUB1 TEM))) (T (* ; "True %"relative pathname%".") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD) then 'DIRECTORY else 'RELATIVEDIRECTORY) POS (SUB1 TEM] (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (DREVERSE VAL))) (if (EQ OSTYPE T) then (* ;  "There wasn't a host field in the name, so we have no clue") (SETQ OSTYPE NIL)) NAMELP (* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.") (SELCHARQ CODE (%. (* ;  "Note position for later--we only want to deal with the last set of dots") (if BEYONDNAME then (* ;  "no longer of interest (probably a bad name, too)") elseif FIRSTDOT then (* ; "We're recording the second dot") (if SECONDDOT then (* ;  "Note only the two most recent dots") (SETQ FIRSTDOT SECONDDOT)) (SETQ SECONDDOT TEM) else (SETQ FIRSTDOT TEM))) ((! ; NIL) (* ;  "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now") (if (SELCHARQ CODE (! (* ;  "! is only a delimiter on IFS, so ignore it if we know the ostype is something else") (AND OSTYPE (NEQ OSTYPE 'IFS))) (; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S") [AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM]) NIL) then (GO NEXTCHAR)) (if FIRSTDOT then (* ;  "Have a name and/or extension to parse now") (if [AND SECONDDOT (NOT (if OSTYPE then (* ;  "Known OS type must be Tops20 for second dot to mean version") (EQ OSTYPE 'TOPS20) else (* ;  "Unknown OS type, so check that %"version%" is numeric or wildcard") (AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM) bind CH always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I))) (EQ CH (CHARCODE *] (SELCHARQ CODE (NIL (* ; "end of file name, ok") T) (; (* ;  "This semi-colon better not be introducing a version") (\UPF.TEMPFILEP FILE (ADD1 TEM))) NIL] then (* ;  "Second dot is not intoducing a version") (SETQ FIRSTDOT SECONDDOT) (SETQ SECONDDOT NIL)) (UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT)) (SETQ POS (ADD1 (if SECONDDOT then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT) (SUB1 SECONDDOT)) (SETQ BEYONDEXT T) SECONDDOT else FIRSTDOT))) (SETQ BEYONDNAME T) (SETQ FIRSTDOT NIL)) (UNPACKFILE1 (COND ((NOT BEYONDNAME) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) 'EXTENSION) ((AND (EQ BEYONDEXT (CHARCODE ";")) (\UPF.TEMPFILEP FILE POS))) (T (* ;  "Everything after the semi was version") 'VERSION)) POS (SUB1 TEM)) (if (NULL CODE) then (* ; "End of string") (RETURN (DREVERSE VAL))) (SETQ BEYONDEXT CODE) (* ;  "Note the character that terminated the name/ext") (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP]) (LASTCHPOS [LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER") (PROG (RESULT NC) (OR START (SETQ START 1)) (while (SETQ NC (NTHCHARCODE STR START)) do (COND ((EQMEMB NC CH) (SETQ RESULT START)) ((EQ NC (CHARCODE %')) (add START 1))) (add START 1)) (RETURN RESULT]) (\UPF.NEXTPOS [LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41") (bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND ((EQMEMB NCH CHAR) (RETURN POS)) ((EQ NCH (CHARCODE %')) (add POS 1))) (add POS 1]) (\UPF.TEMPFILEP [LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:") (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.") (SELCHARQ (NTHCHARCODE FILENAME START) ((T S) (* ; "Funny temp stuff") (AND (EQ START (NCHARS FILENAME)) 'TEMPORARY)) NIL]) (FILENAMEFIELD [LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm") (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME ((VERSION GENERATION) 'VERSION) ((DEVICE STRUCTURE) 'DEVICE) FIELDNAME) 'FIELD NIL T]) (PACKFILENAME [LAMBDA N (* bvm%: " 5-Jul-85 15:40") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME) (ARG N 1))) (T (PACK (PACKFILENAME.ASSEMBLE]) (PACKFILENAME.STRING [LAMBDA N (* bvm%: " 5-Jul-85 15:41") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME.STRING) (ARG N 1))) (T (CONCATLIST (PACKFILENAME.ASSEMBLE]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CANONICAL.DIRECTORY MACRO [OPENLAMBDA (SRCSTRING) (AND SRCSTRING (LET ((LEN (NCHARS SRCSTRING))) (COND ((EQ LEN 1) (if (STREQUAL SRCSTRING "/") then "<" else SRCSTRING)) (T (LET* ((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING)) (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T))) (DSTBASE (ffetch (STRINGP BASE) of DSTSTRING)) (DSTPOS 0) (NEXTPOS -1)) (if (NOT FATP) then [for SRCPOS from 1 to LEN bind CODE first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) (CHARCODE (< / >))) do (add SRCPOS 1)) (if (> SRCPOS LEN) then (RETURN "<")) do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) ((> /) (if (> DSTPOS NEXTPOS) then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >)) (SETQ NEXTPOS (add DSTPOS 1)))) (%' (\PUTBASETHIN DSTBASE DSTPOS CODE) (add DSTPOS 1) (if (NEQ SRCPOS LEN) then (\PUTBASETHIN DSTBASE DSTPOS (NTHCHARCODE SRCSTRING (add SRCPOS 1))) (add DSTPOS 1))) (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE) (add DSTPOS 1))) finally (RETURN (if (EQ DSTPOS LEN) then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 -2) else DSTSTRING) elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) else (SUBSTRING DSTSTRING 1 DSTPOS] else (for SRCPOS from 1 to LEN bind CODE first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) (CHARCODE (< / >))) do (add SRCPOS 1)) do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) ((> /) (if (> DSTPOS NEXTPOS) then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >)) (SETQ NEXTPOS (add DSTPOS 1)))) (%' (\PUTBASEFAT DSTBASE DSTPOS CODE) (add DSTPOS 1) (if (NEQ SRCPOS LEN) then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE SRCSTRING (add SRCPOS 1) )) (add DSTPOS 1))) (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE) (add DSTPOS 1))) finally (RETURN (if (EQ DSTPOS LEN) then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 -2) else DSTSTRING) elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) else (SUBSTRING DSTSTRING 1 DSTPOS]) (PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END) (LET* ((OLDDIR (SUBSTRING FILE ST END)) (NEWDIR (CANONICAL.DIRECTORY OLDDIR))) (COND [(NOT ONEFIELDFLG) (SETQ VAL (CONS (COND (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) (T (OR NEWDIR ""))) (CONS NAM VAL] ((EQMEMB NAM ONEFIELDFLG) (RETURN (COND (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) (T (OR NEWDIR ""]) (PUTPROPS PACKFILENAME.ASSEMBLE MACRO [NIL (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((<= I N) (* ;; "Grab the next field-name / value pair and fold it into the filename:") (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((<= (SETQ I (ADD1 I)) N) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (EQ VAR 'BODY) (\ILLEGAL.ARG VAL)) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (PACKFILENAME.STRING VAL)) (T VAL)) NIL 'OK) [FUNCTION (LAMBDA (X) (SELECTQ (CAR X) (HOST (OR HOST (SETQ HOST (OR (CADR X) BLIP)))) (DEVICE (OR DEVICE (SETQ DEVICE (OR (CADR X) BLIP)))) (DIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR (CADR X) BLIP)))) (RELATIVEDIRECTORY [OR RELATIVEDIRECTORY (COND (DIRECTORY (SETQ RELATIVEDIRECTORY BLIP)) (T (SETQ RELATIVEDIRECTORY (OR (CADR X) BLIP]) (NAME (OR NAME (SETQ NAME (OR (CADR X) BLIP)))) (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR (CADR X) BLIP)))) (VERSION (OR VERSION (SETQ VERSION (OR (CADR X) BLIP)))) (SHOULDNT] (FUNCTION CDDR))) (HOST [OR HOST (SETQ HOST (COND (VAL (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL)) (T BLIP]) ((PATHNAME DIRECTORY) [COND (VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL 'RETURN)) by (CDDR X) do (SELECTQ (CAR X) (HOST [COND ((NOT HOST) (SETQ HOST (OR (CADR X) BLIP]) (DEVICE [COND ((NOT DEVICE) (SETQ DEVICE (OR (CADR X) BLIP]) (SUBDIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (RELATIVEDIRECTORY (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS") (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR (CADR X) BLIP)))) (DIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (ERROR "Illegal field in DIRECTORY slot" VAL))) (for X on VAL by (CDDR X) do (SELECTQ (CAR X) (HOST (OR DEVICE (SETQ DEVICE BLIP)) (OR DIRECTORY (SETQ DIRECTORY BLIP))) (DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP))) NIL))) (T (OR DIRECTORY (SETQ DIRECTORY BLIP]) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP)))) (RELATIVEDIRECTORY (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS") (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP)))) (DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP)))) (NAME (OR NAME (SETQ NAME (OR VAL BLIP)))) (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR VAL BLIP)))) (VERSION (OR VERSION (SETQ VERSION (OR VAL BLIP)))) (TEMPORARY (OR TEMPORARY (SETQ TEMPORARY (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (COND ((EQ HOST BLIP) (SETQ HOST NIL))) (COND ((EQ DEVICE BLIP) (SETQ DEVICE NIL))) (COND ((EQ DIRECTORY BLIP) (SETQ DIRECTORY NIL))) [COND ((EQ SUBDIRECTORY BLIP) (SETQ SUBDIRECTORY NIL)) ((AND NIL SUBDIRECTORY) (COND ((AND (NULL DIRECTORY) (OR HOST DEVICE)) (SETQ DIRECTORY SUBDIRECTORY) (SETQ SUBDIRECTORY NIL] (COND ((EQ RELATIVEDIRECTORY BLIP) (SETQ RELATIVEDIRECTORY NIL))) (RETURN (NCONC (AND HOST (LIST "{" HOST "}")) [AND DEVICE (COND ((AND (SETQ TEMP (LASTCHPOS (CHARCODE %:) DEVICE 1)) (EQ TEMP (NCHARS DEVICE))) (LIST DEVICE)) (T (LIST DEVICE ":"] [COND (DIRECTORY (COND [[OR (STREQUAL DIRECTORY "<") (AND (SETQ TEMP (LASTCHPOS (CHARCODE (> /)) DIRECTORY 1)) (EQ TEMP (NCHARS DIRECTORY] (COND ((EQMEMB (NTHCHARCODE DIRECTORY 1) (CHARCODE (< /))) (LIST DIRECTORY)) (T (LIST (CL:FIRST \FILENAME.SYNTAX) DIRECTORY] (T (LIST (CL:FIRST \FILENAME.SYNTAX) DIRECTORY (CL:SECOND \FILENAME.SYNTAX] [COND (RELATIVEDIRECTORY (COND ((AND (SETQ TEMP (LASTCHPOS (CHARCODE (> /)) RELATIVEDIRECTORY 1)) (EQ TEMP (NCHARS RELATIVEDIRECTORY))) (LIST RELATIVEDIRECTORY)) (T (LIST RELATIVEDIRECTORY (CL:SECOND \FILENAME.SYNTAX ] [COND (SUBDIRECTORY (LIST SUBDIRECTORY (CL:SECOND \FILENAME.SYNTAX] (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) BLIP) (T '%.)) (OR EXTENSION BLIP))) (AND VERSION (NEQ VERSION BLIP) (LIST (CL:THIRD \FILENAME.SYNTAX) (COND ((FIXP VERSION) VERSION) (T (SELCHARQ (CHCON1 VERSION) ((%. ! ;) (SUBSTRING VERSION 2 -1)) VERSION]) (PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21") (COND [(NOT ONEFIELDFLG) (SETQ VAL (CONS (COND (PACKFLG (SUBATOM FILE ST END)) (T (OR (SUBSTRING FILE ST END) ""))) (CONS NAM VAL] ((EQMEMB NAM ONEFIELDFLG) (RETURN (COND (PACKFLG (SUBATOM FILE ST END)) (T (OR (SUBSTRING FILE ST END) ""]) ) ) (RPAQQ \FILENAME.SYNTAX ("<" ">" ";")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FILENAME.SYNTAX) ) (* ; "saving and restoring system state") (DEFINEQ (LOGOUT [LAMBDA (FAST) (* hdj "23-May-86 16:20") (\USEREVENT 'BEFORELOGOUT) (COND ((OR (EQ FAST T) (\FLUSHVMOK? 'LOGOUT)) (* ;  "Check that we have a vmem file before allowing LOGOUT") (\PROCESS.BEFORE.LOGOUT) (\DEVICEEVENT 'BEFORELOGOUT) (\SETTOTALTIME) (* ;  "update the total time that this sysout has been running.") (\LOGOUT0 FAST) (* ;; "Must re-establish the state of devices and of previously open files that might have been modified at the EXEC.") (\RESETKEYBOARD) (\DEVICEEVENT 'AFTERLOGOUT) (\OPENLINEBUF) (\PROCESS.AFTER.EXIT 'AFTERLOGOUT) (\USEREVENT 'AFTERLOGOUT) (INTERPRET.REM.CM) NIL]) (MAKESYS [LAMBDA (FILE NAME) (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE NAME)) (* ; "Edited 13-Oct-2020 22:51 by rmk:") (* ; "Edited 28-Jul-88 18:16 by drc:") (\FLUSHVMOK? 'MAKESYS) (\USEREVENT 'BEFOREMAKESYS) (HERALD (CONCAT (OR NAME (CL:STRING-CAPITALIZE MAKESYSNAME)) " " (SUBSTRING (SETQ MAKESYSDATE (DATE)) 1 11) " ...")) (\DEVICEEVENT 'BEFOREMAKESYS) (* ;; "RMK: make sysout on a temp file, then rename it in order to get version numbers") (LET [(NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE)) "-TEMP"] (COND ((NLISTP NEWFILE) (* ;  "Coming back from doing the MAKESYS, so just set up to keep going.,") (\DEVICEEVENT 'AFTERDOMAKESYS) (\USEREVENT 'AFTERDOMAKESYS) (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE))) FILE) (T (* ;  "Coming back in the MAKESYS'd sysout, so restart the world.") (\DEVICEEVENT 'AFTERMAKESYS) (\PROCESS.AFTER.EXIT 'AFTERMAKESYS) (PRIN1 HERALDSTRING T) (\USEREVENT 'AFTERMAKESYS) (INTERPRET.REM.CM) (* ;  "Run the commands in the file REM.CM") (RESET]) (SYSOUT [LAMBDA (FILE) (* ; "Edited 14-Oct-2020 11:13 by rmk:") (* hdj "29-Sep-86 12:14") (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE)) (* ;  "FILE is special so that BEFORESYSOUTFORMS can alter it") (\FLUSHVMOK? 'SYSOUT) (\USEREVENT 'BEFORESYSOUT) (\DEVICEEVENT 'BEFORESYSOUT) (* ;;  "RMK: Fix it so that sysouts are versioned. Temp file goes to same place as eventual sysout.") (LET ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS)) NEWFILE) (* ;  "update the total time field so that the run time in the sysout will be right.") (\SETTOTALTIME) (SETQ NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE)) "-TEMP"))) (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE))) [COND ((NLISTP NEWFILE) (* ;; "Continuing in same sysout; reset TOTALTIME in misc stats page to not include the time before the sysout.") (replace TOTALTIME of \MISCSTATS with TOTALTIMESAVE) (\DEVICEEVENT 'AFTERDOSYSOUT) (\USEREVENT 'AFTERDOSYSOUT)) (T (* ; "restarting") (\DEVICEEVENT 'AFTERSYSOUT) (\PROCESS.AFTER.EXIT 'AFTERSYSOUT) (INTERPRET.REM.CM) (\USEREVENT 'AFTERSYSOUT] FILE]) (SAVEVM [LAMBDA (RELEASEFLG) (* hdj "23-May-86 16:20") (* ;; "Save the virtual memory. This is similar to logging out, then back in, but is much faster, since it doesn't lose any pages. Conceptually, this is like doing a sysout to Lisp.virtualmem") (\FLUSHVMOK? 'SAVEVM) (\USEREVENT 'BEFORESAVEVM) (\DEVICEEVENT 'BEFORESAVEVM) (COND ((\FLUSHVM) (\RESETKEYBOARD) (* ;  "Returns T when starting up fresh") (\DEVICEEVENT 'AFTERSAVEVM) (\PROCESS.AFTER.EXIT 'AFTERSAVEVM) (\USEREVENT 'AFTERSAVEVM) T) (T (\DEVICEEVENT 'AFTERDOSAVEVM) (\USEREVENT 'AFTERDOSAVEVM]) (HERALD [LAMBDA (STR) (* wt%: " 2-MAY-79 15:38") (AND STR (SETQ HERALDSTRING STR)) HERALDSTRING]) (INTERPRET.REM.CM [LAMBDA (RETFLG) (* ; "Edited 22-Feb-2021 15:31 by larry") (DECLARE (GLOBALVARS STARTUPFORM)) (* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote. If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP, among others. If RETFLG is true, the expression read is simply returned") (PROG ((FILE (UNIX-GETENV "LDEINIT")) COM) (OR FILE (RETURN)) (SETQ FILE (OPENSTREAM FILE 'INPUT)) [COND ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH) 0) (EQ (SKIPSEPRS FILE T) '%") (SETQ COM (CAR (NLSETQ (READ FILE T] (CLOSEF FILE) (COND (RETFLG (* ; "Save it to return")) (T (* ; "Unread a string") (* ;  "RMK: Replace CR and LF by space to avoid EOL convention issues") (for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I) (CHARCODE (CR LF EOL))) do (RPLCHARCODE COM I (CHARCODE EOL))) (BKSYSBUF COM] (RETURN (COND (RETFLG COM) (COM T]) (\USEREVENT [LAMBDA (EVENT) (DECLARE (GLOBALVARS AROUNDEXITFNS)) (* bvm%: "16-Dec-83 15:27") (for FN in (SELECTQ EVENT ((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS) AROUNDEXITFNS) (REVERSE AROUNDEXITFNS)) do (APPLY* FN EVENT]) ) (ADDTOVAR AROUNDEXITFNS ) (RPAQ? HERALDSTRING "") (RPAQ? \USERNAME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS) ) (DEFINEQ (USERNAME [LAMBDA (FLG STRPTR PRESERVECASE) (* lmm "28-MAR-82 14:10") (* ;  "On 10, USERNAME can take a user number as arg") (PROG (ADDR NAME) (SETQ NAME (COND (FLG NIL) ((NEQ 0 (SETQ ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (GetBcplString (\ADDBASE (EMADDRESS 0) ADDR) (EQ STRPTR T))) (T \USERNAME))) (OR PRESERVECASE (NULL NAME) (SETQ NAME (U-CASE NAME))) (RETURN (COND ((NULL NAME) NIL) ((STRINGP STRPTR) (SUBSTRING NAME 1 -1 STRPTR)) (T NAME]) (SETUSERNAME [LAMBDA (NAME) (* lmm "28-MAR-82 14:11") (* ;  "Changed interpretation of UserName0") (COND (NAME (PROG ((ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (RETURN (COND ((NEQ ADDR 0) (SetBcplString (\ADDBASE (EMADDRESS 0) ADDR) NAME) (SETQ USERNAME (USERNAME NIL T))) (T (SETQ \USERNAME (CONCAT NAME]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) FILEIO) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME) ) (PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1920 2017 2020 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2705 9399 (DELFILE 2715 . 2876) (FULLNAME 2878 . 3245) (INFILE 3247 . 3395) (INFILEP 3397 . 3532) (IOFILE 3534 . 3674) (OPENFILE 3676 . 4076) (OPENSTREAM 4078 . 8386) (OUTFILE 8388 . 8539 ) (OUTFILEP 8541 . 8677) (RENAMEFILE 8679 . 8985) (SIMPLE.FINDFILE 8987 . 9397)) (9771 29362 ( UNPACKFILENAME 9781 . 9967) (UNPACKFILENAME.STRING 9969 . 26241) (LASTCHPOS 26243 . 26937) ( \UPF.NEXTPOS 26939 . 27584) (\UPF.TEMPFILEP 27586 . 28163) (FILENAMEFIELD 28165 . 28650) (PACKFILENAME 28652 . 28995) (PACKFILENAME.STRING 28997 . 29360)) (51803 59344 (LOGOUT 51813 . 52774) (MAKESYS 52776 . 54547) (SYSOUT 54549 . 56296) (SAVEVM 56298 . 57110) (HERALD 57112 . 57272) (INTERPRET.REM.CM 57274 . 58967) (\USEREVENT 58969 . 59342)) (59526 61253 (USERNAME 59536 . 60492) (SETUSERNAME 60494 . 61251))))) STOP \ No newline at end of file diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 1593d048..527f9214 100644 Binary files a/sources/ADIR.LCOM and b/sources/ADIR.LCOM differ diff --git a/sources/LLSUBRS b/sources/LLSUBRS index b9dcbf8f..ce9304e5 100644 --- a/sources/LLSUBRS +++ b/sources/LLSUBRS @@ -1 +1 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Dec-92 14:28:41" |{PELE:MV:ENVOS}SOURCES>LLSUBRS.;15| 21492 changes to%: (RECORDS MISCN-UFN-ENTRY) previous date%: "21-Feb-92 12:54:44" |{PELE:MV:ENVOS}SOURCES>LLSUBRS.;14|) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLSUBRSCOMS) (RPAQQ LLSUBRSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS))) (* ;;; "MISCN Vars & Functions") (EXPORT (VARS \MISCN-TABLE-LIST)) (FUNCTIONS MISCN) (OPTIMIZERS MISCN) (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE) (PROP ARGNAMES MISCN) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY)) (* ;;; " USER-SUBR Vars & Functions") (EXPORT (VARS \USER-SUBR-LIST)) (FUNCTIONS USER-SUBR ADD-USER-SUBR) (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR EQ-TO-CADR) (PROP ARGNAMES USER-SUBR) (* ;;; "SUBRCALL Vars & Functions") (EXPORT (VARS \INITSUBRS)) (FUNCTIONS SUBRCALL) (OPTIMIZERS SUBRCALL) (FNS SUBRNUMBER) (* ;; "use this to make a subrs.h file for Maiko ") (FNS WRITECALLSUBRS FIX-SUBR-NAME) (PROP ARGNAMES SUBRCALL) (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING)) (INITRESOURCES UNIXSTRING) (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV UNIX-GETPARM) (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD) (PROPS (LLSUBRS FILETYPE)))) (DECLARE%: EVAL@COMPILE DONTCOPY (ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS) ) (* ;;; "MISCN Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \MISCN-TABLE-LIST ((USER-SUBR 0 \USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL) (LCFetchMethod 7 LCFetchMethod NIL) (LCFetchMethodOrHelp 8 NIL NIL) (LCFindVarIndex 9 NIL NIL) (LCGetIVValue 10 NIL NIL) (LCPutIVValue 11 NIL NIL))) (* "END EXPORTED DEFINITIONS") (DEFMACRO MISCN (NAME &REST ARGS) [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X) (GENSYM] `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES ((OPCODES MISCN ,(MISCN-NUMBER NAME) ,(LENGTH ARGS)) ,@ARGNAMES] ,@ARGS]) (DEFOPTIMIZER MISCN (NAME &REST ARGS) `((OPCODES MISCN ,(MISCN-NUMBER NAME) ,(LENGTH ARGS)) ,@ARGS)) (DEFINEQ (MISCN-NUMBER (LAMBDA (NAME) (* ; "Edited 7-Nov-88 15:21 by krivacic") (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST) (ERROR NAME " not a MISCN index")))) ) (\MISCN.UFN (LAMBDA (ALPHA-BETA) (* ; "Edited 8-Jun-89 16:57 by jds") (* ;; "The UFN for the MISCN opcode.") (DECLARE (GLOBALVARS \MISCN-TABLE)) (* ;; "Get the misc index & number of args from the code stream") (LET ((INDEX (LRSH ALPHA-BETA 8)) (ARG-COUNT (LOGAND ALPHA-BETA 255))) (* ;; "compute the position of the real IVARS on the stack. Create a pointer to these args and pass it to the Handler routine.") (COND ((NOT (AND (BOUNDP (QUOTE \MISCN-TABLE)) \MISCN-TABLE)) (\INIT-MISCN-TABLE))) (LET* ((CALLER (\MYALINK)) (MY-BF (\GET-MY-BF)) (MY-IVAR (fetch (BF IVAR) of MY-BF)) (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1))) (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR)) (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1)))) (COND ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY) (* ;; "This UFN can return Multiple values, so we need to preserve them.") (CL:UNWIND-PROTECT (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))) (T (* ;; "He said no MVs are possible, so don't even TRY to preserve them. This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!") (PROG1 (.UNWIND.PROTECT. (FUNCTION (LAMBDA NIL (replace (BF IVAR) of MY-BF with RESULT-IVAR))) (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR)) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))))))) ) (\UNDEFINED-MISCN-UFN (LAMBDA (INDEX ARG-COUNT ARG-PTR) (* ; "Edited 3-Nov-88 15:56 by krivacic") (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T) (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR))) ) (MISCN-COLLECT (LAMBDA (ARG-COUNT ARG-PTR) (* ; "Edited 3-Nov-88 11:52 by krivacic") (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1)))) ) (\GET-MY-BF (LAMBDA NIL (* ; "Edited 3-Nov-88 11:08 by krivacic") (* ;; "Returns the stack index of the caller's BF.") (- (\MYALINK) 2)) ) (\INIT-MISCN-TABLE (LAMBDA NIL (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE)) (* ; "Edited 7-Mar-89 09:43 by jds") (LET ((OP-NUMBER 36) (OP-LENGTH 3) BASE) (SETQ \MISCN-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-MISCN-UFN) 0)) (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE)) (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY) (CADDR MISCN-ENTRY)) (REPLACE (MISCN-UFN-ENTRY MISCN-MVS) OF (\ADDBASE2 BASE (FETCH (MISCN-UFN-SPEC INDEX) OF MISCN-ENTRY)) WITH (FETCH (MISCN-UFN-SPEC MVS) OF MISCN-ENTRY))) (SETQ \MISCN-TABLE BASE))) ) ) (PUTPROPS MISCN ARGNAMES (NAME &REST ARGS)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD MISCN-UFN-SPEC ( (* ;;  "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.") NAME (* ;  "Name of the MISCN, for the MISCN macro's use.") INDEX (* ; "Sub-opcode index.") UFN-NAME (* ; "Name of the UFN") MVS (* ;  "T if the UFN can returnmultiple values. If this is NIL, MVs WILL NOT BE PRESERVED.") )) (BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG) (NIL BITS 3) (MISCN-UFN POINTER))) ) ) (* ;;; " USER-SUBR Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (* "END EXPORTED DEFINITIONS") (DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS) `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME) ,@ARGS)) (CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN) (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ;; "Make Sure \USER-SUBR-TABLE is made") (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (* ;; "See if the Name is already defined") [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST) (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME) (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)) '\UNDEFINED-USER-SUBR-UFN) (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR] (* ;; "See if the UFN is already defined") [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) '\UNDEFINED-USER-SUBR-UFN) (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND)) (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX) (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR] (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN)) \USER-SUBR-LIST) (\INIT-USER-SUBR-TABLE)) (DEFINEQ (\USER-SUBR-UFN (LAMBDA (INDEX ARG-COUNT ARG-PTR) (DECLARE (GLOBALVARS \USER-SUBR-TABLE)) (* ; "Edited 4-Nov-88 18:43 by krivacic") (IF (NOT (AND (BOUNDP (QUOTE \USER-SUBR-TABLE)) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1))) (* ;; "User SUBR ufn. Index on the User subr indexes") (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) USER-SUBR-INDEX (- ARG-COUNT 1) (\ADDBASE ARG-PTR 2)))) ) (\INIT-USER-SUBR-TABLE (LAMBDA NIL (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ; "Edited 4-Nov-88 18:58 by krivacic") (SETQ \USER-SUBR-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-USER-SUBR-UFN) 0)) (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY) (CADDR SUBR-ENTRY)))) ) (\UNDEFINED-USER-SUBR-UFN (LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR) (* ; "Edited 7-Nov-88 14:33 by krivacic") (* ;; "User SUBR ufn. Index on the User subr indexes") (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR))) ) (USER-SUBR-NUMBER (LAMBDA (NAME) (* ; "Edited 4-Nov-88 18:42 by krivacic") (CADR (OR (ASSOC NAME \USER-SUBR-LIST) (ERROR NAME " not a USER-SUBR index")))) ) (EQ-TO-CAR (LAMBDA (ITEM LIST) (EQ ITEM (CAR LIST)))) (EQ-TO-CADR (LAMBDA (ITEM LIST) (EQ ITEM (CADR LIST)))) ) (PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS)) (* ;;; "SUBRCALL Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) (WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) (CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) (UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) (UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) (ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) (DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) (BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) (KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) (DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) (COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107) (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) (DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119) (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) (GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) (COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (C-SlowBltChar 140) (UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) (CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) (CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) (DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209))) (* "END EXPORTED DEFINITIONS") (DEFMACRO SUBRCALL (NAME &REST ARGS) [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X) (GENSYM] `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES ((OPCODES SUBRCALL ,(SUBRNUMBER NAME) ,(LENGTH ARGS)) ,@ARGNAMES] ,@ARGS]) (DEFOPTIMIZER SUBRCALL (NAME &REST ARGS) `((OPCODES SUBRCALL ,(SUBRNUMBER NAME) ,(LENGTH ARGS)) ,@ARGS)) (DEFINEQ (SUBRNUMBER [LAMBDA (NAME) (* ; "Edited 5-Feb-92 16:49 by jds") (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.") (LET (NUMBER) (COND ((FIXP NAME) (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME) NAME) ((CADR (ASSOC NAME \INITSUBRS))) ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL] (CL:WARN "SUBR name ~s is in wrong package. Using ~d as subr number." NAME NUMBER)) (T (ERROR NAME " not a SUBR"]) ) (* ;; "use this to make a subrs.h file for Maiko ") (DEFINEQ (WRITECALLSUBRS (LAMBDA NIL (* ; "Edited 6-Nov-89 15:39 by jds") (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (CL:FORMAT T "/* This file written from LLSUBRS on ~A */~&" (DATE)) (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&") (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to */~&") (CL:FORMAT T "/* generate a new version. */~&") (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* MISCN opcodes */~&") (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&") (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))))) ) (FIX-SUBR-NAME (LAMBDA (NAME) (* ; "Edited 13-Feb-89 16:17 by jds") (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:") (* ;; "Converting all -'s to _'s") (* ;; "Converting all .'s to _'s") (* ;; "Removing all \'s.") (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.") (CONCATCODES (DREMOVE (CHARCODE \) (SUBST (CHARCODE _) (CHARCODE %.) (SUBST (CHARCODE _) (CHARCODE -) (CHCON NAME)))))) ) ) (PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS)) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512] ) ) (/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL) (DEFINEQ (\MOREVMEMFILE (LAMBDA (FILEPAGE) (* ; "Edited 27-Apr-88 13:36 by MASINTER") (SUBRCALL MOREVMEMFILE FILEPAGE))) (\WRITEMAP (LAMBDA (VP RP FLAGS) (* ; "Edited 27-Apr-88 13:37 by MASINTER") (SUBRCALL WRITEMAP VP RP FLAGS))) (\COPYSYS0SUBR (LAMBDA (FID) (* ; "Edited 20-Apr-88 12:36 by MASINTER") (SUBRCALL COPYSYS0SUBR FID))) (\PUPLEVEL1STATE (LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL PUPLEVEL1STATE FLG))) (SHOWDISPLAY (LAMBDA (BASE RASTERWIDTH) (* ; "Edited 27-Apr-88 13:40 by MASINTER") (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ") (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH)) ) (SETSCREENCOLOR (LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL SETSCREENCOLOR FLG))) (\WRITERAWPBI (LAMBDA (PBI) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL WRITERAWPBI PBI))) (\READRAWPBI (LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL READRAWPBI))) (RAID (LAMBDA (MESS1 MESS2 FLG) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL RAID MESS1 MESS2 FLG))) (\LISPFINISH (LAMBDA (DUMMY) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL LISPFINISH DUMMY))) (\GETPACKETBUFFER (LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GETPACKETBUFFER))) (\GATHERSTATS (LAMBDA (FID) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GATHERSTATS FID))) (\DSPRATE (LAMBDA (AC0 AC1 AC2) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPRATE AC0 AC1 AC2)) ) (DSPBOUT (LAMBDA (CHARCODE) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPBOUT CHARCODE))) (DISKPARTITION (LAMBDA NIL (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (SUBRCALL DISKPARTITION)) ((DANDELION DOVE) (\DFSCurrentVolume)) NIL)) ) (\CHECKBCPLPASSWORD (LAMBDA (USER PASSWORD) (* ; "Edited 14-Jun-88 13:33 by drc:") (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD)) ) (SUSPEND-LISP (LAMBDA NIL (* ; "Edited 20-Jun-88 15:24 by greep") (if (EQ (MACHINETYPE) (QUOTE MAIKO)) then (SUBRCALL SUSPEND-LISP) T else NIL)) ) (UNIX-USERNAME (LAMBDA NIL (* ; "Edited 1-Aug-88 23:22 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-FULLNAME (LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-GETENV (LAMBDA (NAME) (* ; "Edited 1-Aug-88 23:13 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-GETENV (MKSTRING NAME) UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-GETPARM (LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator. Usually gets info about configuration of the machine we're running on.") (* ;; "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") (if (EQ \MACHINETYPE \MAIKO) then (LET (LEN) (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) UNIXSTRING)) (COND ((SMALLP LEN) (if (> LEN 0) then (CONCAT (SUBSTRING UNIXSTRING 1 LEN)))) (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING)))))))))) ) ) (PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH)) (PUTPROPS SETSCREENCOLOR ARGNAMES (FLG)) (PUTPROPS \WRITERAWPBI ARGNAMES (PBI)) (PUTPROPS \READRAWPBI ARGNAMES NIL) (PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG)) (PUTPROPS \LISPFINISH ARGNAMES (DUMMY)) (PUTPROPS \GETPACKETBUFFER ARGNAMES NIL) (PUTPROPS \GATHERSTATS ARGNAMES (FID)) (PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2)) (PUTPROPS DSPBOUT ARGNAMES (CHARCODE)) (PUTPROPS DISKPARTITION ARGNAMES NIL) (PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR)) (PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE) (PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3665 6454 (MISCN-NUMBER 3675 . 3830) (\MISCN.UFN 3832 . 5287) (\UNDEFINED-MISCN-UFN 5289 . 5557) (MISCN-COLLECT 5559 . 5726) (\GET-MY-BF 5728 . 5871) (\INIT-MISCN-TABLE 5873 . 6452)) ( 9128 10493 (\USER-SUBR-UFN 9138 . 9578) (\INIT-USER-SUBR-TABLE 9580 . 9907) (\UNDEFINED-USER-SUBR-UFN 9909 . 10208) (USER-SUBR-NUMBER 10210 . 10371) (EQ-TO-CAR 10373 . 10430) (EQ-TO-CADR 10432 . 10491)) ( 14756 15405 (SUBRNUMBER 14766 . 15403)) (15466 16873 (WRITECALLSUBRS 15476 . 16376) (FIX-SUBR-NAME 16378 . 16871)) (17082 20697 (\MOREVMEMFILE 17092 . 17207) (\WRITEMAP 17209 . 17322) (\COPYSYS0SUBR 17324 . 17429) (\PUPLEVEL1STATE 17431 . 17540) (SHOWDISPLAY 17542 . 17780) (SETSCREENCOLOR 17782 . 17890) (\WRITERAWPBI 17892 . 17995) (\READRAWPBI 17997 . 18092) (RAID 18094 . 18206) (\LISPFINISH 18208 . 18313) (\GETPACKETBUFFER 18315 . 18420) (\GATHERSTATS 18422 . 18525) (\DSPRATE 18527 . 18682) (DSPBOUT 18684 . 18788) (DISKPARTITION 18790 . 18977) (\CHECKBCPLPASSWORD 18979 . 19111) (SUSPEND-LISP 19113 . 19263) (UNIX-USERNAME 19265 . 19515) (UNIX-FULLNAME 19517 . 19768) (UNIX-GETENV 19770 . 20035 ) (UNIX-GETPARM 20037 . 20695))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Feb-2021 21:20:11" {DSK}larry>medley>sources>LLSUBRS.;2 21799 changes to%: (FNS UNIX-GETENV) previous date%: "17-Dec-92 14:28:41" {DSK}larry>medley>sources>LLSUBRS.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT LLSUBRSCOMS) (RPAQQ LLSUBRSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS))) (* ;;; "MISCN Vars & Functions") (EXPORT (VARS \MISCN-TABLE-LIST)) (FUNCTIONS MISCN) (OPTIMIZERS MISCN) (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE) (PROP ARGNAMES MISCN) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY)) (* ;;; " USER-SUBR Vars & Functions") (EXPORT (VARS \USER-SUBR-LIST)) (FUNCTIONS USER-SUBR ADD-USER-SUBR) (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR EQ-TO-CADR) (PROP ARGNAMES USER-SUBR) (* ;;; "SUBRCALL Vars & Functions") (EXPORT (VARS \INITSUBRS)) (FUNCTIONS SUBRCALL) (OPTIMIZERS SUBRCALL) (FNS SUBRNUMBER) (* ;; "use this to make a subrs.h file for Maiko ") (FNS WRITECALLSUBRS FIX-SUBR-NAME) (PROP ARGNAMES SUBRCALL) (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING)) (INITRESOURCES UNIXSTRING) (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV UNIX-GETPARM) (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD) (PROPS (LLSUBRS FILETYPE)))) (DECLARE%: EVAL@COMPILE DONTCOPY (ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS) ) (* ;;; "MISCN Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \MISCN-TABLE-LIST ((USER-SUBR 0 \USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL) (LCFetchMethod 7 LCFetchMethod NIL) (LCFetchMethodOrHelp 8 NIL NIL) (LCFindVarIndex 9 NIL NIL) (LCGetIVValue 10 NIL NIL) (LCPutIVValue 11 NIL NIL))) (* "END EXPORTED DEFINITIONS") (DEFMACRO MISCN (NAME &REST ARGS) [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X) (GENSYM] `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES ((OPCODES MISCN ,(MISCN-NUMBER NAME) ,(LENGTH ARGS)) ,@ARGNAMES] ,@ARGS]) (DEFOPTIMIZER MISCN (NAME &REST ARGS) `((OPCODES MISCN ,(MISCN-NUMBER NAME) ,(LENGTH ARGS)) ,@ARGS)) (DEFINEQ (MISCN-NUMBER (LAMBDA (NAME) (* ; "Edited 7-Nov-88 15:21 by krivacic") (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST) (ERROR NAME " not a MISCN index")))) ) (\MISCN.UFN (LAMBDA (ALPHA-BETA) (* ; "Edited 8-Jun-89 16:57 by jds") (* ;; "The UFN for the MISCN opcode.") (DECLARE (GLOBALVARS \MISCN-TABLE)) (* ;; "Get the misc index & number of args from the code stream") (LET ((INDEX (LRSH ALPHA-BETA 8)) (ARG-COUNT (LOGAND ALPHA-BETA 255))) (* ;; "compute the position of the real IVARS on the stack. Create a pointer to these args and pass it to the Handler routine.") (COND ((NOT (AND (BOUNDP (QUOTE \MISCN-TABLE)) \MISCN-TABLE)) (\INIT-MISCN-TABLE))) (LET* ((CALLER (\MYALINK)) (MY-BF (\GET-MY-BF)) (MY-IVAR (fetch (BF IVAR) of MY-BF)) (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1))) (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR)) (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1)))) (COND ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY) (* ;; "This UFN can return Multiple values, so we need to preserve them.") (CL:UNWIND-PROTECT (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))) (T (* ;; "He said no MVs are possible, so don't even TRY to preserve them. This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!") (PROG1 (.UNWIND.PROTECT. (FUNCTION (LAMBDA NIL (replace (BF IVAR) of MY-BF with RESULT-IVAR))) (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR)) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))))))) ) (\UNDEFINED-MISCN-UFN (LAMBDA (INDEX ARG-COUNT ARG-PTR) (* ; "Edited 3-Nov-88 15:56 by krivacic") (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T) (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR))) ) (MISCN-COLLECT (LAMBDA (ARG-COUNT ARG-PTR) (* ; "Edited 3-Nov-88 11:52 by krivacic") (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1)))) ) (\GET-MY-BF (LAMBDA NIL (* ; "Edited 3-Nov-88 11:08 by krivacic") (* ;; "Returns the stack index of the caller's BF.") (- (\MYALINK) 2)) ) (\INIT-MISCN-TABLE (LAMBDA NIL (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE)) (* ; "Edited 7-Mar-89 09:43 by jds") (LET ((OP-NUMBER 36) (OP-LENGTH 3) BASE) (SETQ \MISCN-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-MISCN-UFN) 0)) (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE)) (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY) (CADDR MISCN-ENTRY)) (REPLACE (MISCN-UFN-ENTRY MISCN-MVS) OF (\ADDBASE2 BASE (FETCH (MISCN-UFN-SPEC INDEX) OF MISCN-ENTRY)) WITH (FETCH (MISCN-UFN-SPEC MVS) OF MISCN-ENTRY))) (SETQ \MISCN-TABLE BASE))) ) ) (PUTPROPS MISCN ARGNAMES (NAME &REST ARGS)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD MISCN-UFN-SPEC ( (* ;;  "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.") NAME (* ;  "Name of the MISCN, for the MISCN macro's use.") INDEX (* ; "Sub-opcode index.") UFN-NAME (* ; "Name of the UFN") MVS (* ;  "T if the UFN can returnmultiple values. If this is NIL, MVs WILL NOT BE PRESERVED.") )) (BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG) (NIL BITS 3) (MISCN-UFN POINTER))) ) ) (* ;;; " USER-SUBR Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (* "END EXPORTED DEFINITIONS") (DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS) `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME) ,@ARGS)) (CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN) (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ;; "Make Sure \USER-SUBR-TABLE is made") (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (* ;; "See if the Name is already defined") [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST) (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME) (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)) '\UNDEFINED-USER-SUBR-UFN) (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR] (* ;; "See if the UFN is already defined") [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) '\UNDEFINED-USER-SUBR-UFN) (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND)) (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX) (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR] (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN)) \USER-SUBR-LIST) (\INIT-USER-SUBR-TABLE)) (DEFINEQ (\USER-SUBR-UFN (LAMBDA (INDEX ARG-COUNT ARG-PTR) (DECLARE (GLOBALVARS \USER-SUBR-TABLE)) (* ; "Edited 4-Nov-88 18:43 by krivacic") (IF (NOT (AND (BOUNDP (QUOTE \USER-SUBR-TABLE)) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1))) (* ;; "User SUBR ufn. Index on the User subr indexes") (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) USER-SUBR-INDEX (- ARG-COUNT 1) (\ADDBASE ARG-PTR 2)))) ) (\INIT-USER-SUBR-TABLE (LAMBDA NIL (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ; "Edited 4-Nov-88 18:58 by krivacic") (SETQ \USER-SUBR-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-USER-SUBR-UFN) 0)) (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY) (CADDR SUBR-ENTRY)))) ) (\UNDEFINED-USER-SUBR-UFN (LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR) (* ; "Edited 7-Nov-88 14:33 by krivacic") (* ;; "User SUBR ufn. Index on the User subr indexes") (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR))) ) (USER-SUBR-NUMBER (LAMBDA (NAME) (* ; "Edited 4-Nov-88 18:42 by krivacic") (CADR (OR (ASSOC NAME \USER-SUBR-LIST) (ERROR NAME " not a USER-SUBR index")))) ) (EQ-TO-CAR (LAMBDA (ITEM LIST) (EQ ITEM (CAR LIST)))) (EQ-TO-CADR (LAMBDA (ITEM LIST) (EQ ITEM (CADR LIST)))) ) (PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS)) (* ;;; "SUBRCALL Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) (WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) (CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) (UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) (UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) (ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) (DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) (BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) (KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) (DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) (COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107) (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) (DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119) (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) (GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) (COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (C-SlowBltChar 140) (UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) (CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) (CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) (DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209))) (* "END EXPORTED DEFINITIONS") (DEFMACRO SUBRCALL (NAME &REST ARGS) [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X) (GENSYM] `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES ((OPCODES SUBRCALL ,(SUBRNUMBER NAME) ,(LENGTH ARGS)) ,@ARGNAMES] ,@ARGS]) (DEFOPTIMIZER SUBRCALL (NAME &REST ARGS) `((OPCODES SUBRCALL ,(SUBRNUMBER NAME) ,(LENGTH ARGS)) ,@ARGS)) (DEFINEQ (SUBRNUMBER [LAMBDA (NAME) (* ; "Edited 5-Feb-92 16:49 by jds") (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.") (LET (NUMBER) (COND ((FIXP NAME) (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME) NAME) ((CADR (ASSOC NAME \INITSUBRS))) ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL] (CL:WARN "SUBR name ~s is in wrong package. Using ~d as subr number." NAME NUMBER)) (T (ERROR NAME " not a SUBR"]) ) (* ;; "use this to make a subrs.h file for Maiko ") (DEFINEQ (WRITECALLSUBRS (LAMBDA NIL (* ; "Edited 6-Nov-89 15:39 by jds") (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (CL:FORMAT T "/* This file written from LLSUBRS on ~A */~&" (DATE)) (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&") (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to */~&") (CL:FORMAT T "/* generate a new version. */~&") (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* MISCN opcodes */~&") (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&") (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))))) ) (FIX-SUBR-NAME (LAMBDA (NAME) (* ; "Edited 13-Feb-89 16:17 by jds") (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:") (* ;; "Converting all -'s to _'s") (* ;; "Converting all .'s to _'s") (* ;; "Removing all \'s.") (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.") (CONCATCODES (DREMOVE (CHARCODE \) (SUBST (CHARCODE _) (CHARCODE %.) (SUBST (CHARCODE _) (CHARCODE -) (CHCON NAME)))))) ) ) (PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS)) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512] ) ) (/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL) (DEFINEQ (\MOREVMEMFILE (LAMBDA (FILEPAGE) (* ; "Edited 27-Apr-88 13:36 by MASINTER") (SUBRCALL MOREVMEMFILE FILEPAGE))) (\WRITEMAP (LAMBDA (VP RP FLAGS) (* ; "Edited 27-Apr-88 13:37 by MASINTER") (SUBRCALL WRITEMAP VP RP FLAGS))) (\COPYSYS0SUBR (LAMBDA (FID) (* ; "Edited 20-Apr-88 12:36 by MASINTER") (SUBRCALL COPYSYS0SUBR FID))) (\PUPLEVEL1STATE (LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL PUPLEVEL1STATE FLG))) (SHOWDISPLAY (LAMBDA (BASE RASTERWIDTH) (* ; "Edited 27-Apr-88 13:40 by MASINTER") (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ") (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH)) ) (SETSCREENCOLOR (LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL SETSCREENCOLOR FLG))) (\WRITERAWPBI (LAMBDA (PBI) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL WRITERAWPBI PBI))) (\READRAWPBI (LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL READRAWPBI))) (RAID (LAMBDA (MESS1 MESS2 FLG) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL RAID MESS1 MESS2 FLG))) (\LISPFINISH (LAMBDA (DUMMY) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL LISPFINISH DUMMY))) (\GETPACKETBUFFER (LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GETPACKETBUFFER))) (\GATHERSTATS (LAMBDA (FID) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GATHERSTATS FID))) (\DSPRATE (LAMBDA (AC0 AC1 AC2) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPRATE AC0 AC1 AC2)) ) (DSPBOUT (LAMBDA (CHARCODE) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPBOUT CHARCODE))) (DISKPARTITION (LAMBDA NIL (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (SUBRCALL DISKPARTITION)) ((DANDELION DOVE) (\DFSCurrentVolume)) NIL)) ) (\CHECKBCPLPASSWORD (LAMBDA (USER PASSWORD) (* ; "Edited 14-Jun-88 13:33 by drc:") (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD)) ) (SUSPEND-LISP (LAMBDA NIL (* ; "Edited 20-Jun-88 15:24 by greep") (if (EQ (MACHINETYPE) (QUOTE MAIKO)) then (SUBRCALL SUSPEND-LISP) T else NIL)) ) (UNIX-USERNAME (LAMBDA NIL (* ; "Edited 1-Aug-88 23:22 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-FULLNAME (LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-GETENV [LAMBDA (NAME) (* ; "Edited 21-Feb-2021 21:09 by larry") (WITH-RESOURCES UNIXSTRING (LET ((X UNIXSTRING)) (if (SUBRCALL UNIX-GETENV (MKSTRING NAME) X) then (CONCAT (SUBSTRING X 1 (for I from 1 do (if (FMEMB (NTHCHARCODE X I) '(0 NIL)) then (RETURN (SUB1 I]) (UNIX-GETPARM (LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator. Usually gets info about configuration of the machine we're running on.") (* ;; "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") (if (EQ \MACHINETYPE \MAIKO) then (LET (LEN) (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) UNIXSTRING)) (COND ((SMALLP LEN) (if (> LEN 0) then (CONCAT (SUBSTRING UNIXSTRING 1 LEN)))) (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING)))))))))) ) ) (PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH)) (PUTPROPS SETSCREENCOLOR ARGNAMES (FLG)) (PUTPROPS \WRITERAWPBI ARGNAMES (PBI)) (PUTPROPS \READRAWPBI ARGNAMES NIL) (PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG)) (PUTPROPS \LISPFINISH ARGNAMES (DUMMY)) (PUTPROPS \GETPACKETBUFFER ARGNAMES NIL) (PUTPROPS \GATHERSTATS ARGNAMES (FID)) (PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2)) (PUTPROPS DSPBOUT ARGNAMES (CHARCODE)) (PUTPROPS DISKPARTITION ARGNAMES NIL) (PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR)) (PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE) (PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3635 6424 (MISCN-NUMBER 3645 . 3800) (\MISCN.UFN 3802 . 5257) (\UNDEFINED-MISCN-UFN 5259 . 5527) (MISCN-COLLECT 5529 . 5696) (\GET-MY-BF 5698 . 5841) (\INIT-MISCN-TABLE 5843 . 6422)) ( 7808 9097 (ADD-USER-SUBR 7808 . 9097)) (9098 10463 (\USER-SUBR-UFN 9108 . 9548) (\INIT-USER-SUBR-TABLE 9550 . 9877) (\UNDEFINED-USER-SUBR-UFN 9879 . 10178) (USER-SUBR-NUMBER 10180 . 10341) (EQ-TO-CAR 10343 . 10400) (EQ-TO-CADR 10402 . 10461)) (14726 15375 (SUBRNUMBER 14736 . 15373)) (15436 16843 ( WRITECALLSUBRS 15446 . 16346) (FIX-SUBR-NAME 16348 . 16841)) (17052 20999 (\MOREVMEMFILE 17062 . 17177 ) (\WRITEMAP 17179 . 17292) (\COPYSYS0SUBR 17294 . 17399) (\PUPLEVEL1STATE 17401 . 17510) (SHOWDISPLAY 17512 . 17750) (SETSCREENCOLOR 17752 . 17860) (\WRITERAWPBI 17862 . 17965) (\READRAWPBI 17967 . 18062 ) (RAID 18064 . 18176) (\LISPFINISH 18178 . 18283) (\GETPACKETBUFFER 18285 . 18390) (\GATHERSTATS 18392 . 18495) (\DSPRATE 18497 . 18652) (DSPBOUT 18654 . 18758) (DISKPARTITION 18760 . 18947) ( \CHECKBCPLPASSWORD 18949 . 19081) (SUSPEND-LISP 19083 . 19233) (UNIX-USERNAME 19235 . 19485) ( UNIX-FULLNAME 19487 . 19738) (UNIX-GETENV 19740 . 20337) (UNIX-GETPARM 20339 . 20997))))) STOP \ No newline at end of file diff --git a/sources/LLSUBRS.LCOM b/sources/LLSUBRS.LCOM index 7330734d..f4889509 100644 Binary files a/sources/LLSUBRS.LCOM and b/sources/LLSUBRS.LCOM differ diff --git a/sources/LOADUP-GREET b/sources/LOADUP-GREET deleted file mode 100644 index 6a452c18..00000000 --- a/sources/LOADUP-GREET +++ /dev/null @@ -1 +0,0 @@ -() diff --git a/sources/YREM.CM b/sources/YREM.CM new file mode 100644 index 00000000..5536f3d0 --- /dev/null +++ b/sources/YREM.CM @@ -0,0 +1,6 @@ +" +(PROGN(LOAD(CONCAT (QUOTE {DSK}) (UNIX-GETENV (QUOTE MEDLEYDIR)) (QUOTE /sources/LOADUP.LISP)))(HARDRESET)) +SHH(PROGN(IL:ENDLOADUP)(IL:MAKESYS (IL:CONCAT (QUOTE {DSK})(IL:UNIX-GETENV(QUOTE MEDLEYDIR))(IL:L-CASE (QUOTE /loadups/lisp.sysout))))) +(IL:LOGOUT T) + +"