From 311e4f049c9f76c073c5ddf24dc09fabb07b94fe Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 20:55:52 -0800 Subject: [PATCH 01/10] ADIR: Device colons before directories --- sources/ADIR | 435 +++++++++++++++++++++++----------------------- sources/ADIR.LCOM | Bin 24216 -> 24318 bytes 2 files changed, 217 insertions(+), 218 deletions(-) diff --git a/sources/ADIR b/sources/ADIR index 7fe32da3..c2f27f11 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,10 +1,11 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "13-Jun-2021 11:25:58" {DSK}kaplan>Local>medley3.5>git-medley>sources>ADIR.;9 65815 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS OPENSTREAM) +(FILECREATED " 5-Jan-2022 11:06:37" {DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;10 65596 - previous date%: "21-Mar-2021 21:59:07" -{DSK}kaplan>Local>medley3.5>git-medley>sources>ADIR.;8) + :CHANGES-TO (FNS UNPACKFILENAME.STRING) + + :PREVIOUS-DATE "13-Jun-2021 11:25:58" +{DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;9) (* ; " @@ -14,14 +15,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (PRETTYCOMPRINT ADIRCOMS) (RPAQQ ADIRCOMS - [[COMS (* ; "user-level i/o routines") + [[COMS (* ; "user-level i/o routines") (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP RENAMEFILE SIMPLE.FINDFILE VMEMSIZE \COPYSYS \FLUSHVM \LOGOUT0) (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.") + (* ;; "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 @@ -30,8 +31,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo PACKFILENAME.ASSEMBLE UNPACKFILE1)) (VARS \FILENAME.SYNTAX) (GLOBALVARS \FILENAME.SYNTAX)) - (COMS (* ; - "saving and restoring system state") + (COMS (* ; "saving and restoring system state") (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT) (ADDVARS (AROUNDEXITFNS)) (INITVARS (HERALDSTRING "") @@ -274,7 +274,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (DECLARE%: DONTEVAL@LOAD DOCOPY -(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") +(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP) @@ -286,10 +286,13 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T]) (UNPACKFILENAME.STRING - [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm") + [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 5-Jan-2022 11:03 by rmk") + (* ; "Edited 30-Mar-90 22:37 by nm") (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") +(* ;;; "rmk: devices must come before directories.") + (PROG ((POS 1) (LEN (NCHARS FILE)) TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) @@ -302,7 +305,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo ((TYPEP FILE 'PATHNAME) (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG))) [(STREAMP FILE) (* ; - "For streams, use full name. If anonymous, fake it") + "For streams, use full name. If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (COND (ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME) @@ -316,12 +319,12 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo FILE 2) 0)))) (%[ (* ; - "some Xerox and Arpanet systems use '[' for host") + "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") + "this is the 'proposed standard' for Xerox servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) @@ -329,21 +332,28 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (UNPACKFILE1 'HOST 2 TEM) [COND ((EQ TEM -1) (* ; - "Started with the host field delimiter, but there was no corresponding terminating delimiter .") + "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.") + "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] + then (* ; + "Use actual host to determine os type") + (SETQ OSTYPE (GETHOSTINFO (CAR VAL) + 'OSTYPE] (SETQ HOSTP T))) + + (* ;; "rmk: if there is a colon before the next < or /, then we must be looking at a device. A device appears to end after the last colon, i.e., a device name can have a colon inside it.") + (COND - ((SETQ TEM (LASTCHPOS (CHARCODE %:) - FILE POS)) (* ; - "all device returned have DEVICE.END on it so that NIL: will work") + ((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /)) + FILE POS)) + (EQ (CHARCODE %:) + (NTHCHARCODE FILE TEM)) + (SETQ TEM (LASTCHPOS (CHARCODE %:) + FILE TEM))) (* ; + "all device returned have DEVICE.END on it so that NIL: will work") (UNPACKFILE1 'DEVICE POS (if CLFLG then (SUB1 TEM) else TEM)) @@ -356,7 +366,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (NIL (* ; "just host, return") (RETURN (DREVERSE VAL))) ((/ <) (* ; - "Started with the initial directory delimiter.") + "Started with the initial directory delimiter.") (ADD1 POS)) POS)) END) @@ -364,7 +374,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo ((/ >) [COND ((EQ START POS) (* ; - "Didn't start with a directory delimiter,") + "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)) @@ -372,13 +382,13 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (SETQ TYPE 'RELATIVEDIRECTORY] (COND ((EQ LEN POS) (* ; - "Only the initial directory is specified (i.e. %"{DSK}/%").") + "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.") + "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)) @@ -387,24 +397,24 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (T (COND ((EQ LEN POS) (* ; - "Only the initial directory is specified (i.e. %"{DSK}<%").") + "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") + "unix and the 'xerox standard' use / for delimiter") (* ; - "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.") + "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 >>") + "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") (* ; - "In the case of the {DSK} /)) FILE (ADD1 POS))) @@ -415,20 +425,19 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (if TEM then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS) - (SUB1 TEM)) - (SETQ POS (ADD1 TEM)) + (SUB1 TEM)) + (SETQ POS (ADD1 TEM)) else + (* ;; "{DSK}/foo: the directory is /, the name is foo") - (* ;; "{DSK}/foo: the directory is /, the name is foo") - - (UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS) - (SETQ POS (ADD1 POS))) + (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.") + " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.") [COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case.") @@ -448,9 +457,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (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)) + then (* ; + "There wasn't a host field in the name, so we have no clue") + (SETQ OSTYPE NIL)) NAMELP @@ -458,61 +467,61 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (SELCHARQ CODE (%. (* ; - "Note position for later--we only want to deal with the last set of dots") + "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)") + 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) + 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") + "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) + (! (* ; + "! 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") + 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)) + 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 + (SUB1 SECONDDOT)) + (SETQ BEYONDEXT T) + SECONDDOT else FIRSTDOT))) (SETQ BEYONDNAME T) (SETQ FIRSTDOT NIL)) @@ -524,15 +533,15 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo ((AND (EQ BEYONDEXT (CHARCODE ";")) (\UPF.TEMPFILEP FILE POS))) (T (* ; - "Everything after the semi was version") + "Everything after the semi was version") 'VERSION)) POS (SUB1 TEM)) (if (NULL CODE) - then (* ; "End of string") - (RETURN (DREVERSE VAL))) + then (* ; "End of string") + (RETURN (DREVERSE VAL))) (SETQ BEYONDEXT CODE) (* ; - "Note the character that terminated the name/ext") + "Note the character that terminated the name/ext") (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) @@ -623,80 +632,74 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (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 >)) + 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))) + (%' (\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 >)) + (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) - )) + (%' (\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]) + (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 + (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 ""]) + (T (OR NEWDIR ""))) + (CONS NAM VAL] + ((EQMEMB NAM ONEFIELDFLG) + (RETURN (COND + (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) + (T (OR NEWDIR ""]) (PUTPROPS PACKFILENAME.ASSEMBLE MACRO [NIL @@ -705,11 +708,11 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo 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)) + VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((<= I N) - (* ;; "Grab the next field-name / value pair and fold it into the filename:") + (* ;; "Grab the next field-name / value pair and fold it into the filename:") (COND ((LISTP (SETQ VAR (ARG N I))) @@ -725,9 +728,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (\ILLEGAL.ARG VAL)) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND - ((LISTP VAL) - (PACKFILENAME.STRING VAL)) - (T VAL)) + ((LISTP VAL) + (PACKFILENAME.STRING VAL)) + (T VAL)) NIL 'OK) [FUNCTION (LAMBDA (X) @@ -781,52 +784,49 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo ((PATHNAME DIRECTORY) [COND (VAL - (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL - 'RETURN)) + (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) + (HOST [COND + ((NOT HOST) + (SETQ HOST (OR (CADR X) + BLIP]) + (DEVICE [COND + ((NOT DEVICE) + (SETQ DEVICE (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 + (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") + (* ;; "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 RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY + (OR (CADR X) + BLIP)))) + (DIRECTORY [OR DIRECTORY (COND + (RELATIVEDIRECTORY + (SETQ DIRECTORY BLIP)) + (T (SETQ DIRECTORY (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))) + 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))) + (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") + (* ;; "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)))) @@ -868,9 +868,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo [COND (DIRECTORY (COND [[OR (STREQUAL DIRECTORY "<") - (AND (SETQ TEMP (LASTCHPOS - (CHARCODE (> /)) - DIRECTORY 1)) + (AND (SETQ TEMP (LASTCHPOS (CHARCODE + (> /)) + DIRECTORY 1)) (EQ TEMP (NCHARS DIRECTORY] (COND ((EQMEMB (NTHCHARCODE DIRECTORY 1) @@ -913,20 +913,19 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (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 +(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) + ""]) ) ) @@ -1158,14 +1157,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (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 (2733 13858 (DELFILE 2743 . 2904) (FULLNAME 2906 . 3273) (INFILE 3275 . 3423) (INFILEP -3425 . 3560) (IOFILE 3562 . 3702) (OPENFILE 3704 . 4104) (OPENSTREAM 4106 . 8446) (OUTFILE 8448 . 8599 -) (OUTFILEP 8601 . 8737) (RENAMEFILE 8739 . 9045) (SIMPLE.FINDFILE 9047 . 9457) (VMEMSIZE 9459 . 9626) - (\COPYSYS 9628 . 12577) (\FLUSHVM 12579 . 13651) (\LOGOUT0 13653 . 13856)) (14230 33821 ( -UNPACKFILENAME 14240 . 14426) (UNPACKFILENAME.STRING 14428 . 30700) (LASTCHPOS 30702 . 31396) ( -\UPF.NEXTPOS 31398 . 32043) (\UPF.TEMPFILEP 32045 . 32622) (FILENAMEFIELD 32624 . 33109) (PACKFILENAME - 33111 . 33454) (PACKFILENAME.STRING 33456 . 33819)) (56262 63442 (LOGOUT 56272 . 57189) (MAKESYS -57191 . 58820) (SYSOUT 58822 . 60374) (SAVEVM 60376 . 61176) (HERALD 61178 . 61338) (INTERPRET.REM.CM -61340 . 63065) (\USEREVENT 63067 . 63440)) (63624 65351 (USERNAME 63634 . 64590) (SETUSERNAME 64592 . -65349))))) + (FILEMAP (NIL (2686 13811 (DELFILE 2696 . 2857) (FULLNAME 2859 . 3226) (INFILE 3228 . 3376) (INFILEP +3378 . 3513) (IOFILE 3515 . 3655) (OPENFILE 3657 . 4057) (OPENSTREAM 4059 . 8399) (OUTFILE 8401 . 8552 +) (OUTFILEP 8554 . 8690) (RENAMEFILE 8692 . 8998) (SIMPLE.FINDFILE 9000 . 9410) (VMEMSIZE 9412 . 9579) + (\COPYSYS 9581 . 12530) (\FLUSHVM 12532 . 13604) (\LOGOUT0 13606 . 13809)) (14183 34403 ( +UNPACKFILENAME 14193 . 14379) (UNPACKFILENAME.STRING 14381 . 31282) (LASTCHPOS 31284 . 31978) ( +\UPF.NEXTPOS 31980 . 32625) (\UPF.TEMPFILEP 32627 . 33204) (FILENAMEFIELD 33206 . 33691) (PACKFILENAME + 33693 . 34036) (PACKFILENAME.STRING 34038 . 34401)) (56043 63223 (LOGOUT 56053 . 56970) (MAKESYS +56972 . 58601) (SYSOUT 58603 . 60155) (SAVEVM 60157 . 60957) (HERALD 60959 . 61119) (INTERPRET.REM.CM +61121 . 62846) (\USEREVENT 62848 . 63221)) (63405 65132 (USERNAME 63415 . 64371) (SETUSERNAME 64373 . +65130))))) STOP diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index ddc6503091ed76eddd32aca532330184c2d5596a..370a9cb699b04f4b8227d8af234c12688a2e3515 100644 GIT binary patch delta 3693 zcma)9OOG2x5XL!ykyd%J77s_v?t7 zF5kG0bQ zMYn&_n_S8ko#j-thm!@2IM_Q9-Pt_5I-0H)odH~3%f_3JAHBcPKKpd<%=fP~p09t{ zYc>8@|F$=2e6xOK|EI>E>tFWYd-wiJ_`7iOs{dSn^4W#UP5M~ z^Xs`y#AJDbr|13YAQMI@D;BGZi{*SYxr8Mfzw9lir^0aR!~oW0a|FS#)1f3=4kVQl zpRZ=a<7IX_^MRTPLoN;F2`?{Jd3iNabeT+x%PK2mLiOEJyX``!X<=U}sMACRXAs;m zLZ?zj{^mN-@&zde^G~l7PHQJs?Xl${kr_Rjh0{kIm7V<9KN0 zc65{pkZhDrz&sRLm#@sX@J>u zkY|Du8#~BuhidGo#@WLRhr@ufwK03y!rSOovx6!dE&|ot797@_oq9vT;Rr-l&PE`z zGF)(vi}F;V$N;B8k%2&n2YlH=#i+R@ga}Va3nmlOf{9{UunbsGaF0?K=NGPwbtnbd z>ex_X;|!&Q<5$Vqn9k%>j5Jxl!2$Qkz~KlsGDyrYWyu&@z(%O#b;^yxh4Y7)OM}#ULNzhLElGHmY(!03L zhZLOJUhoyDyqh1%PSHtB909kx<{gqca4!VgCZ3`Pxj}!b2xM0cTI*>2m#R=l8tXHjKvTTm5J{ zL9>UyILjvGQX*u%Q%nKiQg}d`q9u|$P?Nso6lxM(to$XBK7LOpFn>9nE$|fDGLmRC z^i2eun`h(Ra&$EtjOJN?Ih|j_Hf|1=s64|_HXaB?&<6^^p&u^7C0;CLC143oq$&mT z%_9=H)W^(dMBx&JI$UB@s+R_{(u-!BqzGjoh7$T8Viz|}zLwMIX9LWEec)u|_9sXl z$N+ajoSq}k6%;)5tJv0VI@ildPccu3d|n}FW!OI-pE?XD8TLyPyq@& zNTVxmZ_#L0B{+gG7J8FN=>i+VP*F>=&P^RFk|>42J1G*Rx-^6|L3aA*9ikD4Ta*sJ qZNYxe5={R7Wz3t!hcsR?i75Oy!f;b?_hrTq*TVl~PamnnkNyRBj%85* delta 3615 zcmZ`*OOG2x5SD>c&_;P9E>Ytou&Zd7uIk5hTagmS9+FGk3^zly4^r&qK$~fM@9xuO^h_P&J2G4R-Fm+= z+;YcP-}wGy>#xPHr`oNb7k``@w?123KK)bcc=7w`_uhKgxv_iv_L*PK7MjF(zT4aF zPJ5GnE{u|1%noh>iQ)JoVc5H{?9L~9SY%T4r}^!CI)fzZERj?ul9X0_ey~5-ndf`^ zA#eM_kl|RKaP#b-SeceCF(z$ktnxw{-Po2a>xK5V^lv4oy|K|51lOFlUog?6O= zBbCAZy<26_+Ge&1T3eeX`r0bph*Eib<&4SJWR0?^vi3#lj@B~GhgNz`M{$glX6I6y zAuVx6HF>$V0W>R#Ya!`6;9Ko1H^_-ASGv<__s;gsF0!qq)S^2YO?s>7ly`FR`h#~0 zqXf3{PY${xp*+wS2Qtm@&vCw$%cufMIUKFU!sxI_Y6Lhc z)QC!US13!X#Hc%)_jdOuz*K@kE8y5?zWKMIn5wGf0DT+|ND^a~7lNHi1LSOtXl#9= zBiLqfLfNX6yKE3`a;sTGm9<|c>PFRWSgm%N4FsHk$V&SJL{@A7;`xHh=2W4`3_MmS zGJK8kU|km}lT$Tpl(ZQpPHDl?rLgBQKONop(+~k5!yt&R4y$t zQns#YQi_|dNnxn0XiEiySJ5Smu@JL{m{Q&miYAqiYvoJf5s=uBA;h{KJUCS!KS0*j z>%*-z9mi<~vbDAKYb3ScUJSN1ONv^?c&ebbKw*Wn@i9Nmdecv;S%YDSWjT!~YhcyE zUPOX`e-pHV+L=mEp`R}^xj4D=Td}ce7-KIC^5JBR(TsTVPv>|5Etd`{>F#016Px6K zbi9-(-bhV`mQt!o%&78DV@j<49K4%P_GcK%8#+Ug3gUZ|l+&bIBLaSz>&=fWi0^SIg zw>IDz5>bodzM@$X%DsIJ<|OFYC?RLT9ULgHooIiEABR4PivF#{PK(Pt?s}mbj`vd z$B{Q|3oV;d15Va@p$vmJ3_K#84Z%tRhHz3k3_O?(cJK{#RemulYeN!AuNHWlg+-MR zL4`vO>r;n5zglbv3@fA;_mBlqVBDsTkhffZaLyiLk4rgkIA zxWCC2+G>K1$Me53>LW-q)OheKLpCC}EZRZXwqSo?i3TZfv$D&iIItpM6Ij;X+E~q* K<3H8KtN#LeSy|%% From 7966704f1ed0c1037cbac58a701dbe2e739687d3 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 20:57:56 -0800 Subject: [PATCH 02/10] PRETTY: DEFMACROS in filemap for PF, CLSTREAMS remade to test --- sources/CLSTREAMS | 99 +++++++++++++++++++++-------------------- sources/CLSTREAMS.LCOM | Bin 30991 -> 30989 bytes sources/PRETTY | 65 +++++++++++++++------------ sources/PRETTY.LCOM | Bin 30365 -> 30453 bytes 4 files changed, 87 insertions(+), 77 deletions(-) diff --git a/sources/CLSTREAMS b/sources/CLSTREAMS index 9e8c01b6..046ea232 100644 --- a/sources/CLSTREAMS +++ b/sources/CLSTREAMS @@ -1,10 +1,10 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "27-Nov-2021 13:30:46"  -|{DSK}kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3| 53235 +(FILECREATED "20-Jan-2022 09:16:52"  +|{DSK}kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;4| 53233 - |previous| |date:| " 3-Apr-91 15:11:53" -|{DSK}kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;2|) + :PREVIOUS-DATE "27-Nov-2021 13:30:46" +|{DSK}kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3|) ; Copyright (c) 1985-1988, 1990-1991 by Venue & Xerox Corporation. @@ -955,48 +955,51 @@ (PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE) (PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991)) (DECLARE\: DONTCOPY - (FILEMAP (NIL (5167 14142 (OPEN 5167 . 14142)) (14144 15070 (CL:CLOSE 14144 . 15070)) (15072 15150 ( -CL:STREAM-EXTERNAL-FORMAT 15072 . 15150)) (15152 15219 (CL:STREAM-ELEMENT-TYPE 15152 . 15219)) (15221 -15455 (CL:INPUT-STREAM-P 15221 . 15455)) (15457 15693 (CL:OUTPUT-STREAM-P 15457 . 15693)) (15695 15832 - (XCL:OPEN-STREAM-P 15695 . 15832)) (15834 15901 (FILE-STREAM-POSITION 15834 . 15901)) (15953 17296 ( -CL:MAKE-SYNONYM-STREAM 15953 . 17296)) (17298 17387 (XCL:SYNONYM-STREAM-P 17298 . 17387)) (17389 17527 - (XCL:SYNONYM-STREAM-SYMBOL 17389 . 17527)) (17529 17807 (XCL:FOLLOW-SYNONYM-STREAMS 17529 . 17807)) ( -17809 18568 (CL:MAKE-BROADCAST-STREAM 17809 . 18568)) (18570 18713 (XCL:BROADCAST-STREAM-P 18570 . -18713)) (18715 18930 (XCL:BROADCAST-STREAM-STREAMS 18715 . 18930)) (18932 19617 ( -CL:MAKE-CONCATENATED-STREAM 18932 . 19617)) (19619 19718 (XCL:CONCATENATED-STREAM-P 19619 . 19718)) ( -19720 19933 (XCL:CONCATENATED-STREAM-STREAMS 19720 . 19933)) (19935 21519 (CL:MAKE-TWO-WAY-STREAM -19935 . 21519)) (21521 21658 (XCL:TWO-WAY-STREAM-P 21521 . 21658)) (21660 21805 ( -XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21660 . 21805)) (21807 21951 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21807 - . 21951)) (21953 23503 (CL:MAKE-ECHO-STREAM 21953 . 23503)) (23505 23634 (XCL:ECHO-STREAM-P 23505 . -23634)) (23636 23774 (XCL:ECHO-STREAM-INPUT-STREAM 23636 . 23774)) (23776 23915 ( -XCL:ECHO-STREAM-OUTPUT-STREAM 23776 . 23915)) (23917 24644 (CL:MAKE-STRING-INPUT-STREAM 23917 . 24644) -) (24646 25139 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24646 . 25139)) (25141 25301 ( -%MAKE-INITIAL-STRING-STREAM-CONTENTS 25141 . 25301)) (28348 29874 (MAKE-FILL-POINTER-OUTPUT-STREAM -28348 . 29874)) (29876 30597 (CL:GET-OUTPUT-STREAM-STRING 29876 . 30597)) (30599 31078 ( -\\STRING-STREAM-OUTCHARFN 30599 . 31078)) (31080 32935 (\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31080 . -32935)) (32964 33046 (%NEW-FILE 32964 . 33046)) (33048 33193 (PREDICT-NAME 33048 . 33193)) (33434 -34622 (%BROADCAST-STREAM-DEVICE-BOUT 33444 . 33667) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33669 . 34120) - (%BROADCAST-STREAM-DEVICE-CLOSEFILE 34122 . 34361) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34363 . -34620)) (34624 34951 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34624 . 34951)) (34952 37011 ( -%CONCATENATED-STREAM-DEVICE-BIN 34962 . 35367) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35369 . 35682) ( -%CONCATENATED-STREAM-DEVICE-EOFP 35684 . 36048) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36050 . 36525) ( -%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36527 . 37009)) (37013 37344 ( -%CONCATENATED-STREAM-DEVICE-CHARSETFN 37013 . 37344)) (37345 37564 (%ECHO-STREAM-DEVICE-BIN 37355 . -37562)) (37566 37791 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37566 . 37791)) (37792 41137 ( -%SYNONYM-STREAM-DEVICE-BIN 37802 . 37990) (%SYNONYM-STREAM-DEVICE-BOUT 37992 . 38193) ( -%SYNONYM-STREAM-DEVICE-OUTCHARFN 38195 . 38902) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38904 . 39488) ( -%SYNONYM-STREAM-DEVICE-EOFP 39490 . 39681) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39683 . 39921) ( -%SYNONYM-STREAM-DEVICE-GETFILEINFO 39923 . 40160) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40162 . 40385) ( -%SYNONYM-STREAM-DEVICE-READP 40387 . 40498) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40500 . 40646) ( -%SYNONYM-STREAM-DEVICE-SETFILEINFO 40648 . 40897) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40899 . 41135)) ( -41138 45463 (%TWO-WAY-STREAM-DEVICE-BIN 41148 . 41321) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41323 . -41514) (%TWO-WAY-STREAM-DEVICE-BOUT 41516 . 41688) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41690 . 41880) - (%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41882 . 42744) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42746 . 44169) ( -%TWO-WAY-STREAM-DEVICE-EOFP 44171 . 44347) (%TWO-WAY-STREAM-DEVICE-READP 44349 . 44542) ( -%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44544 . 44680) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44682 . 44911) ( -%TWO-WAY-STREAM-DEVICE-PEEKBIN 44913 . 45126) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45128 . 45461)) (45465 - 45690 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45465 . 45690)) (45692 45811 ( -%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45692 . 45811)) (46051 46290 (%SYNONYM-STREAM-DEVICE-GET-STREAM - 46061 . 46288)) (46521 46997 (%INITIALIZE-STANDARD-STREAMS 46521 . 46997)) (46998 52961 ( -%INITIALIZE-CLSTREAM-TYPES 47008 . 52959))))) + (FILEMAP (NIL (5165 14140 (OPEN 5165 . 14140)) (14142 15068 (CL:CLOSE 14142 . 15068)) (15070 15148 ( +CL:STREAM-EXTERNAL-FORMAT 15070 . 15148)) (15150 15217 (CL:STREAM-ELEMENT-TYPE 15150 . 15217)) (15219 +15453 (CL:INPUT-STREAM-P 15219 . 15453)) (15455 15691 (CL:OUTPUT-STREAM-P 15455 . 15691)) (15693 15830 + (XCL:OPEN-STREAM-P 15693 . 15830)) (15832 15899 (FILE-STREAM-POSITION 15832 . 15899)) (15951 17294 ( +CL:MAKE-SYNONYM-STREAM 15951 . 17294)) (17296 17385 (XCL:SYNONYM-STREAM-P 17296 . 17385)) (17387 17525 + (XCL:SYNONYM-STREAM-SYMBOL 17387 . 17525)) (17527 17805 (XCL:FOLLOW-SYNONYM-STREAMS 17527 . 17805)) ( +17807 18566 (CL:MAKE-BROADCAST-STREAM 17807 . 18566)) (18568 18711 (XCL:BROADCAST-STREAM-P 18568 . +18711)) (18713 18928 (XCL:BROADCAST-STREAM-STREAMS 18713 . 18928)) (18930 19615 ( +CL:MAKE-CONCATENATED-STREAM 18930 . 19615)) (19617 19716 (XCL:CONCATENATED-STREAM-P 19617 . 19716)) ( +19718 19931 (XCL:CONCATENATED-STREAM-STREAMS 19718 . 19931)) (19933 21517 (CL:MAKE-TWO-WAY-STREAM +19933 . 21517)) (21519 21656 (XCL:TWO-WAY-STREAM-P 21519 . 21656)) (21658 21803 ( +XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21658 . 21803)) (21805 21949 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21805 + . 21949)) (21951 23501 (CL:MAKE-ECHO-STREAM 21951 . 23501)) (23503 23632 (XCL:ECHO-STREAM-P 23503 . +23632)) (23634 23772 (XCL:ECHO-STREAM-INPUT-STREAM 23634 . 23772)) (23774 23913 ( +XCL:ECHO-STREAM-OUTPUT-STREAM 23774 . 23913)) (23915 24642 (CL:MAKE-STRING-INPUT-STREAM 23915 . 24642) +) (24644 25137 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24644 . 25137)) (25139 25299 ( +%MAKE-INITIAL-STRING-STREAM-CONTENTS 25139 . 25299)) (25301 25731 (CL:WITH-OPEN-STREAM 25301 . 25731)) + (25733 26962 (CL:WITH-INPUT-FROM-STRING 25733 . 26962)) (26964 27466 (CL:WITH-OUTPUT-TO-STRING 26964 + . 27466)) (27468 28122 (CL:WITH-OPEN-FILE 27468 . 28122)) (28346 29872 ( +MAKE-FILL-POINTER-OUTPUT-STREAM 28346 . 29872)) (29874 30595 (CL:GET-OUTPUT-STREAM-STRING 29874 . +30595)) (30597 31076 (\\STRING-STREAM-OUTCHARFN 30597 . 31076)) (31078 32933 ( +\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31078 . 32933)) (32962 33044 (%NEW-FILE 32962 . 33044)) (33046 +33191 (PREDICT-NAME 33046 . 33191)) (33227 33378 (INTERLISP-ACCESS 33227 . 33378)) (33432 34620 ( +%BROADCAST-STREAM-DEVICE-BOUT 33442 . 33665) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33667 . 34118) ( +%BROADCAST-STREAM-DEVICE-CLOSEFILE 34120 . 34359) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34361 . 34618) +) (34622 34949 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34622 . 34949)) (34950 37009 ( +%CONCATENATED-STREAM-DEVICE-BIN 34960 . 35365) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35367 . 35680) ( +%CONCATENATED-STREAM-DEVICE-EOFP 35682 . 36046) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36048 . 36523) ( +%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36525 . 37007)) (37011 37342 ( +%CONCATENATED-STREAM-DEVICE-CHARSETFN 37011 . 37342)) (37343 37562 (%ECHO-STREAM-DEVICE-BIN 37353 . +37560)) (37564 37789 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37564 . 37789)) (37790 41135 ( +%SYNONYM-STREAM-DEVICE-BIN 37800 . 37988) (%SYNONYM-STREAM-DEVICE-BOUT 37990 . 38191) ( +%SYNONYM-STREAM-DEVICE-OUTCHARFN 38193 . 38900) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38902 . 39486) ( +%SYNONYM-STREAM-DEVICE-EOFP 39488 . 39679) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39681 . 39919) ( +%SYNONYM-STREAM-DEVICE-GETFILEINFO 39921 . 40158) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40160 . 40383) ( +%SYNONYM-STREAM-DEVICE-READP 40385 . 40496) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40498 . 40644) ( +%SYNONYM-STREAM-DEVICE-SETFILEINFO 40646 . 40895) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40897 . 41133)) ( +41136 45461 (%TWO-WAY-STREAM-DEVICE-BIN 41146 . 41319) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41321 . +41512) (%TWO-WAY-STREAM-DEVICE-BOUT 41514 . 41686) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41688 . 41878) + (%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41880 . 42742) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42744 . 44167) ( +%TWO-WAY-STREAM-DEVICE-EOFP 44169 . 44345) (%TWO-WAY-STREAM-DEVICE-READP 44347 . 44540) ( +%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44542 . 44678) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44680 . 44909) ( +%TWO-WAY-STREAM-DEVICE-PEEKBIN 44911 . 45124) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45126 . 45459)) (45463 + 45688 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45463 . 45688)) (45690 45809 ( +%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45690 . 45809)) (46049 46288 (%SYNONYM-STREAM-DEVICE-GET-STREAM + 46059 . 46286)) (46519 46995 (%INITIALIZE-STANDARD-STREAMS 46519 . 46995)) (46996 52959 ( +%INITIALIZE-CLSTREAM-TYPES 47006 . 52957))))) STOP diff --git a/sources/CLSTREAMS.LCOM b/sources/CLSTREAMS.LCOM index 6e87e8270964be7e49e7d62cc75b0edb3413594c..777ed881b9bb2b369d68a1cb79796a95446e04a6 100644 GIT binary patch delta 231 zcmeDG#Mt|ZaYB%Qfv#6#p01IBk&%LdrIn%C#H8?glNwD0B|}SujFGXGk%g6kiIM`B zlC!^WfTxeEt{ad@QBtVM%&SpQatrnGQ9#zAr>6&$OGzwAO#wY|`z1ak@>%q>=?MnD@U?__k8G^tTAH8wIfRM@Fg bR4^KE{>`ZF%4BXiS;c)HklOsjUE2@larry>medley>sources>PRETTY.;2 65400 +(FILECREATED "19-Jan-2022 20:35:18" {DSK}kaplan>Local>medley3.5>my-medley>sources>PRETTY.;23 65357 - :CHANGES-TO (FNS PRINTDATE1) + :CHANGES-TO (FNS PRINTDEF1) - :PREVIOUS-DATE "11-Sep-2021 09:14:19" {DSK}larry>medley>sources>PRETTY.;1) + :PREVIOUS-DATE "30-Nov-2021 22:18:04" +{DSK}kaplan>Local>medley3.5>my-medley>sources>PRETTY.;21) (* ; " @@ -89,7 +90,7 @@ with the terms of said license. PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS] (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; - "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES") + "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES") (FILES (IMPORT) FILEPKG)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP) @@ -418,24 +419,30 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL ) (PRINTDEF1 - [LAMBDA (EXPR FORMFLG) (* ; "Edited 16-Apr-2018 21:35 by rmk:") - (* ; "Edited 16-Apr-2018 10:14 by rmk:") - (* ; "Edited 14-Apr-88 18:21 by bvm") + [LAMBDA (EXPR FORMFLG) - (* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS") + (* ;; "Edited 19-Jan-2022 20:35 by rmk: Added DEFMACRO") - (* ;; "Used by MAKEFILE to print P, etc expressions. ") + (* ;; "Edited 16-Apr-2018 21:35 by rmk:") + + (* ;; "Edited 16-Apr-2018 10:14 by rmk:") + + (* ;; "Edited 14-Apr-88 18:21 by bvm") + + (* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS") + + (* ;; "Used by MAKEFILE to print P, etc expressions. ") (TERPRI) (LET (STARTPOS ENDPOS) - (IF (AND FORMFLG NEWFILEMAP (EQ (CAR EXPR) - 'CL:DEFUN)) + (IF [AND FORMFLG NEWFILEMAP (MEMB (CAR EXPR) + '(CL:DEFUN DEFMACRO)] THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE))) (PRINTDEF EXPR NIL FORMFLG NIL FNSLST) [IF STARTPOS THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE)) - (NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR) - (CONS STARTPOS ENDPOS] + (NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR) + (CONS STARTPOS ENDPOS] (TERPRI]) (SUPERPRINTEQ @@ -629,8 +636,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL (RPAQ? COPYRIGHTSRESERVED T) -(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT - :XCCS)) +(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT + :XCCS)) (RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -658,8 +665,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL (RPAQ? PRETTYTABFLG T) (RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY - DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN - EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) + DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD + EVAL@LOADWHEN FIRST NOTFIRST)) (RPAQ? AVERAGEVARLENGTH 4) @@ -679,8 +686,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL (RPAQ? PRETTYPRINTYPEMACROS ) -(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS - ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) +(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS + APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (RPAQ? SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE @@ -722,14 +729,14 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL (PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018 )) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5881 48457 (PRETTYDEF 5891 . 21564) (PRETTYDEFCOMS 21566 . 22248) (PRETTYDEF0 22250 . -22441) (PRETTYDEF1 22443 . 24206) (PRINTDATE 24208 . 25444) (PRINTDATE1 25446 . 27076) (PRINTFNS 27078 - . 27647) (PRETTYCOM 27649 . 33990) (PRETTYVAR 33992 . 35030) (PRETTYVAR1 35032 . 37250) (PRETTYCOM1 -37252 . 37956) (ENDFILE 37958 . 38054) (MAKEDEFLIST 38056 . 38460) (PP 38462 . 38738) (PP* 38740 . -39053) (PPT 39055 . 39374) (PRETTYPRINT 39376 . 42528) (PRETTYPRINT1 42530 . 44416) (PRETTYPRINT2 -44418 . 45734) (PRETTYPRINT3 45736 . 46691) (PRINTDEF1 46693 . 47701) (SUPERPRINTEQ 47703 . 47797) ( -SUPERPRINTGETPROP 47799 . 47943) (CHANGEFONT 47945 . 48455)) (48458 53804 (READARRAY 48468 . 49394) ( -PRINTARRAY 49396 . 51136) (READARRAY-FROM-LIST 51138 . 52243) (PRINTARRAY-TO-LIST 52245 . 53802)) ( -53931 61449 (PRINTCOPYRIGHT 53941 . 58018) (PRINTCOPYRIGHT1 58020 . 61144) (SAVECOPYRIGHT 61146 . -61447))))) + (FILEMAP (NIL (5927 48431 (PRETTYDEF 5937 . 21610) (PRETTYDEFCOMS 21612 . 22294) (PRETTYDEF0 22296 . +22487) (PRETTYDEF1 22489 . 24252) (PRINTDATE 24254 . 25490) (PRINTDATE1 25492 . 27122) (PRINTFNS 27124 + . 27693) (PRETTYCOM 27695 . 34036) (PRETTYVAR 34038 . 35076) (PRETTYVAR1 35078 . 37296) (PRETTYCOM1 +37298 . 38002) (ENDFILE 38004 . 38100) (MAKEDEFLIST 38102 . 38506) (PP 38508 . 38784) (PP* 38786 . +39099) (PPT 39101 . 39420) (PRETTYPRINT 39422 . 42574) (PRETTYPRINT1 42576 . 44462) (PRETTYPRINT2 +44464 . 45780) (PRETTYPRINT3 45782 . 46737) (PRINTDEF1 46739 . 47675) (SUPERPRINTEQ 47677 . 47771) ( +SUPERPRINTGETPROP 47773 . 47917) (CHANGEFONT 47919 . 48429)) (48432 53778 (READARRAY 48442 . 49368) ( +PRINTARRAY 49370 . 51110) (READARRAY-FROM-LIST 51112 . 52217) (PRINTARRAY-TO-LIST 52219 . 53776)) ( +53905 61423 (PRINTCOPYRIGHT 53915 . 57992) (PRINTCOPYRIGHT1 57994 . 61118) (SAVECOPYRIGHT 61120 . +61421))))) STOP diff --git a/sources/PRETTY.LCOM b/sources/PRETTY.LCOM index 04790f20f6d4f1b2218f1cce7288ede951a1e03e..0d64f3106077fe112b343acd9ac46f4f8e113192 100644 GIT binary patch delta 590 zcmb7>yH3L}6ov^b$V_Y?0XnjTNQP92)AVAYh?2MvNS%@kU06b!0ns*93kZY|uYlB< zm!QwUJ0RYnBRejLwgUrrID@V8Up_yNrH`@n)TrrY^(g78L?Z-nRu!^8@btFFiFfK?*q z0N$P7o;CVU0YC-QFpEI#!wNrOp&I!hS9v(gssODA?9}z+P<4baU_(=Rb~E9q10ez; z)$)Jl_6^Y*WY_&>Iy{qBM(@&242{L5g~jCsaaKX9ylez7>w7IJn_QsD7;ZMK$2>$V z5D=kQf-`RW+$LZa;DALFEcGaWd~q5a40Ha46rjdx`|zWoAntld2GK#bJt}@B<{)OR aVh6sWpfIj~dGUyy0Ch@8c1N#`x2;cK_n_ba delta 457 zcmZuuUrWMJ6nE<-20lnc1`&q~;TBBpy_>0*kYu|vX_9XE z1dq0V@pRgYhGA*YnoJ%_Q%O!gYoH)%{@@8_CT1ju;ARr83EI8Zs2koMF{pc05!mH` z6X?gRPQ!KKH$I!qBIva4V%2}d24%E>G(~l)F1I`$vmD!iHrwB57r{x+#2A=$UKSPZ z>p=}vNBE$ueNEq_oeUwmACA8h!9_+)Mv9vg*qiUmnZ|)HZzbgIL|iG5%CodL+db<@ z-R0n8dfhBFF$CO;MIdj&m9T2UqL8Cd;lc8ldf Date: Mon, 24 Jan 2022 21:03:15 -0800 Subject: [PATCH 03/10] FILEIO: Recirculated FDEV fields that had been evacuated during external format transformation FDEV1...FDEV4 now available (used by PSEUDOHOSTS) --- sources/FILEIO | 98 ++++++++++++++++++++++---------------------- sources/FILEIO.LCOM | Bin 45531 -> 45517 bytes 2 files changed, 49 insertions(+), 49 deletions(-) diff --git a/sources/FILEIO b/sources/FILEIO index 95c3fda4..5fa11e3d 100644 --- a/sources/FILEIO +++ b/sources/FILEIO @@ -1,11 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Dec-2021 09:31:06" {DSK}kaplan>Local>medley3.5>my-medley>sources>FILEIO.;103 160528 +(FILECREATED "13-Jan-2022 19:45:36" {DSK}kaplan>Local>medley3.5>my-medley>sources>FILEIO.;105 160514 - :CHANGES-TO (FNS \DO.PARAMS.AT.OPEN SETFILEINFO) + :CHANGES-TO (RECORDS FDEV) - :PREVIOUS-DATE "14-Dec-2021 16:10:18" -{DSK}kaplan>Local>medley3.5>my-medley>sources>FILEIO.;102) + :PREVIOUS-DATE "19-Dec-2021 09:31:06" +{DSK}kaplan>Local>medley3.5>my-medley>sources>FILEIO.;103) (* ; " @@ -859,12 +859,12 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.  "(stream byte) output byte to stream") (PEEKBIN POINTER) (* ;  "(stream) => next byte without advancing position in stream") - (NIL POINTER) (* ; - "Was READCHAR, replaced by READCHARCODE") - (NIL POINTER) (* ; + (FDEV1 POINTER) (* ; + "Was READCHAR, replaced by READCHARCODE. Now available for device-specific use") + (FDEV2 POINTER) (* ;  "Was WRITECHAR (stream char) => writes char to stream") - (NIL POINTER) (* ; "Was PEEKCHAR") - (NIL POINTER) (* ; "Was UNREADCHAR") + (FDEV3 POINTER) (* ; "Was PEEKCHAR") + (FDEV4 POINTER) (* ; "Was UNREADCHAR") (READP POINTER) (* ;  "(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* ; @@ -1125,10 +1125,10 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. (BIN POINTER) (BOUT POINTER) (PEEKBIN POINTER) - (NIL POINTER) - (NIL POINTER) - (NIL POINTER) - (NIL POINTER) + (FDEV1 POINTER) + (FDEV2 POINTER) + (FDEV3 POINTER) + (FDEV4 POINTER) (READP POINTER) (EOFP POINTER) (BLOCKIN POINTER) @@ -3089,40 +3089,40 @@ update the map") (PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2020 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (26876 30354 (STREAMPROP 26886 . 27320) (GETSTREAMPROP 27322 . 27791) (PUTSTREAMPROP -27793 . 30202) (STREAMP 30204 . 30352)) (30397 32916 (\DEFPRINT.BY.NAME 30407 . 31559) ( -\STREAM.DEFPRINT 31561 . 32609) (\FDEV.DEFPRINT 32611 . 32914)) (33174 38215 (\GETACCESS 33184 . 33638 -) (\SETACCESS 33640 . 38213)) (58368 64337 (\DEFINEDEVICE 58378 . 60694) (\GETDEVICEFROMNAME 60696 . -61169) (\GETDEVICEFROMHOSTNAME 61171 . 62215) (\REMOVEDEVICE 62217 . 63340) (\REMOVEDEVICE.NAMES 63342 - . 64335)) (64377 88654 (\CLOSEFILE 64387 . 65212) (\DELETEFILE 65214 . 65508) (\DEVICEEVENT 65510 . -67280) (\GENERATEFILES 67282 . 67760) (\GENERATENEXTFILE 67762 . 68413) (\GENERATEFILEINFO 68415 . -68876) (\GETFILENAME 68878 . 69267) (\GENERIC.OUTFILEP 69269 . 69739) (\OPENFILE 69741 . 72319) ( -\DO.PARAMS.AT.OPEN 72321 . 74491) (\RENAMEFILE 74493 . 74917) (\REVALIDATEFILE 74919 . 77521) ( -\PAGED.REVALIDATEFILELST 77523 . 79081) (\PAGED.REVALIDATEFILES 79083 . 80802) (\PAGED.REVALIDATEFILE -80804 . 83087) (\BUFFERED.REVALIDATEFILE 83089 . 85375) (\BUFFERED.REVALIDATEFILELST 85377 . 86561) ( -\PRINT-REVALIDATION-RESULT 86563 . 86978) (\TRUNCATEFILE 86980 . 87371) (\FILE-CONFLICT 87373 . 88652) -) (88690 93353 (\GENERATENOFILES 88700 . 90796) (\NULLFILEGENERATOR 90798 . 91042) (\NOFILESNEXTFILEFN - 91044 . 93035) (\NOFILESINFOFN 93037 . 93351)) (93472 95380 (\FILE.NOT.OPEN 93482 . 93995) ( -\FILE.WONT.OPEN 93997 . 94325) (\ILLEGAL.DEVICEOP 94327 . 94609) (\IS.NOT.RANDACCESSP 94611 . 95057) ( -\STREAM.NOT.OPEN 95059 . 95378)) (95515 97813 (\FDEVINSTANCE 95525 . 97811)) (99015 106389 (CNDIR -99025 . 100330) (DIRECTORYNAME 100332 . 104515) (DIRECTORYNAMEP 104517 . 105133) (HOSTNAMEP 105135 . -105942) (\ADD.CONNECTED.DIR 105944 . 106387)) (106434 134314 (\BACKFILEPTR 106444 . 106632) ( -\BACKPEEKBIN 106634 . 106995) (\BACKBIN 106997 . 107348) (BIN 107350 . 107567) (\BIN 107569 . 107846) -(\BINS 107848 . 108134) (BOUT 108136 . 108498) (\BOUT 108500 . 108815) (\BOUTS 108817 . 109128) ( -COPYBYTES 109130 . 112462) (COPYCHARS 112464 . 116130) (COPYFILE 116132 . 116929) (\COPYOPENFILE -116931 . 120004) (\INFER.FILE.TYPE 120006 . 120960) (EOFP 120962 . 121259) (FORCEOUTPUT 121261 . -121508) (\FLUSH.OPEN.STREAMS 121510 . 121866) (CHARSET 121868 . 123532) (ACCESS-CHARSET 123534 . -123751) (GETEOFPTR 123753 . 124003) (GETFILEINFO 124005 . 127198) (\TYPE.FROM.FILETYPE 127200 . 127670 -) (\FILETYPE.FROM.TYPE 127672 . 127851) (GETFILEPTR 127853 . 128105) (SETFILEINFO 128107 . 132213) ( -SETFILEPTR 132215 . 133934) (BOUT16 133936 . 134121) (BIN16 134123 . 134312)) (134417 139622 ( -\GENERIC.BINS 134427 . 134707) (\GENERIC.BOUTS 134709 . 134974) (\GENERIC.RENAMEFILE 134976 . 136807) -(\GENERIC.OPENP 136809 . 138124) (\GENERIC.READP 138126 . 139167) (\GENERIC.CHARSET 139169 . 139620)) -(139623 139962 (\MAP-OPEN-STREAMS 139633 . 139960)) (141746 143826 (\EOF.ACTION 141756 . 142007) ( -\EOSERROR 142009 . 142202) (\GETEOFPTR 142204 . 142386) (\INCFILEPTR 142388 . 142738) (\PEEKBIN 142740 - . 142931) (\SETCLOSEDFILELENGTH 142933 . 143267) (\SETEOFPTR 143269 . 143457) (\SETFILEPTR 143459 . -143824)) (143827 144369 (\FIXPOUT 143837 . 144137) (\FIXPIN 144139 . 144367)) (144370 144936 (\BOUTEOL - 144380 . 144934)) (147832 157696 (\BUFFERED.BIN 147842 . 148694) (\BUFFERED.PEEKBIN 148696 . 149478) -(\BUFFERED.BOUT 149480 . 150340) (\BUFFERED.BINS 150342 . 154027) (\BUFFERED.BOUTS 154029 . 155830) ( -\BUFFERED.COPYBYTES 155832 . 157694)) (157725 160077 (\NULLDEVICE 157735 . 159753) (\NULL.OPENFILE -159755 . 160075))))) + (FILEMAP (NIL (26854 30332 (STREAMPROP 26864 . 27298) (GETSTREAMPROP 27300 . 27769) (PUTSTREAMPROP +27771 . 30180) (STREAMP 30182 . 30330)) (30375 32894 (\DEFPRINT.BY.NAME 30385 . 31537) ( +\STREAM.DEFPRINT 31539 . 32587) (\FDEV.DEFPRINT 32589 . 32892)) (33152 38193 (\GETACCESS 33162 . 33616 +) (\SETACCESS 33618 . 38191)) (58354 64323 (\DEFINEDEVICE 58364 . 60680) (\GETDEVICEFROMNAME 60682 . +61155) (\GETDEVICEFROMHOSTNAME 61157 . 62201) (\REMOVEDEVICE 62203 . 63326) (\REMOVEDEVICE.NAMES 63328 + . 64321)) (64363 88640 (\CLOSEFILE 64373 . 65198) (\DELETEFILE 65200 . 65494) (\DEVICEEVENT 65496 . +67266) (\GENERATEFILES 67268 . 67746) (\GENERATENEXTFILE 67748 . 68399) (\GENERATEFILEINFO 68401 . +68862) (\GETFILENAME 68864 . 69253) (\GENERIC.OUTFILEP 69255 . 69725) (\OPENFILE 69727 . 72305) ( +\DO.PARAMS.AT.OPEN 72307 . 74477) (\RENAMEFILE 74479 . 74903) (\REVALIDATEFILE 74905 . 77507) ( +\PAGED.REVALIDATEFILELST 77509 . 79067) (\PAGED.REVALIDATEFILES 79069 . 80788) (\PAGED.REVALIDATEFILE +80790 . 83073) (\BUFFERED.REVALIDATEFILE 83075 . 85361) (\BUFFERED.REVALIDATEFILELST 85363 . 86547) ( +\PRINT-REVALIDATION-RESULT 86549 . 86964) (\TRUNCATEFILE 86966 . 87357) (\FILE-CONFLICT 87359 . 88638) +) (88676 93339 (\GENERATENOFILES 88686 . 90782) (\NULLFILEGENERATOR 90784 . 91028) (\NOFILESNEXTFILEFN + 91030 . 93021) (\NOFILESINFOFN 93023 . 93337)) (93458 95366 (\FILE.NOT.OPEN 93468 . 93981) ( +\FILE.WONT.OPEN 93983 . 94311) (\ILLEGAL.DEVICEOP 94313 . 94595) (\IS.NOT.RANDACCESSP 94597 . 95043) ( +\STREAM.NOT.OPEN 95045 . 95364)) (95501 97799 (\FDEVINSTANCE 95511 . 97797)) (99001 106375 (CNDIR +99011 . 100316) (DIRECTORYNAME 100318 . 104501) (DIRECTORYNAMEP 104503 . 105119) (HOSTNAMEP 105121 . +105928) (\ADD.CONNECTED.DIR 105930 . 106373)) (106420 134300 (\BACKFILEPTR 106430 . 106618) ( +\BACKPEEKBIN 106620 . 106981) (\BACKBIN 106983 . 107334) (BIN 107336 . 107553) (\BIN 107555 . 107832) +(\BINS 107834 . 108120) (BOUT 108122 . 108484) (\BOUT 108486 . 108801) (\BOUTS 108803 . 109114) ( +COPYBYTES 109116 . 112448) (COPYCHARS 112450 . 116116) (COPYFILE 116118 . 116915) (\COPYOPENFILE +116917 . 119990) (\INFER.FILE.TYPE 119992 . 120946) (EOFP 120948 . 121245) (FORCEOUTPUT 121247 . +121494) (\FLUSH.OPEN.STREAMS 121496 . 121852) (CHARSET 121854 . 123518) (ACCESS-CHARSET 123520 . +123737) (GETEOFPTR 123739 . 123989) (GETFILEINFO 123991 . 127184) (\TYPE.FROM.FILETYPE 127186 . 127656 +) (\FILETYPE.FROM.TYPE 127658 . 127837) (GETFILEPTR 127839 . 128091) (SETFILEINFO 128093 . 132199) ( +SETFILEPTR 132201 . 133920) (BOUT16 133922 . 134107) (BIN16 134109 . 134298)) (134403 139608 ( +\GENERIC.BINS 134413 . 134693) (\GENERIC.BOUTS 134695 . 134960) (\GENERIC.RENAMEFILE 134962 . 136793) +(\GENERIC.OPENP 136795 . 138110) (\GENERIC.READP 138112 . 139153) (\GENERIC.CHARSET 139155 . 139606)) +(139609 139948 (\MAP-OPEN-STREAMS 139619 . 139946)) (141732 143812 (\EOF.ACTION 141742 . 141993) ( +\EOSERROR 141995 . 142188) (\GETEOFPTR 142190 . 142372) (\INCFILEPTR 142374 . 142724) (\PEEKBIN 142726 + . 142917) (\SETCLOSEDFILELENGTH 142919 . 143253) (\SETEOFPTR 143255 . 143443) (\SETFILEPTR 143445 . +143810)) (143813 144355 (\FIXPOUT 143823 . 144123) (\FIXPIN 144125 . 144353)) (144356 144922 (\BOUTEOL + 144366 . 144920)) (147818 157682 (\BUFFERED.BIN 147828 . 148680) (\BUFFERED.PEEKBIN 148682 . 149464) +(\BUFFERED.BOUT 149466 . 150326) (\BUFFERED.BINS 150328 . 154013) (\BUFFERED.BOUTS 154015 . 155816) ( +\BUFFERED.COPYBYTES 155818 . 157680)) (157711 160063 (\NULLDEVICE 157721 . 159739) (\NULL.OPENFILE +159741 . 160061))))) STOP diff --git a/sources/FILEIO.LCOM b/sources/FILEIO.LCOM index 422549371b53a6834c8083fa09d1c0a1bd4f5bd4..194c556abecd4db770539ff201e295eb49350ac4 100644 GIT binary patch delta 382 zcmccpnCa|erU?;3#=2gKdAddhMn(#TmR2UFR>l*vf+b8f6_gB(kfbcEj4Z8;%qCvd z_D2%d)6-K@NJ%V7O~Izz*icE6OT*36$JIH=)iK1?1*izqy2<{GPM)R;T!v-_riLa8 zR?Z%de(tWpx*`4w8bPkk{y{Fm3T`g0VVVk70YR=|p8lc1x-LM|fQDJ>x}+w9+-|5~ zU}e|F8DvK~fex*Qqo%gde2VlMp|1QFZC+08d_GTciP5~mD4 zg`<;WpTO10%TQWS9KZkXeQSSi?U!YD=qKxYKMX<)gCU793Cag`7J1OY@qrYRe$S}o z$Avtg5kd}J-94^Xf7)Zm18&MEY@9P%u*8^t&uM9mZX*crAn1oNB;zY8E}8NR3EfmE zc#}w!(VR{dq6Lx}6Hu|DZRH}B9wb@L=3LH{pO_6Z(c9m~1A+sBp(wOv#xoVw->}N3G`PbHLXu9py&1V@s2nBKsWWWv*03; N3z;bhn$y>}qaOgTX72z1 From ae3851ccf9f9ff42f8e93c4738d10fc579930470 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 21:04:10 -0800 Subject: [PATCH 04/10] CMLPATHNAME: reprinted for FUNCTION/MACRO filemap --- sources/CMLPATHNAME | 256 ++++++++++++++++++++------------------- sources/CMLPATHNAME.LCOM | Bin 22230 -> 21996 bytes 2 files changed, 131 insertions(+), 125 deletions(-) diff --git a/sources/CMLPATHNAME b/sources/CMLPATHNAME index 5c4d79d4..0c0bff9c 100644 --- a/sources/CMLPATHNAME +++ b/sources/CMLPATHNAME @@ -1,13 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Sep-90 15:14:19" |{PELE:MV:ENVOS}SOURCES>CMLPATHNAME.;9| 42057 - changes to%: (FNS CL:MAKE-PATHNAME) +(FILECREATED "14-Jan-2022 11:40:58"  +{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2 41496 - previous date%: "22-Aug-90 19:16:14" |{PELE:MV:ENVOS}SOURCES>CMLPATHNAME.;8|) + :PREVIOUS-DATE "28-Sep-90 15:14:19" +{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;1) (* ; " -Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT CMLPATHNAMECOMS) @@ -38,11 +39,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - (ADDVARS (NLAMA) - (NLAML) - (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES - PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME]) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA + CL:ENOUGH-NAMESTRING + CL:MERGE-PATHNAMES + CL:MAKE-PATHNAME]) @@ -68,20 +70,20 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL) `[if (NOT ,ONEFIELDFLG) then [SETQ ,VAL (CONS (COND - (,PACKFLG (SUBATOM ,FILE ,ST ,END)) - (T (OR (SUBSTRING ,FILE ,ST ,END) - ""))) - (CONS ,NAM ,VAL] + (,PACKFLG (SUBATOM ,FILE ,ST ,END)) + (T (OR (SUBSTRING ,FILE ,ST ,END) + ""))) + (CONS ,NAM ,VAL] elseif (EQMEMB ,NAM ,ONEFIELDFLG) then (RETURN (COND - (,PACKFLG (SUBATOM ,FILE ,ST ,END)) - (T (OR (SUBSTRING ,FILE ,ST ,END) - ""]) + (,PACKFLG (SUBATOM ,FILE ,ST ,END)) + (T (OR (SUBSTRING ,FILE ,ST ,END) + ""]) (CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-) - (:PRINT-FUNCTION %%PRINT-PATHNAME) - (:CONSTRUCTOR %%%%MAKE-PATHNAME) - (:PREDICATE CL:PATHNAMEP)) + (:PRINT-FUNCTION %%PRINT-PATHNAME) + (:CONSTRUCTOR %%%%MAKE-PATHNAME) + (:PREDICATE CL:PATHNAMEP)) HOST DEVICE DIRECTORY @@ -90,9 +92,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r VERSION) (CL:DEFSTRUCT (DIRECTORY-COMPONENT (:CONC-NAME %%DIRECTORY-COMPONENT-) - (:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT) - (:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT) - (:PREDICATE %%DIRECTORY-COMPONENT-P)) + (:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT) + (:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT) + (:PREDICATE %%DIRECTORY-COMPONENT-P)) TYPE PATH) (DEFINEQ @@ -252,9 +254,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (* ;;; "Returns the full form of PATHNAME as a string.") (CL:WHEN (AND (STREAMP PATHNAME) - (NOT (fetch (STREAM NAMEDP) of PATHNAME))) - (* ; - "unnamed streams have the empty string as name.") + (NOT (fetch (STREAM NAMEDP) of PATHNAME))) (* ; + "unnamed streams have the empty string as name.") (CL:RETURN-FROM CL:NAMESTRING "")) [LET* ((PATHNAME (PATHNAME PATHNAME)) (CL::HOST (%%PATHNAME-HOST PATHNAME)) @@ -306,8 +307,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (T CL::VERSION))])]) (CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0) - END - (JUNK-ALLOWED NIL)) + END + (JUNK-ALLOWED NIL)) (* ;;; "Parses a string representation of a pathname into a pathname. For details on the other silly arguments see the manual. NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything) It also ignores Host and defaults since we don't support non-standard hosts") @@ -317,9 +318,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (PATHNAME (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:VALUES THING START))) (STREAM (CL:IF (XCL:SYNONYM-STREAM-P THING) [CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:PARSE-NAMESTRING (CL:SYMBOL-VALUE - ( + ( XCL:SYNONYM-STREAM-SYMBOL - THING] + THING] (SETQ THING (FILE-NAME THING)))) (CL:SYMBOL (SETQ THING (CL:SYMBOL-NAME THING))) (T (CL:ERROR "This is of an inappropriate type for parse-namestring: ~S" THING))) @@ -339,8 +340,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH (%%WILD-NAME CL:DIRECTORY))) (CL::SUBDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :SUBDIRECTORY - :PATH (%%WILD-NAME CL::SUBDIRECTORY)) - ) + :PATH (%%WILD-NAME CL::SUBDIRECTORY))) (CL::RELATIVEDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (%%WILD-NAME CL::RELATIVEDIRECTORY)) @@ -374,8 +374,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r ((OR (LITATOM FILE) (CL:STRINGP FILE) (NUMBERP FILE))) - [(type? STREAM FILE) (* ; - "For streams, use full name. If anonymous, fake it") + [(type? STREAM FILE) (* ; + "For streams, use full name. If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (CONS (SUB1 POS) (LIST 'NAME FILE] @@ -387,12 +387,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r FILE 2) 0)))) (%[ (* ; - "some Xerox and Arpanet systems use `[' for host") + "some Xerox and Arpanet systems use `[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ; - "this is the standard for Xerox product file servers") + "this is the standard for Xerox product file servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) @@ -426,7 +426,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r [COND ((AND (EQ START POS) (NOT HOSTP)) (* ; - "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory") + "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory") (SETQ TYPE 'SUBDIRECTORY] -2) (PROGN -1))) @@ -435,12 +435,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DREVERSE VAL] ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ; - "unix and the `xerox standard' use / for delimiter") + "unix and the `xerox standard' use / for delimiter") (SETQ TEM (LASTCHPOS (CHARCODE /) FILE (ADD1 POS)))) ((< >) (* ; - "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") + "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") (SETQ TEM (LASTCHPOS (CHARCODE >) FILE (ADD1 POS)))) @@ -456,7 +456,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r NAMELP (SELCHARQ CODE ((%. ! ; NIL) (* ; - "NAME and SUBDIRECTORY fields definitely terminated by now") + "NAME and SUBDIRECTORY fields definitely terminated by now") (COND ((AND (EQ CODE (CHARCODE %.)) (NOT BEYONDNAME) @@ -475,29 +475,29 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (COND ((AND (NULL CODE) (EQ POS TEM)) (* ; - "Nothing follows the subdirectory; null name is NOT implied") + "Nothing follows the subdirectory; null name is NOT implied") (RETURN (CONS (SUB1 POS) (DREVERSE VAL] (%%UNPACKFILE1 [COND - ((NOT BEYONDNAME) - (COND - ((NEQ CODE (CHARCODE %.)) - (SETQQ BEYONDEXT ;))) - (SETQQ BEYONDNAME NAME)) - ((NOT BEYONDEXT) - (SETQ BEYONDEXT (COND - ((NEQ CODE (CHARCODE %.)) - ';) - (T T))) - 'TYPE) - (T (SELCHARQ (AND (EQ BEYONDEXT ';) - (NTHCHARCODE FILE POS)) - (P 'PROTECTION) - (A (add POS 1) - 'ACCOUNT) - ((T S) - 'TEMPORARY) - 'VERSION] + ((NOT BEYONDNAME) + (COND + ((NEQ CODE (CHARCODE %.)) + (SETQQ BEYONDEXT ;))) + (SETQQ BEYONDNAME NAME)) + ((NOT BEYONDEXT) + (SETQ BEYONDEXT (COND + ((NEQ CODE (CHARCODE %.)) + ';) + (T T))) + 'TYPE) + (T (SELCHARQ (AND (EQ BEYONDEXT ';) + (NTHCHARCODE FILE POS)) + (P 'PROTECTION) + (A (add POS 1) + 'ACCOUNT) + ((T S) + 'TEMPORARY) + 'VERSION] POS (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) @@ -509,12 +509,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (%' (* ; "Quoter") (add TEM 1)) ((/ >) (* ; - "Subdirectory terminating character") + "Subdirectory terminating character") (COND ((AND (NOT HOSTP) (NOT BEYONDNAME) DIRFLG) (* ; - "Ok to treat this as a subdirectory") + "Ok to treat this as a subdirectory") (SETQ SUBDIREND TEM)))) NIL) NEXTCHAR @@ -527,14 +527,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r [if (STREAMP PATHNAME) then (COND - [(XCL:SYNONYM-STREAM-P PATHNAME) - (CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE ( - XCL:SYNONYM-STREAM-SYMBOL - PATHNAME] - ((NOT (fetch (STREAM NAMEDP) of PATHNAME)) - (* ; - "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.") - (CL:ERROR "The stream ~S has no corresponding named file." PATHNAME] + [(XCL:SYNONYM-STREAM-P PATHNAME) + (CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (XCL:SYNONYM-STREAM-SYMBOL + PATHNAME] + ((NOT (fetch (STREAM NAMEDP) of PATHNAME)) (* ; + "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.") + (CL:ERROR "The stream ~S has no corresponding named file." PATHNAME] (LET ((RESULT (CL:PROBE-FILE PATHNAME))) (CL:UNLESS RESULT (CL:ERROR "The file ~S does not exist." (CL:NAMESTRING PATHNAME))) @@ -571,8 +569,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS* \CONNECTED.DIRECTORY)) (if (NOT (BOUNDP '\CONNECTED.DIRECTORY)) then (SETQ \CONNECTED.DIRECTORY '{DSK})) - [SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY - (FILENAMEFIELD \CONNECTED.DIRECTORY 'HOST] + [SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD + \CONNECTED.DIRECTORY + 'HOST] (CL:SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*) :NEWEST) *DEFAULT-PATHNAME-DEFAULTS*) @@ -599,53 +598,52 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DECLARE (IGNORE DIRFLG)) [if ONEFIELDFLG then [AND (CL:CONSP ONEFIELDFLG) - (SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG - '(HOST DEVICE DIRECTORY NAME EXTENSION VERSION] - (LET [(RESULT (CASE ONEFIELDFLG - (HOST (CL:PATHNAME-HOST FILE)) - (DEVICE (CL:PATHNAME-DEVICE FILE)) - (DIRECTORY (CL:PATHNAME-DIRECTORY FILE)) - (NAME (CL:PATHNAME-NAME FILE)) - (EXTENSION (CL:PATHNAME-TYPE FILE)) - (VERSION (CL:PATHNAME-VERSION FILE)) - (CL:OTHERWISE NIL))] - (if ATOMFLG - then (MKATOM RESULT) - else RESULT)) + (SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG + '(HOST DEVICE DIRECTORY NAME EXTENSION VERSION] + (LET [(RESULT (CASE ONEFIELDFLG + (HOST (CL:PATHNAME-HOST FILE)) + (DEVICE (CL:PATHNAME-DEVICE FILE)) + (DIRECTORY (CL:PATHNAME-DIRECTORY FILE)) + (NAME (CL:PATHNAME-NAME FILE)) + (EXTENSION (CL:PATHNAME-TYPE FILE)) + (VERSION (CL:PATHNAME-VERSION FILE)) + (CL:OTHERWISE NIL))] + (if ATOMFLG + then (MKATOM RESULT) + else RESULT)) else (LET ((COMPONENT)) - (APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE)) - then (LIST 'HOST (if ATOMFLG - then (MKATOM COMPONENT) - else COMPONENT) - COMPONENT)) - (if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE)) - then (LIST 'DEVICE (if ATOMFLG - then (MKATOM COMPONENT) - else COMPONENT))) - (if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE)) - then (LIST 'DIRECTORY (if ATOMFLG - then (MKATOM COMPONENT) - else COMPONENT))) - (if (SETQ COMPONENT (CL:PATHNAME-NAME FILE)) - then (LIST 'NAME (if ATOMFLG - then (MKATOM COMPONENT) - else COMPONENT))) - (if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE)) - then (LIST 'EXTENSION (if ATOMFLG - then (MKATOM COMPONENT) - else COMPONENT))) - (if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE)) - then (LIST 'VERSION (if ATOMFLG - then (MKATOM COMPONENT) - else (MKSTRING COMPONENT]) + (APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE)) + then (LIST 'HOST (if ATOMFLG + then (MKATOM COMPONENT) + else COMPONENT) + COMPONENT)) + (if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE)) + then (LIST 'DEVICE (if ATOMFLG + then (MKATOM COMPONENT) + else COMPONENT))) + (if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE)) + then (LIST 'DIRECTORY (if ATOMFLG + then (MKATOM COMPONENT) + else COMPONENT))) + (if (SETQ COMPONENT (CL:PATHNAME-NAME FILE)) + then (LIST 'NAME (if ATOMFLG + then (MKATOM COMPONENT) + else COMPONENT))) + (if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE)) + then (LIST 'EXTENSION (if ATOMFLG + then (MKATOM COMPONENT) + else COMPONENT))) + (if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE)) + then (LIST 'VERSION (if ATOMFLG + then (MKATOM COMPONENT) + else (MKSTRING COMPONENT]) (CL:DEFUN CL:FILE-NAMESTRING (PATHNAME) (LET* ((*PRINT-BASE* 10) (*PRINT-RADIX* NIL) (PATH (PATHNAME PATHNAME)) - [RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING ( - %%PATHNAME-NAME - PATH))) + [RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING (%%PATHNAME-NAME + PATH))) "." (MKSTRING (%%COMPONENT-STRING (%%PATHNAME-TYPE PATH] (VERSION (%%PATHNAME-VERSION PATH))) @@ -675,8 +673,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (ADDTOVAR NLAML ) -(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME - %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME) +(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME) ) (PRETTYCOMPRINT CMLPATHNAMECOMS) @@ -706,24 +703,33 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA - CL:ENOUGH-NAMESTRING - CL:MERGE-PATHNAMES - CL:MAKE-PATHNAME]) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA) + (NLAML) + (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES + PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) -(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME) +(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME + %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME) ) (PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3597 9368 (%%PRINT-PATHNAME 3607 . 3768) (CL:MAKE-PATHNAME 3770 . 8520) ( -%%PRINT-DIRECTORY-COMPONENT 8522 . 9366)) (10569 15893 (PATHNAME 10579 . 10771) (CL:MERGE-PATHNAMES -10773 . 12859) (FILE-NAME 12861 . 13002) (CL:HOST-NAMESTRING 13004 . 13193) (CL:ENOUGH-NAMESTRING -13195 . 15660) (%%NUMERIC-STRING-P 15662 . 15891))))) + (FILEMAP (NIL (3743 9514 (%%PRINT-PATHNAME 3753 . 3914) (CL:MAKE-PATHNAME 3916 . 8666) ( +%%PRINT-DIRECTORY-COMPONENT 8668 . 9512)) (9516 9709 (CL:PATHNAME-HOST 9516 . 9709)) (9711 9910 ( +CL:PATHNAME-DEVICE 9711 . 9910)) (9912 10120 (CL:PATHNAME-DIRECTORY 9912 . 10120)) (10122 10315 ( +CL:PATHNAME-NAME 10122 . 10315)) (10317 10510 (CL:PATHNAME-TYPE 10317 . 10510)) (10512 10714 ( +CL:PATHNAME-VERSION 10512 . 10714)) (10715 16039 (PATHNAME 10725 . 10917) (CL:MERGE-PATHNAMES 10919 . +13005) (FILE-NAME 13007 . 13148) (CL:HOST-NAMESTRING 13150 . 13339) (CL:ENOUGH-NAMESTRING 13341 . +15806) (%%NUMERIC-STRING-P 15808 . 16037)) (16041 19794 (CL:NAMESTRING 16041 . 19794)) (19796 23267 ( +CL:PARSE-NAMESTRING 19796 . 23267)) (23269 31722 (PARSE-NAMESTRING1 23269 . 31722)) (31724 32727 ( +CL:TRUENAME 31724 . 32727)) (32729 32921 (%%MAKE-PATHNAME 32729 . 32921)) (32923 33560 ( +%%PATHNAME-EQUAL 32923 . 33560)) (33562 34019 (%%DIRECTORY-COMPONENT-EQUAL 33562 . 34019)) (34021 +34644 (%%INITIALIZE-DEFAULT-PATHNAME 34021 . 34644)) (34734 34901 (INTERLISP-NAMESTRING 34734 . 34901) +) (34903 37796 (UNPACKPATHNAME.STRING 34903 . 37796)) (37798 39055 (CL:FILE-NAMESTRING 37798 . 39055)) + (39057 39255 (CL:DIRECTORY-NAMESTRING 39057 . 39255))))) STOP diff --git a/sources/CMLPATHNAME.LCOM b/sources/CMLPATHNAME.LCOM index 586309238f131ecf68e75301dc9733225546aff9..28c012eadef98657b4dbbaf946af64eada7cbf27 100644 GIT binary patch delta 6060 zcmb_gdu&_P8IPSugWIG|6F(B1oDngIc69CMpC-j45tlQi0Axlcse{n>OwB$NnhNCMLumFtkmYrfAuk-r8-}l|~hu1A1y=HlOx@5EYr;;fpo>O84WfFN=AvjY!5#$(-Lo6E+ z*a#zfk>7jxtIGO?cvz+`->HXFylR1t;)>)yDU&cdpK zWNFJ@bQI>CnoFe+%h%*5CMLXSx%d@W6Bw$|bvv>*@Hty!BBEUSV)lXrRtQTdlFcde zNp&tCoP^VaeQl+Yy=BE>!~3m=p?%TOi!WIZ zK(DQJ5!zzw5ooWr-UaQxwk2qvXv;%;t?dxBvGy#b4B_?mTcI~He+RUsc_+Ty(eJjc z+sJYL1vl&uRj2Pl#i|$GibB`Ovl@e1E3^X4gC2(0jT?f5K8pz#{Bj;^uD^C?EH`0i_nI5kaPOpj=QZk8Q_h!6_LfXC)u7<>;o>M28Qt52Sv3`$Oy-n$LCqbc zlY_zWw*O_&&@rx#h`3 zSX~!Y+jza_0=ZJ9cN(rVV2i8SgIgu=#oh-%0QHTw(UVQ|5idQk|9V{M3)9{J?sZ5V znkr^dA3p5Z4-AWY0AF^bpx5D?f;R0W4nX)nbrP!GbtkkIx3i;mlR#K^xwMJibBUBc z1TAvkU}k~Rbz~cw2OxI<57|4+0>z&3bNvpWz&hJ#)QJ7xhT*&Y{B_1Q$yzifat~r| zU>@cbLYP4g{Ng~mpUC-qSqPm%-HB|wzAz2(!tF>jN$I_BG)?>BKBtN}a zw(zUFdOorDTpK$2R^r$@Z>N@L300`9-hSoij}yn1?3JbNifUh0yQy?#_0FYTm7`02 z72vrmOU{bwURIri$5vLC`j!SNxWnVHOkj`4V;RR`kH_u@#=a%4l6P zW-blVmDU<{;LGZb+sW$J75vQ5pmpIEya56Ew-&$5@;JNSGaHh_2re$JX5x@HG9-6| zWPy6Y8hlX_Lr6zjNo0tTGNM;|EVMyT<$siS}VOfaeOo}@p zNrnJ$m8wQiNUZ9F#H~7lp#$)*nGJCQisY13tdN|CqhoO{TL@o#>}7icAwCC*z-tI7=+w$P+>^ zYZXKVp}Jau<57fyHXja|m&J$32|#55m&FS*iX_y00YaAuDO0hzR3Q%`tzG$+m2u(Y zrUT$$S_6bR$;^SHsd3;8Y6G}uxZ5;KqKgGA11*+B?2lI$%2gLK1F zYAzisps|lAkOV19+iaq5WYu3ak z=N1O=>w6w#eyBPxmRnv@`<6S%Rb6e-F7(pZE2>kcEV(rrR{PfP#a|k`!IHq=85^)J zc<>L#&N=}I>ye6+B?4+rPNo-b21$+=2`esghF>C+D}#^nGKnc=K_LNSMgtyD#W)yV z;PExT+s&E6fM);-C|q!1Tnf0XApxHaI4u%pcRRhDSVcj^kpL#9pvURx!9nz&4Y-03 zw;Bh4vIbBb#Hxle90SXvlR#{d3ZR!I3kIC8ff9=+kjudWNY~LtssRWi)ONxG-Wc0r z8PmChP5YHi5iW&m3ZkhGm4SY6w6Y~dLhWNfD<}vpfZyAzbZZWU*bssu9;)8fUcLGm zpK;eaBm#J*Qav3GO=^97`1-4On8e7RG}yxID2+0usR_eE_F zRVZ$hE#Jp4?0bIjJasqKsdj4)2#%%$Nx9`RzCGyK|5sfia~<(ns!V|fN|y5G&r`bJ zzPXKZsEmyWUMz3Egv-IeZoaX|g_!V~Dz)gAZ6kos|S2y7EmmcvI%%YrzB2Aj0=NOp)J`YsF9vX`mt? z$zK8!jdD;}G!h|f^=gBmQ9U9wt26|`6zT#l@9wknaxEt#UZTn}4<%v49J~Paf>9*# zu(qvu!UN6$0+mQ5VL%86`Lw|j2j*)MP=+*0Kyo%DSO9Jv&vsgHR`^;%t!Bq=4MSd4_09{kRoJpyEvxIk>QECqx4Q0Fuv@Cc1v~bL zVRb=cKAXCjeq;6!fta<{k1rjf_?4spRztB%$;`4QenG>{^?q%5o{FzN1~y+2_mmdw zR;#66^cR}wrFW_9`r9pjUV_-AUooj9$+(bE7BhsvK_7~VY9CT&t#6{kXHJ#Q!A-z{ zYB15o$ssfsjK}f{g4DVw?Y;|gJ4n=WJ2*E@q~x2#ppwrGEr-KxFQ#MhL^7k$`ko~4 zsu;&tqmKi))m>GlU*ugZ32QAwYr$oOgaj1;z7YCW6lzO?ci=ZX#0l{l9%^_pWFW`E z5I_rg=Q7FLpbNzTC2>Ha4u_ZIk$$Zx&E>V^YVx3s@5=vfwb(Y!-*|;QloX=(xop|k zRzcVulyn<^i9Xo|B4^@Pp}lER=pjZ6xjFh(uT^~yPyVY5PE4Xl8cRct{)V#P0OxLe zEWm$P9tJ!2Ox;p_iqPL|gW6rtD)LuTZ-LA=r_X6`CIIL*6ZhuC3eW)r$(zQN#A!|F ziMBzUO_G()CC>s$BAMNT|B-x3<3BzV9k9Wxhmr&5$<0kw{@gFB^72SS6=mGO@U@y!a3i6>sRmNhUus zG9r+L`TH@XP@;-zP||~nU+`3V?e}ID&w2ws0ufOOiUENThx@pz?4|{C%E6bwAM!knlp#9#V z1+>Gp$Iw1edlK!f+Hauk%gmy^l*yoNsGCE(RF~qEKKh5cgZS#I*J$^Q7hkcNX|xa2 zk9OD=A3QsMX2I)n9f`%qy=*Gz$za<_Jd%YQyBqdG&DYpR&o%7A z*NY9kXm8dl^luF=e6=>VHQC%m5)mJQ2MWH%bXRGFnPe&yo@SdY7RHd*K5X1!f$E>P zz2;=9vch$VCCTnUAwDfsvT56K9c$I#c{CMPWESz6sXtZ0m*1&x1bp^XauK#7R zv}dq4T)(xwG7qvxQ>F1o8oyTla3r0H8Oee(eeK(~R-vzS4Aa@x?d@0|muu7E;JRy< zTVG&X-O)CQt@hZ$M(Sws_?Xr&v^@fW&)bG>c5q5Ad%p`WL%~uUN`h!+_gPpLfQ$+1#m_Y$|P}XvjH4ceb-ofJS|3qieCOblz^S zD{QiAifk(_(eVz?w&JFi$->Y!76Yc=$2&$VY`xNP0Jh-zZTvJfc0Psfvz@Xzv0g`~ zNk87vOY6E0gR1DT?x6Q~B|6#Mv0v#}GF!1eL~zi5cHMb54yLa>LWxR*!4dbR47rr? z017L?iF@ge6St3e=g*xy@AY^{?Y{mRYt3S-r6zj1)oPuJeSR%x(dc@&qf=jBy8Gs- zccZ6gTh?cr*Nv71quJzs+TCqY=(e7ogt)#m+cPVypPC(7hoF0XcGtS$UNCks!4WWr zX7_-(moa_ovm@(`$*V`Af*vi)AH&NRpCdTtSBWi z0J}i;=|!?E1`1@^SCW=|(Lj0Z`H>?yh!Q`7GB_SfN5WYneU$ipVDOWq`$ck$;XW?} zGDnly&|O5=6&CSxx>gvH=$e!_r6cKo$Vlq&fh zQB`vrHxp%%6zzIhaYN7A>sM7#~2+hQ^86t~jfNUB_I*y1dWGy0L*iuI;=U}Bu9IQ#HgD@#}#6T$sP~Iq5 zri&0mVfczm znY8gD$ILU4^kk_D&TyHEOk=rX%V(O?^R2n2Woz`a=jPaM(j&Vrb*~xDYq^?N4f}$L zpfzS>fOeVwW0%u%k=E@VCDWX0bnqYZ+qnsG5AD9}4CqxzC?PcC{XGuJ4=~#d!IDC! z`+GIDRO^wl*hehO0i3U7yNCfz4 z*X8PflQfO-2Gl?yEF~3ZoGm($6u=!RAJi#>`}t8_FMW9$}ra?sfr}(^u1BLN7bvO72tZsIZ^xp zCcRJ5ILlmGZ_>zmBZp=}aiVAnNlfQgTtQN;)R+8B{|-e&nSqjr*DdAxKCPrLBaABa zWkfm(_a3JVgs4!74{+bqi`4Sqo9jYKmpzfkKh+UDqO@bFdJ+I*e?X}>l0a5!d|i; zK&XHxD@g%#?#DSCD3dbf!$1v>B1gc3M$ z{95AmBquM|-nwyu!&r>tTM6WD#FGoA_zNb4Uhgrx&vWsmC%L}WYDq42bZ|836>QI z)&d9vjF1^`IFyOtlRmBv;0;t^iL{XYQ9GNF#_*{+{1G43L|($@s|P@zsV}kPlL&>Q zv1G(d>_E@LFcQ0)@LP%?A@k)m5LH#iS;Y-#7!duKUggb7#4?$>!1?(OM<<>@w}2N> z$qB85?$UBgkp15kh#C$x# zZYP$>MJt{QTYc?xb@H6axs>V6Kftv|FN371>?TRyiau@fr($E!9IbPh1^%^IsIhQt z>CUX<>J( Date: Mon, 24 Jan 2022 21:06:20 -0800 Subject: [PATCH 05/10] UFS, CMLFILESYS: Honor default extension and version for subdirectory enumeration --- sources/CMLFILESYS | 142 +++++++++-- sources/CMLFILESYS.LCOM | Bin 3470 -> 3730 bytes sources/UFS | 523 +++++++++++++++++++++++++++++----------- sources/UFS.LCOM | Bin 37196 -> 37417 bytes 4 files changed, 502 insertions(+), 163 deletions(-) diff --git a/sources/CMLFILESYS b/sources/CMLFILESYS index 8af2fbdb..23015c5e 100644 --- a/sources/CMLFILESYS +++ b/sources/CMLFILESYS @@ -1,37 +1,139 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(filecreated " 8-Jun-90 16:41:26" |{PELE:MV:ENVOS}SOURCES>CMLFILESYS.;4| 4326 - |changes| |to:| (functions cl:directory cl:user-homedir-pathname) +(FILECREATED "23-Jan-2022 12:32:16"  +|{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;4| 6055 - |previous| |date:| " 4-Jun-90 14:56:58" |{PELE:MV:ENVOS}SOURCES>CMLFILESYS.;3|) + :CHANGES-TO (FUNCTIONS CL:DIRECTORY) + + :PREVIOUS-DATE "22-Jan-2022 09:26:49" +|{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;3|) -; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. +; Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. -(prettycomprint cmlfilesyscoms) +(PRETTYCOMPRINT CMLFILESYSCOMS) -(rpaqq cmlfilesyscoms ((functions cl:directory cl:file-author cl:file-length cl:file-position cl:user-homedir-pathname cl:file-write-date) (functions cl:probe-file cl:rename-file cl:delete-file) (prop filetype cmlfilesys))) +(RPAQQ CMLFILESYSCOMS ((FUNCTIONS CL:DIRECTORY CL:FILE-AUTHOR CL:FILE-LENGTH CL:FILE-POSITION + CL:USER-HOMEDIR-PATHNAME CL:FILE-WRITE-DATE) + (FUNCTIONS CL:PROBE-FILE CL:RENAME-FILE CL:DELETE-FILE) + (PROP FILETYPE CMLFILESYS))) -(cl:defun cl:directory (pathname) (let (generator file) (declare (cl:special generator)) (resetlst (|if| (eql \\machinetype \\maiko) |then| (resetsave nil (quote (and resetstate (\\ufs.abort.cl-directory))))) (cl:setq generator (\\generatefiles (directory.fill.pattern (cl:namestring pathname)) nil (quote (sort resetlst)))) (|while| (setq file (\\generatenextfile generator)) |collect| (pathname file))))) +(CL:DEFUN CL:DIRECTORY (PATHNAME &KEY CL::DEFAULTEXT CL::DEFAULTVERS) + (* \; "Edited 23-Jan-2022 12:32 by rmk") + (* \; "Edited 22-Jan-2022 09:26 by rmk") + (LET (GENERATOR FILE) + (DECLARE (CL:SPECIAL GENERATOR)) + (RESETLST + (CL:WHEN (EQL \\MACHINETYPE \\MAIKO) + (RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY)))) + (CL:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (CL:NAMESTRING PATHNAME) + CL::DEFAULTEXT CL::DEFAULTVERS) + NIL + '(SORT RESETLST))) + (|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE))))) -(cl:defun cl:file-author (cl::file) (* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.") (let ((cl::author (getfileinfo cl::file (quote author)))) (cl:if cl::author (coerce cl::author (quote cl:simple-string)) nil))) +(CL:DEFUN CL:FILE-AUTHOR (CL::FILE) -(cl:defun cl:file-length (file-stream) (|if| (and (streamp file-stream) (openp file-stream)) |then| (geteofptr file-stream))) +(* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.") -(cl:defun cl:file-position (cl::file-stream &optional (cl:position nil cl::positionp)) (cl:unless (streamp cl::file-stream) (\\illegal.arg cl::file-stream)) (cl:if cl::positionp (cl:if (randaccessp cl::file-stream) (progn (setfileptr cl::file-stream (case cl:position (:start 0) (:end (geteofptr cl::file-stream)) (t cl:position))) t) nil) (getfileptr cl::file-stream))) + (LET ((CL::AUTHOR (GETFILEINFO CL::FILE 'AUTHOR))) + (CL:IF CL::AUTHOR + (COERCE CL::AUTHOR 'CL:SIMPLE-STRING) + NIL))) -(cl:defun cl:user-homedir-pathname (&optional host) (declare (globalvars loginhost/dir *default-pathname-defaults*)) (cl:if (machinetype (quote maiko)) (cl:if (and host (cl:string-not-equal (string host) (unix-getparm "HOSTNAME"))) nil (cl:make-pathname :host :dsk :directory (unpackfilename.string (unix-getenv "HOME") (quote directory) (quote return)))) (pathname (or loginhost/dir *default-pathname-defaults*)))) +(CL:DEFUN CL:FILE-LENGTH (FILE-STREAM) + (|if| (AND (STREAMP FILE-STREAM) + (OPENP FILE-STREAM)) + |then| (GETEOFPTR FILE-STREAM))) -(cl:defun cl:file-write-date (file) (* |;;| "Return file's creation date, or NIL if it doesn't exist.") (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time") (let ((tn (cl:probe-file file))) (cl:when tn (%convert-internal-time-to-clut (getfileinfo tn (quote icreationdate)))))) +(CL:DEFUN CL:FILE-POSITION (CL::FILE-STREAM &OPTIONAL (CL:POSITION NIL CL::POSITIONP)) + (CL:UNLESS (STREAMP CL::FILE-STREAM) + (\\ILLEGAL.ARG CL::FILE-STREAM)) + (CL:IF CL::POSITIONP + (CL:IF (RANDACCESSP CL::FILE-STREAM) + (PROGN (SETFILEPTR CL::FILE-STREAM (CASE CL:POSITION + (:START 0) + (:END (GETEOFPTR CL::FILE-STREAM)) + (T CL:POSITION))) + T) + NIL) + (GETFILEPTR CL::FILE-STREAM))) -(cl:defun cl:probe-file (file) (* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.") (if (streamp file) then (if (openp file) then (pathname (fetch (stream fullname) of file)) else (let ((namestring-if-exists (infilep (fetch (stream fullname) of file)))) (and namestring-if-exists (pathname namestring-if-exists)))) else (let ((infilep (\\getfilename file (quote old)))) (if infilep then (pathname infilep) else nil)))) +(CL:DEFUN CL:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST) + (DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*)) + (CL:IF (MACHINETYPE 'MAIKO) + (CL:IF (AND HOST (CL:STRING-NOT-EQUAL (STRING HOST) + (UNIX-GETPARM "HOSTNAME"))) + NIL + (CL:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME") + 'DIRECTORY + 'RETURN))) + (PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*)))) -(cl:defun cl:rename-file (file new-name) (* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.") (let ((old-pathname (pathname file)) (cl::new-fullname)) (if (streamp file) then (if (openp file) then (cl:error "Renaming open streams is not supported: ~S" file) else (setq cl::new-fullname (renamefile (setq file (fetch (stream fullname) of file)) new-name))) else (setq cl::new-fullname (renamefile file new-name))) (if cl::new-fullname then (cl:values (cl:merge-pathnames new-name file) old-pathname (pathname cl::new-fullname)) else (cl:error "Rename failed")))) +(CL:DEFUN CL:FILE-WRITE-DATE (FILE) -(cl:defun cl:delete-file (file) (* * "Delete the specified file.") (let ((tn (cl:probe-file file))) (cl:when (streamp file) (cl:close file :abort t)) (cl:if tn (let ((ns (interlisp-namestring tn))) (cl:unless (delfile ns) (cl:error "Could not delete the file ~S" file))) (cl:unless (streamp file) (cl:error "File to be deleted does not exist: ~S" file)))) t) + (* |;;| "Return file's creation date, or NIL if it doesn't exist.") -(putprops cmlfilesys filetype cl:compile-file) -(putprops cmlfilesys copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) -(declare\: dontcopy - (filemap (nil))) -stop + (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time") + + (LET ((TN (CL:PROBE-FILE FILE))) + (CL:WHEN TN + (%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE))))) + +(CL:DEFUN CL:PROBE-FILE (FILE) + +(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.") + + (IF (STREAMP FILE) + THEN (IF (OPENP FILE) + THEN (PATHNAME (FETCH (STREAM FULLNAME) OF FILE)) + ELSE (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH (STREAM FULLNAME) OF FILE)))) + (AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS)))) + ELSE (LET ((INFILEP (\\GETFILENAME FILE 'OLD))) + (IF INFILEP + THEN (PATHNAME INFILEP) + ELSE NIL)))) + +(CL:DEFUN CL:RENAME-FILE (FILE NEW-NAME) + +(* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.") + + (LET ((OLD-PATHNAME (PATHNAME FILE)) + (CL::NEW-FULLNAME)) + (IF (STREAMP FILE) + THEN (IF (OPENP FILE) + THEN (CL:ERROR "Renaming open streams is not supported: ~S" FILE) + ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE (SETQ FILE (FETCH (STREAM FULLNAME) + OF FILE)) + NEW-NAME))) + ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE FILE NEW-NAME))) + (IF CL::NEW-FULLNAME + THEN (CL:VALUES (CL:MERGE-PATHNAMES NEW-NAME FILE) + OLD-PATHNAME + (PATHNAME CL::NEW-FULLNAME)) + ELSE (CL:ERROR "Rename failed")))) + +(CL:DEFUN CL:DELETE-FILE (FILE) + + (* * "Delete the specified file.") + + (LET ((TN (CL:PROBE-FILE FILE))) + (CL:WHEN (STREAMP FILE) + (CL:CLOSE FILE :ABORT T)) + (CL:IF TN + (LET ((NS (INTERLISP-NAMESTRING TN))) + (CL:UNLESS (DELFILE NS) + (CL:ERROR "Could not delete the file ~S" FILE))) + (CL:UNLESS (STREAMP FILE) + (CL:ERROR "File to be deleted does not exist: ~S" FILE)))) + T) + +(PUTPROPS CMLFILESYS FILETYPE CL:COMPILE-FILE) +(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (751 1642 (CL:DIRECTORY 751 . 1642)) (1644 1950 (CL:FILE-AUTHOR 1644 . 1950)) (1952 2113 + (CL:FILE-LENGTH 1952 . 2113)) (2115 2709 (CL:FILE-POSITION 2115 . 2709)) (2711 3302 ( +CL:USER-HOMEDIR-PATHNAME 2711 . 3302)) (3304 3662 (CL:FILE-WRITE-DATE 3304 . 3662)) (3664 4329 ( +CL:PROBE-FILE 3664 . 4329)) (4331 5387 (CL:RENAME-FILE 4331 . 5387)) (5389 5894 (CL:DELETE-FILE 5389 + . 5894))))) +STOP diff --git a/sources/CMLFILESYS.LCOM b/sources/CMLFILESYS.LCOM index d7c258b0cad159f71a0cabd3758f541297dccd94..28fb3e3142ff8cb7bf5bceedcd9cb0b1cf5286a5 100644 GIT binary patch delta 1458 zcmb_cO>Y}z5cX$CHZ{Uh5&eXzPrH%U+Apu|1zBwE*YPI%mEE=7DCuDpyJ;0Cj^c8t zF!F&r0#-=;0q#+eKtKR-;lhPO4;=Uf?V(7$RjS17yDfHm;8Y*hJMYZS%=64M?`N04 zy!yF5V;Ht=n55|uJs>S8Nix3?9`TYONgzs^ENPWW3E0x!`0)77XgGlJ5tM+Le%$gm zKlz|L8JQex91cdqdvdwbIK0OvMq@Jm=wxp=X*4Y}F6M9h<@c2- zht+1%LOEHJL`}wWOsVNuE=KZk_@D&SJ4aI}wY#PX(!v+zav6Pt@a}Mc?nRGCb16cJ z`+s~h1SqPn2@t44r2<;BqucAm=K}}WcGqqOhGYA{G)=8#c%&IP-ZlrC>ye(}%(_0` zLgruYUZ`u5swwr?(w96%4m?-i+JZU%$gdA9+m2Q%=A=(nD1PvKl?ia_=y#f-XyMb_|>L ziugd0qP5(IvzJ(=EwU!C0!;bvWPie==3JCDc*G}xAH>9?ErM@o+8RAa4U6g2L0HuD zol)keA2&Ci+*fWF(@SXmd}a;IC-=2qZx^qv^e+{!or@mlF3vUw;eHB#|9msbJlHus zJNPR+J$ruil@(jRSm?QVdYWQYnIfbByLR8OTS#)uVGkh&P?3{{U#OGL7fG$7m|MwU z=@hH#e>UL}mQs5)Eq+9`63>g*yFmv@qB=RqZ=lS+%fE}$n@5<$UJp7+#G|}_m9Y(T z(eFCG5pPctv9t911%_1>&`1mb|8as|Kx?9cFXrM(-}c_frLok`@))0gEMK}1OM>>( z_l$rf+eUkOwtTb7us95Z-hNmo-o#i;vI>%@RF#^nDplGp?#A`xHcEQ=V&!{GZ!lM0 z;PFVTU3y<75mV-A0hL+-Kft@y;+W{uRdSx{li-RihW@?!Cx%M6Qu=i#1{D2p&cXC6 Ng)%;Cg{?d#=3l}bh*bap delta 1178 zcmai!OK%fN5XWuD80Rr4k%D-H>=r|WY>BaEJdZd{h#2e!kMTU1=>&p!D6*|2QpiLJ zK|%})C%B>2j`p@60trRzA|Y;E;UmC>0~hX`sBS|7T=1bh(^cK|tNK^Z-;+-#{<3$Z z(nY6D>mjunZGc=gmDbX_GE)OhCF(RWYBH4MPJCx$b*CQQ zW^ZmQ-rnr=w&v}km8JFN-c|xqayKRkq-S#z>G|T} zn`KBgHhcG0<85>bI`qn5?4>q{X%Q2s;U8L)TDHBV0no5unZYCkWY69{@fYN;BO`7c9@$^aZJrIvDz8g z%{NEI<4b3Eu(fi0@xNyuTc`hj_90WUEC_7Y^lX=cX~K;gm#9ZWoCuFzV>|~K#t*AP zWzcol!>Zs?yOJ*Cj~$UpJk+)8O~<2bF`%du=rif#{P|P7mc2cqic$augfyZoVwewt z^vb~aP5@QlN?mI@5rY6U5D)>V@Qut5!NIpZ>Wg6R@4$|nJdn*~#~?dDb~3-rTOleJ zrpRAkPZhGGnG$LpIfMv+dGD&@HK3}&F!C>8euk5jjuytxNF`1CH4w`x^LjX$V$ZWC zA_-mMLJOsPS@;86u^-W<-X+%TM|>_slalAOfAj}_u_&am_Ia_X$}n zEZ3MeYPw}i3)Ud?FZ8cwfA2p-FYtJG_{8^OLdvH^T;6`fqv0kaplan>Local>medley3.5>git-medley>sources>UFS.;5 69271 - changes to%: (FNS \UFSeol) +(FILECREATED "22-Jan-2022 09:06:35" {DSK}kaplan>Local>medley3.5>my-medley>sources>UFS.;4 79559 - previous date%: "20-Apr-2021 12:11:36" -{DSK}kaplan>Local>medley3.5>git-medley>sources>UFS.;4) + :CHANGES-TO (FNS \UFSGenerateFiles \UFS.NEXTFILEFN) + + :PREVIOUS-DATE "22-Jan-2022 08:36:27" +{DSK}kaplan>Local>medley3.5>my-medley>sources>UFS.;3) (* ; " @@ -19,7 +20,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) DIRECTORY FILEIO)) (INITVARS (\UFS.DEFAULT.EOLC NIL)) - (COMS (* ; "Create FDEV function.") + (COMS (* ; "Create FDEV function.") (FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice) (INITVARS (\UFSdevice) (\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor"))) @@ -27,15 +28,14 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE))) (INITRECORDS UFSGENFILESTATE) (SYSRECORDS UFSGENFILESTATE)) - (COMS (* ; - "UNIX File System's FDEV methods.") + (COMS (* ; "UNIX File System's FDEV methods.") (FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile \UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages \UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS \UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP \UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY \UFS.CLEANUP.GFS.TABLE)) - (COMS (* ; "File Name parsing") + (COMS (* ; "File Name parsing") (FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY \UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD \UFS.HANDLE.RELATIVEDIRECTORY) @@ -56,22 +56,22 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. \UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE *DSK-HOST-NAME* *UFS-HOST-NAME*)) (COMS - (* ;; "Change UNIX Curent Directory") + (* ;; "Change UNIX Curent Directory") (FNS CHDIR) - (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") + (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") (FNS \DEVICEFILE.EOSERROR) - (* ;; "flush/revalidate unvisible stream, like dribble files.") + (* ;; "flush/revalidate unvisible stream, like dribble files.") (FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS) - (* ;; " Error handler") + (* ;; " Error handler") (FNS \UFSError)) - (COMS (* ; "File Type and EOL handling") + (COMS (* ; "File Type and EOL handling") (FNS \UFSGetFileType \UFSSetFileType \UFSeol) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY) (DEFAULTFILETYPELIST '((NIL . BINARY) @@ -110,11 +110,11 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (VM . BINARY] (GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST)) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS)) - (COMS (* ; "Filetypepatch functions. ") + (COMS (* ; "Filetypepatch functions. ") (FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu) - (* ; "for hardcopy") + (* ; "for hardcopy") (FNS \UFStoOtherCopyMess \UFStoOtherRenameMess) - (* ; "for copyfile,renamefile") + (* ; "for copyfile,renamefile") (INITVARS (FileTypeConfirmFlg T)) (GLOBALVARS FileTypeMenu FileTypeConfirmFlg)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) @@ -166,35 +166,38 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (DATATYPE UFSGENFILESTATE ( - (* ;; - "Holds the file-directory-generator state for %"Unix%" file system enumeration.") + (* ;; + "Holds the file-directory-generator state for %"Unix%" file system enumeration.") - (FINFOID FIXP) - (FILEID FIXP) (* ; - "Current file in list of 1 to TOTALNUM files.") - (TOTALNUM FIXP) - DIRECTORY DEV (PROPP FLAG) - THISFILE - (ERRONO FIXP) - NAME - (LENGTH FIXP) - (WDATE FIXP) - (RDATE FIXP) - (PROTECTION FIXP) - AUTHOR - (AULEN FIXP) - SUBGENERATORS (* ; -"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.") - CURRENT-DEPTH (* ; - "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH") - MAX-DEPTH (* ; - "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.") - )) + (FINFOID FIXP) + (FILEID FIXP) (* ; + "Current file in list of 1 to TOTALNUM files.") + (TOTALNUM FIXP) + DIRECTORY DEV (PROPP FLAG) + THISFILE + (ERRONO FIXP) + NAME + (LENGTH FIXP) + (WDATE FIXP) + (RDATE FIXP) + (PROTECTION FIXP) + AUTHOR + (AULEN FIXP) + SUBGENERATORS (* ; + "A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.") + CURRENT-DEPTH (* ; + "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH") + MAX-DEPTH (* ; + "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.") + DEFAULTEXT (* ; + "Value of DEFAULTEXT, so we can propagate it through subdirectories") + DEFAULTVERS (* ; "Value of DEFAULTVERS") + )) ) (/DECLAREDATATYPE 'UFSGENFILESTATE '(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP - POINTER POINTER POINTER) + POINTER POINTER POINTER POINTER POINTER) '((UFSGENFILESTATE 0 FIXP) (UFSGENFILESTATE 2 FIXP) (UFSGENFILESTATE 4 FIXP) @@ -212,8 +215,10 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (UFSGENFILESTATE 26 FIXP) (UFSGENFILESTATE 28 POINTER) (UFSGENFILESTATE 30 POINTER) - (UFSGENFILESTATE 32 POINTER)) - '34) + (UFSGENFILESTATE 32 POINTER) + (UFSGENFILESTATE 34 POINTER) + (UFSGENFILESTATE 36 POINTER)) + '38) (* "END EXPORTED DEFINITIONS") @@ -221,7 +226,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (/DECLAREDATATYPE 'UFSGENFILESTATE '(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP - POINTER POINTER POINTER) + POINTER POINTER POINTER POINTER POINTER) '((UFSGENFILESTATE 0 FIXP) (UFSGENFILESTATE 2 FIXP) (UFSGENFILESTATE 4 FIXP) @@ -239,24 +244,26 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. (UFSGENFILESTATE 26 FIXP) (UFSGENFILESTATE 28 POINTER) (UFSGENFILESTATE 30 POINTER) - (UFSGENFILESTATE 32 POINTER)) - '34) + (UFSGENFILESTATE 32 POINTER) + (UFSGENFILESTATE 34 POINTER) + (UFSGENFILESTATE 36 POINTER)) + '38) (ADDTOVAR SYSTEMRECLST (DATATYPE UFSGENFILESTATE ((FINFOID FIXP) - (FILEID FIXP) - (TOTALNUM FIXP) - DIRECTORY DEV (PROPP FLAG) - THISFILE - (ERRONO FIXP) - NAME - (LENGTH FIXP) - (WDATE FIXP) - (RDATE FIXP) - (PROTECTION FIXP) - AUTHOR - (AULEN FIXP) - SUBGENERATORS CURRENT-DEPTH MAX-DEPTH)) + (FILEID FIXP) + (TOTALNUM FIXP) + DIRECTORY DEV (PROPP FLAG) + THISFILE + (ERRONO FIXP) + NAME + (LENGTH FIXP) + (WDATE FIXP) + (RDATE FIXP) + (PROTECTION FIXP) + AUTHOR + (AULEN FIXP) + SUBGENERATORS CURRENT-DEPTH MAX-DEPTH DEFAULTEXT DEFAULTVERS)) ) @@ -330,12 +337,244 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. ) (\UFSGenerateFiles -(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 27-Sep-93 16:17 by jds") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (DEVICE (LISTGET PARSED (QUOTE DEVICE))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) (SETQ FILTER (COND ((STREQUAL DIRECTORY "<") (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" (OR DEVICE "") "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (T (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE DEVICE) DEVICE (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))))) (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) (COND ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR)))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND ((< TOTALNUM 0) (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR)))) (T (COND ((ZEROP TOTALNUM) (RETURN (\NULLFILEGENERATOR))) (T (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN)) CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH)))))))))))) -) + [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) + + (* ;; + "Edited 22-Jan-2022 09:06 by rmk: Capture current free values of DEFAULTEXT and DEFAULTVERS") + + (* ;; "Edited 27-Sep-93 16:17 by jds") + + (DECLARE (SPECVARS DEFAULTEXT DEFAULTVERS)) + +(* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") + + (WITH.MONITOR (\UFSGetMonitor FDEV) + [PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) + (DIRECTORY (OR (LISTGET PARSED 'DIRECTORY) + (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY) + FDEV) + (\UFS.DEFAULT.DIR FDEV))) + (DEVICE (LISTGET PARSED 'DEVICE)) + (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) + FILTER LEN) + (COND + ((STREQUAL DIRECTORY "/") + (SETQ DIRECTORY "<"))) + [SETQ FILTER (COND + [(STREQUAL DIRECTORY "<") + (CONCAT "{" (LISTGET PARSED 'HOST) + "}" + (OR DEVICE "") + "<" + (PACKFILENAME.STRING 'NAME (OR (LISTGET PARSED 'NAME) + "*") + 'EXTENSION + (OR (LISTGET PARSED 'EXTENSION) + "*") + 'VERSION + (OR (LISTGET PARSED 'VERSION) + "*"] + (T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET + PARSED + 'HOST) + 'DEVICE DEVICE 'NAME (OR (LISTGET PARSED 'NAME) + "*") + 'EXTENSION + (OR (LISTGET PARSED 'EXTENSION) + "*") + 'VERSION + (OR (LISTGET PARSED 'VERSION) + "*"] + (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") + DIRECTORY) + NAMEAREA FDEV)) + [COND + ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") + (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") + (RETURN (\NULLFILEGENERATOR] + (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) + + (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") + + (LET ((ID (CREATECELL \FIXP)) + (ERRNO (CREATECELL \FIXP)) + (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) + TOTALNUM) + (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) + (COND + [(< TOTALNUM 0) + (OR (\UFSError DIRECTORY ERRNO FDEV) + (RETURN (\NULLFILEGENERATOR] + (T (COND + ((ZEROP TOTALNUM) + (RETURN (\NULLFILEGENERATOR))) + (T [AND (OR (AND (NOT (LISTP OPTIONS)) + (EQ OPTIONS 'RESETLST)) + (FMEMB 'RESETLST OPTIONS)) + (RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID] + (RETURN (create FILEGENOBJ + NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) + FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) + GENFILESTATE _ + (\UFS.REGISTER.GFS (create UFSGENFILESTATE + FINFOID _ ID + FILEID _ 0 + TOTALNUM _ TOTALNUM + DIRECTORY _ DIRECTORY + DEV _ FDEV + PROPP _ PROPP + NAME _ (ALLOCSTRING + MAX-PATHNAME-LEN + ) + AUTHOR _ (AND PROPP + (ALLOCSTRING + MAX-UNAME-LEN + )) + CURRENT-DEPTH _ 1 + MAX-DEPTH _ + FILING.ENUMERATION.DEPTH + DEFAULTEXT _ DEFAULTEXT + DEFAULTVERS _ DEFAULTVERS])]) (\UFS.NEXTFILEFN -(LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE))) (DECLARE (SPECVARS FILEGROUP)) (COND (SUBGEN (* ;; "We're in a sub-directory.") (LET (FILENAME NAMELEN NEWWNAME FILEGROUP) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))))) (T (* ;; "Not in a sub-directory, so act directly on the top-level generator.") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (QUOTE *)) (DEFAULTVERS (QUOTE *)) (DESIREDPROPS (COND ((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (QUOTE (SIZE CREATIONDATE AUTHOR))) (T NIL)))) (DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS)) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (COND ((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))) (COND ((= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T)) (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))) (COND ((AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) T) (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE) (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))) (IEQP (CHARCODE >) (NTHCHARCODE FILENAME (NCHARS FILENAME))) (DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP))) (* ;; "It's a directory, so let's recurse into it.") (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))) (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE))) (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)))) (T (COND (NAMEONLY NEWNAME) (T FILENAME)))))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))))))) -) + [LAMBDA (GENFILESTATE NAMEONLY) + + (* ;; + "Edited 22-Jan-2022 09:05 by rmk: Bind DEFAULTEXT and DEFAULTVERS to values in GENFILESTATE") + + (* ;; "Edited 7-Oct-93 14:31 by jds") + + (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") + + (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE))) + (DECLARE (SPECVARS FILEGROUP)) + (COND + [SUBGEN + + (* ;; "We're in a sub-directory.") + + (LET (FILENAME NAMELEN NEWWNAME FILEGROUP) + (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) + (COND + (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) + (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE + with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) + (replace (UFSGENFILESTATE RDATE) of GENFILESTATE + with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) + (replace (UFSGENFILESTATE WDATE) of GENFILESTATE + with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) + (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE + with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) + (replace (UFSGENFILESTATE AULEN) of GENFILESTATE + with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) + (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE + with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) + FILENAME) + (T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) + (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY] + (T + (* ;; "Not in a sub-directory, so act directly on the top-level generator.") + + (LET* [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) + (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) + (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) + FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (FETCH (UFSGENFILESTATE + DEFAULTEXT) + OF GENFILESTATE)) + (DEFAULTVERS (FETCH (UFSGENFILESTATE DEFAULTVERS) OF GENFILESTATE)) + (DESIREDPROPS (COND + ((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) + '(SIZE CREATIONDATE AUTHOR)) + (T NIL] + (DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS)) + (AND (> FINFOID -1) + (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) + (CL:UNWIND-PROTECT + [COND + ((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) + 0) + [replace (UFSGENFILESTATE THISFILE) of GENFILESTATE + with (SETQ FILENAME (\UFS.FULLNAME.M + (fetch (UFSGENFILESTATE DIRECTORY) + of GENFILESTATE) + (SETQ NEWNAME (CL:SUBSEQ + (fetch (UFSGENFILESTATE + NAME) of + GENFILESTATE + ) + 0 NAMELEN)) + (fetch (UFSGENFILESTATE DEV) of + GENFILESTATE + ] + (COND + ((= (add FILEID 1) + (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) + (* ; "Generator exhausted. ") + (\UFS.UNREGISTER.GFS GENFILESTATE T)) + (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE + with FILEID))) + (COND + [(AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) + of GENFILESTATE) + T) + (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH + ) of GENFILESTATE) + (fetch (UFSGENFILESTATE MAX-DEPTH) + of GENFILESTATE))) + (IEQP (CHARCODE >) + (NTHCHARCODE FILENAME (NCHARS FILENAME))) + (DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE) + of GENFILESTATE)) + (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP))) + + (* ;; "It's a directory, so let's recurse into it.") + + [replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE + with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) + of (CAR FILEGROUP] + (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN + with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) + of GENFILESTATE))) + (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN + with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) + (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) + (COND + (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) + of GENFILESTATE) + (replace (UFSGENFILESTATE LENGTH) of + GENFILESTATE + with (fetch (UFSGENFILESTATE LENGTH) + of SUBGEN)) + (replace (UFSGENFILESTATE RDATE) of + GENFILESTATE + with (fetch (UFSGENFILESTATE RDATE) + of SUBGEN)) + (replace (UFSGENFILESTATE WDATE) of + GENFILESTATE + with (fetch (UFSGENFILESTATE WDATE) + of SUBGEN)) + (replace (UFSGENFILESTATE PROTECTION) + of GENFILESTATE with (fetch ( + UFSGENFILESTATE + PROTECTION) + of SUBGEN)) + (replace (UFSGENFILESTATE AULEN) of + GENFILESTATE + with (fetch (UFSGENFILESTATE AULEN) + of SUBGEN)) + (replace (UFSGENFILESTATE AUTHOR) of + GENFILESTATE + with (fetch (UFSGENFILESTATE AUTHOR) + of SUBGEN))) + FILENAME) + (NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of + GENFILESTATE + with NIL) + (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY] + (T (COND + (NAMEONLY NEWNAME) + (T FILENAME] + (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))]) (\UFS.FILEINFOFN (LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T))))) @@ -574,7 +813,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap \UFS.DIRECTORY.RECOGNIZER DSKP) (RECORDS UFSSTREAM NAME&ALLPROPS) - (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") + (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") (CONSTANTS (ATTR-LENGTH 1) (ATTR-WDATE 2) @@ -585,7 +824,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (ATTR-EOL 7) (ATTR-ALL 8)) - (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") + (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") (CONSTANTS (RECOG-OLD 0) (RECOG-OLDEST 1) @@ -594,7 +833,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (RECOG-OTHER 4) (RECOG-NON 5)) - (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") + (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") (CONSTANTS (ACCESS-INPUT 0) (ACCESS-OUTPUT 1) @@ -602,95 +841,93 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (ACCESS-APPEND 3) (ACCESS-OTHER 4)) - (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") + (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") (CONSTANTS (MAX-UNAME-LEN 512)) - (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") + (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") (CONSTANTS (MAX-PATHNAME-LEN 256)) (FILES (LOADCOMP) PMAP) - (* ; "For \devicefile.eoserror"))) + (* ; "For \devicefile.eoserror"))) (DECLARE%: EVAL@COMPILE (PUTPROPS \UFS.FULLNAME.M MACRO [LAMBDA (DIR NAME DEV ATOMP) - (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) + (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) - (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") + (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") + + (COND + (NAME (* ; "Pass NIL thru transparently") + (COND + [(DSKP DEV) + (SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME)) + (COND + [*DSK-UPPER-CASE-FILE-NAMES* + + (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") - (COND - (NAME (* ; "Pass NIL thru transparently") (COND - [(DSKP DEV) - (SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME)) - (COND - [*DSK-UPPER-CASE-FILE-NAMES* - - (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") - - (COND - (ATOMP (MKATOM (U-CASE NAME))) - (T (U-CASE NAME] - (T (COND - (ATOMP (MKATOM NAME)) - (T NAME] - (T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME) - ) - (COND - (ATOMP (MKATOM NAME)) - (T NAME]) + (ATOMP (MKATOM (U-CASE NAME))) + (T (U-CASE NAME] + (T (COND + (ATOMP (MKATOM NAME)) + (T NAME] + (T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME)) + (COND + (ATOMP (MKATOM NAME)) + (T NAME]) (PUTPROPS \UFSGetMonitor MACRO ((DEV) - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK \DSKtopMonitor) - (UNIX \UFStopMonitor) - NIL))) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK \DSKtopMonitor) + (UNIX \UFStopMonitor) + NIL))) (PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV) - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK \DSK.DEFAULT.DIRECTORY) - (UNIX \UFS.DEFAULT.DIRECTORY) - NIL))) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK \DSK.DEFAULT.DIRECTORY) + (UNIX \UFS.DEFAULT.DIRECTORY) + NIL))) (PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV) - (* ;; - "Return a function that will do name recognition for this device") + (* ;; + "Return a function that will do name recognition for this device") - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK (FUNCTION \DSKGetFileName-C)) - (UNIX (FUNCTION \UFSGetFileName-C)) - (FUNCTION SHOULDNT)))) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK (FUNCTION \DSKGetFileName-C)) + (UNIX (FUNCTION \UFSGetFileName-C)) + (FUNCTION SHOULDNT)))) (PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV) - (SELECTQ (fetch (FDEV DEVICENAME) of - DEV) - (DSK (FUNCTION \DSKDirectoryNameP-C)) - (UNIX (FUNCTION \UFSDirectoryNameP-C)) - (FUNCTION SHOULDNT)))) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK (FUNCTION \DSKDirectoryNameP-C)) + (UNIX (FUNCTION \UFSDirectoryNameP-C)) + (FUNCTION SHOULDNT)))) (PUTPROPS DSKP MACRO ((DEV) - (EQ (fetch (FDEV DEVICENAME) of DEV) - 'DSK))) + (EQ (fetch (FDEV DEVICENAME) of DEV) + 'DSK))) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS UFSSTREAM ( - (* ;; - "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.") + (* ;; + "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.") - (FILEID (fetch F1 of DATUM) - (REPLACE F1 OF DATUM WITH NEWVALUE)) - (* ; "Unix file handle") - (CDATE (fetch F2 of DATUM) - (REPLACE F2 OF DATUM WITH NEWVALUE)) - (* ; "IDate given to openstream") - (UNIXNAME (fetch F5 of DATUM) - (REPLACE F5 OF DATUM WITH NEWVALUE)) - (* ; - "The name by which Unix knows this file") - )) + (FILEID (fetch F1 of DATUM) + (REPLACE F1 OF DATUM WITH NEWVALUE)) + (* ; "Unix file handle") + (CDATE (fetch F2 of DATUM) + (REPLACE F2 OF DATUM WITH NEWVALUE)) + (* ; "IDate given to openstream") + (UNIXNAME (fetch F5 of DATUM) + (REPLACE F5 OF DATUM WITH NEWVALUE)) + (* ; + "The name by which Unix knows this file") + )) (RECORD NAME&ALLPROPS (NAME . ALLPROPS)) ) @@ -876,23 +1113,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000 2021 )) (DECLARE%: DONTCOPY - (FILEMAP (NIL (8248 9801 (\UFSCreateDevice 8258 . 8623) (\UFS.CREATE.DEVICE 8625 . 9481) ( -\UFSOpenDevice 9483 . 9660) (\UFSCloseDevice 9662 . 9799)) (13962 41872 (\UFSOpenFile 13972 . 17266) ( -\UFS.OPENP 17268 . 17765) (\UFS.RECOGNIZE.FILE 17767 . 18520) (\UFS.DIRECTORY.NAME 18522 . 19265) ( -\UFSCloseFile 19267 . 20243) (\UFSGetFileName 20245 . 20444) (\UFSDeleteFile 20446 . 20986) ( -\UFSRenameFile 20988 . 22153) (\UFSReadPages 22155 . 23290) (\UFSWritePages 23292 . 24512) ( -\UFSTruncateFile 24514 . 26011) (\UFSDirectoryNameP 26013 . 27067) (\UFSEventFn 27069 . 27731) ( -\UFSGetFileInfo 27733 . 30015) (\UFS.CREATE.PROPS 30017 . 30370) (\UFSSetFileInfo 30372 . 31601) ( -\UFSGenerateFiles 31603 . 34315) (\UFS.NEXTFILEFN 34317 . 38460) (\UFS.FILEINFOFN 38462 . 39911) ( -\UFS.VALID.PROPP 39913 . 40205) (\UFS.REGISTER.GFS 40207 . 40462) (\UFS.UNREGISTER.GFS 40464 . 41047) -(\UFS.ABORT.DIRECTORY 41049 . 41397) (\UFS.ABORT.CL-DIRECTORY 41399 . 41686) (\UFS.CLEANUP.GFS.TABLE -41688 . 41870)) (41907 48591 (\UFSMakeUnixFormatName 41917 . 42938) (\UFSParseNameString 42940 . 43314 -) (\UFSParse-Directory 43316 . 43857) (\UFS.PARSE.BODY 43859 . 44404) (\UFS.ADJUST.HOST 44406 . 44565) - (\UFS.FULLNAME 44567 . 45775) (\UFS.ADD.HOST.FIELD 45777 . 46137) (\UFS.REMOVE.HOST.FIELD 46139 . -47809) (\UFS.HANDLE.RELATIVEDIRECTORY 47811 . 48589)) (49407 50020 (CHDIR 49417 . 50018)) (50092 51078 - (\DEVICEFILE.EOSERROR 50102 . 51076)) (51151 52388 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51161 . 52006) - (\UNVISIBLE.FLUSH.OPEN.STREAMS 52008 . 52386)) (52421 54047 (\UFSError 52431 . 54045)) (54091 56338 ( -\UFSGetFileType 54101 . 54702) (\UFSSetFileType 54704 . 55133) (\UFSeol 55135 . 56336)) (65950 67074 ( -\UFSGetPrintFileType 65960 . 66372) (\UFSGetFileTypeConfirm 66374 . 66822) (\UFSPrintTypeMenu 66824 . -67072)) (67104 68852 (\UFStoOtherCopyMess 67114 . 68105) (\UFStoOtherRenameMess 68107 . 68850))))) + (FILEMAP (NIL (8206 9759 (\UFSCreateDevice 8216 . 8581) (\UFS.CREATE.DEVICE 8583 . 9439) ( +\UFSOpenDevice 9441 . 9618) (\UFSCloseDevice 9620 . 9757)) (14300 52622 (\UFSOpenFile 14310 . 17604) ( +\UFS.OPENP 17606 . 18103) (\UFS.RECOGNIZE.FILE 18105 . 18858) (\UFS.DIRECTORY.NAME 18860 . 19603) ( +\UFSCloseFile 19605 . 20581) (\UFSGetFileName 20583 . 20782) (\UFSDeleteFile 20784 . 21324) ( +\UFSRenameFile 21326 . 22491) (\UFSReadPages 22493 . 23628) (\UFSWritePages 23630 . 24850) ( +\UFSTruncateFile 24852 . 26349) (\UFSDirectoryNameP 26351 . 27405) (\UFSEventFn 27407 . 28069) ( +\UFSGetFileInfo 28071 . 30353) (\UFS.CREATE.PROPS 30355 . 30708) (\UFSSetFileInfo 30710 . 31939) ( +\UFSGenerateFiles 31941 . 38373) (\UFS.NEXTFILEFN 38375 . 49210) (\UFS.FILEINFOFN 49212 . 50661) ( +\UFS.VALID.PROPP 50663 . 50955) (\UFS.REGISTER.GFS 50957 . 51212) (\UFS.UNREGISTER.GFS 51214 . 51797) +(\UFS.ABORT.DIRECTORY 51799 . 52147) (\UFS.ABORT.CL-DIRECTORY 52149 . 52436) (\UFS.CLEANUP.GFS.TABLE +52438 . 52620)) (52657 59341 (\UFSMakeUnixFormatName 52667 . 53688) (\UFSParseNameString 53690 . 54064 +) (\UFSParse-Directory 54066 . 54607) (\UFS.PARSE.BODY 54609 . 55154) (\UFS.ADJUST.HOST 55156 . 55315) + (\UFS.FULLNAME 55317 . 56525) (\UFS.ADD.HOST.FIELD 56527 . 56887) (\UFS.REMOVE.HOST.FIELD 56889 . +58559) (\UFS.HANDLE.RELATIVEDIRECTORY 58561 . 59339)) (60157 60770 (CHDIR 60167 . 60768)) (60842 61828 + (\DEVICEFILE.EOSERROR 60852 . 61826)) (61901 63138 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61911 . 62756) + (\UNVISIBLE.FLUSH.OPEN.STREAMS 62758 . 63136)) (63171 64797 (\UFSError 63181 . 64795)) (64841 67088 ( +\UFSGetFileType 64851 . 65452) (\UFSSetFileType 65454 . 65883) (\UFSeol 65885 . 67086)) (76238 77362 ( +\UFSGetPrintFileType 76248 . 76660) (\UFSGetFileTypeConfirm 76662 . 77110) (\UFSPrintTypeMenu 77112 . +77360)) (77392 79140 (\UFStoOtherCopyMess 77402 . 78393) (\UFStoOtherRenameMess 78395 . 79138))))) STOP diff --git a/sources/UFS.LCOM b/sources/UFS.LCOM index a4cdd0657aef824e6c67a89eafd7c62421fd21af..392e967cb3de2d2372cab0e4cb0cd0bcc5b8aa55 100644 GIT binary patch delta 851 zcma)4%}*0S6n7RRuo}Wgk&mFhEQq@?t-G_^{X!5zXKA6fb$5#%AOJLi{5Y9-@lP;b^k7JwB_*25!Aa)jef-|RpK&i=aO=q) zUUX7vGUAe9pCmxQI65}H6vZ;eAX~Pq+iHB{iq0+GrT0-=Op_Qy{sY0-j+?e(3NW)W zd-?j}^1`**0`RkUmRD|`u<5tep2>wJ5S)BE4S(mwVle><)3+FSA3m%K(tq?Nz{YA% zrL#^A3@aYDfVW4I!V3Sr2YTBx9V}pK0eHA{W z2FJK*jc({27C4}okRV>lC5fDy&3U26VjgEWpZ3W`pV?U6vnPn_Nx*$N+z`CdzaZ30 zOXexGO<$Xv$At)N6)yBe1SZ8u?^eSBcDlNn=9>2+ zY|E;O0(r+9C7JN!cz*br*u?+(jD2vrT#XAF#xjWU1GZE;HQvnzUd}~=wQ+ust{3as zjkNI9^ZtI%ZN-I!gOXG5WC7LQ%PsJ}KFZ^<%M}!@G%(%O_c^nZx=n zjaxp$!Z*s@NDJi=9dg-J#wV^MNg$rjXW4+N89XmHqV~NVhdZyVKU{aP`RHlwZ?6*U AMgRZ+ delta 803 zcmZ{i?@JSL9LK%WG?$Z&G*dD^Tv>P7=H2&px9!x4xjUV%ZS6KO5Ms?sN7IdMNt$dzQ?VNi?iAaE5P{(wJMD?!87Y>2*$av&E0T|a^-G5`|MQnX4idlMfb4u` zan2}1rC=MfT1?;6GzxhRiX~$?S6C`4xQWM1i|MArk~-Q_#pHKdw2I(cZXXV?CitQD>U9rHDm9D z3w14ykJ3)Ouf3qAtmUzKs%frpc>zRT#_q_ET~1aMBk|R0 z(a8b{2>5pLfbIKr@?fZi(Om}?%9Qe`f!e><;kDKmB z0$OA`fuF1G2xbsZRQK2Oc4XM>K+`;GM_f%r{+(&V59VMyB;t`+N=srV#7~fG3XBf From 51f0c19ad161e8da9a7383e809dfea3bd682d1ca Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 21:07:01 -0800 Subject: [PATCH 06/10] DMISC: Generalize argument to FLASHWINDOW --- sources/DMISC | 117 ++++++++++++++++++++++++--------------------- sources/DMISC.LCOM | Bin 17733 -> 17796 bytes 2 files changed, 63 insertions(+), 54 deletions(-) diff --git a/sources/DMISC b/sources/DMISC index 91c0b8fe..ebf93839 100644 --- a/sources/DMISC +++ b/sources/DMISC @@ -1,13 +1,15 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "16-May-90 15:53:57" {DSK}local>lde>lispcore>sources>DMISC.;3 45292 - changes to%: (VARS DMISCCOMS) +(FILECREATED " 6-Jan-2022 19:08:15" {DSK}kaplan>Local>medley3.5>my-medley>sources>DMISC.;3 45512 - previous date%: " 6-Apr-90 10:59:19" {DSK}local>lde>lispcore>sources>DMISC.;2) + :CHANGES-TO (FNS FLASHWINDOW) + + :PREVIOUS-DATE "16-May-90 15:53:57" +{DSK}kaplan>Local>medley3.5>my-medley>sources>DMISC.;1) (* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1982-1990 by Venue & Xerox Corporation. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance @@ -41,7 +43,7 @@ with the terms of said license. (DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \PlayTimer)) (INITRESOURCES \PlayTimer) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ; - "Overrides definition in the shared MISC") + "Overrides definition in the shared MISC") (P (MOVD 'RINGBELLS 'PRINTBELLS] [COMS (* ; "Changing display") (FNS DISPLAYDOWN SETDISPLAYHEIGHT VIDEORATE) @@ -68,7 +70,7 @@ with the terms of said license. \MISC1.UFN \MISC2.UFN \MISC3.UFN \MISC4.UFN \MISC5.UFN \MISC6.UFN \MISC7.UFN \MISC8.UFN \MISC10.UFN) (* ; - "sub-functions of floating-point ufns") + "sub-functions of floating-point ufns") (FNS \BLKFDIFF.UFN \BLKFPLUS.UFN \BLKFTIMES.UFN \BLKSEP.UFN \BLKPERM.UFN \BLKEXPONENT.UFN \BLKFLOATP2COMP.UFN \BLKSMALLP2FLOAT.UFN \BLKMAG.UFN \FLOATTOBYTE.UFN \BLKFMAX.UFN \BLKFMIN.UFN \BLKFABSMAX.UFN \BLKFABSMIN.UFN) @@ -79,7 +81,7 @@ with the terms of said license. (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) - (LAMA \DIRTYBACKGROUND]) + (LAMA]) (DEFINEQ (BACKSPACEDEL @@ -226,28 +228,35 @@ with the terms of said license. (FLASHWINDOW NIL N]) (FLASHWINDOW - [LAMBDA (WIN? N FLASHINTERVAL SHADE) (* bvm%: "16-Jul-85 12:20") - (* ; "This is an 'attention getting' action.") - (* ; - "rrb --- added shade argument so contrast of flash could be explored.") + [LAMBDA (WIN? N FLASHINTERVAL SHADE) (* ; "Edited 6-Jan-2022 19:08 by rmk") + (* bvm%: "16-Jul-85 12:20") + (* ; + "This is an 'attention getting' action.") + (* ; + "rrb --- added shade argument so contrast of flash could be explored.") (OR (FIXP N) (SETQ N 1)) (OR (FIXP FLASHINTERVAL) (SETQ FLASHINTERVAL 200)) [COND - ((WINDOWP WIN?) - (SETQ WIN? (GETSTREAM WIN? 'OUTPUT] + (WIN? + (* ;; + "RMK: GETSTREAM even if not a window. Catches T, other streams. But NIL still means whole screen") + + (SETQ WIN? (GETSTREAM WIN? 'OUTPUT] (for I to N bind (WHOLEP _ (NOT (DISPLAYSTREAMP WIN?))) COLORP first [COND (WHOLEP (SETQ COLORP (NULL (VIDEOCOLOR] do (UNINTERRUPTABLY - (* ; - "Open-coded 'during' loops so that no one else can sneak in and steal cycles") + (* ; + "Open-coded 'during' loops so that no one else can sneak in and steal cycles") (COND - [WHOLEP (* ; "Flash the whole screen") + [WHOLEP (* ; "Flash the whole screen") (VIDEOCOLOR (PROG1 (VIDEOCOLOR COLORP) (DISMISS FLASHINTERVAL NIL T] - (T (* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer") + (T + (* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer") + (INVERTW WIN? SHADE) (DISMISS FLASHINTERVAL NIL T) (INVERTW WIN? SHADE)))) @@ -907,26 +916,26 @@ with the terms of said license. ) (RPAQQ RINGBELLS.L1 ((1000 . 1000) - (800 . 1000) - (600 . 1000) - (500 . 1000) - (400 . 1000) - (NIL . 500) - (440 . 1000) - (484 . 1000) - (540 . 1000) - (600 . 1000))) + (800 . 1000) + (600 . 1000) + (500 . 1000) + (400 . 1000) + (NIL . 500) + (440 . 1000) + (484 . 1000) + (540 . 1000) + (600 . 1000))) (RPAQQ RINGBELLS.L2 ((2000 . 1000) - (1600 . 1000) - (1200 . 1000) - (1000 . 1000) - (800 . 1000) - (NIL . 500) - (880 . 1000) - (968 . 1000) - (1080 . 1000) - (1188 . 1000))) + (1600 . 1000) + (1200 . 1000) + (1000 . 1000) + (800 . 1000) + (NIL . 500) + (880 . 1000) + (968 . 1000) + (1080 . 1000) + (1188 . 1000))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) @@ -937,27 +946,27 @@ with the terms of said license. (ADDTOVAR NLAML ) -(ADDTOVAR LAMA \DIRTYBACKGROUND) +(ADDTOVAR LAMA ) ) (PUTPROPS DMISC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4791 5494 (BACKSPACEDEL 4801 . 5492)) (5589 6022 (PERIODICALLYRECLAIM 5599 . 6020)) ( -6252 7943 (\DIRTYBACKGROUND 6262 . 6684) (\SAVEVMBACKGROUND 6686 . 7470) (COPYVM 7472 . 7941)) (8364 -9563 (SETTIME 8374 . 9561)) (9564 13243 (RINGBELLS 9574 . 10067) (FLASHWINDOW 10069 . 11645) (PLAYTUNE - 11647 . 13241)) (13505 19037 (DISPLAYDOWN 13515 . 13903) (SETDISPLAYHEIGHT 13905 . 16705) (VIDEORATE -16707 . 19035)) (19461 20182 (DOAROUNDEXITFORMS 19471 . 20180)) (20385 22100 (REALMEMORYSIZE 20395 . -20553) (LISPVERSION 20555 . 20708) (MICROCODEVERSION 20710 . 20868) (BCPLVERSION 20870 . 21023) ( -REQUIREVERSION 21025 . 22098)) (22137 26715 (APROPOS 22147 . 26163) (APROPRINT 26165 . 26713)) (26741 -30649 (READPRINTERPORT 26751 . 26892) (WRITEPRINTERPORT 26894 . 27049) (\READPRINTERPORT.UFN 27051 . -27240) (\WRITEPRINTERPORT.UFN 27242 . 27440) (\MISC1.UFN 27442 . 27595) (\MISC2.UFN 27597 . 27835) ( -\MISC3.UFN 27837 . 28570) (\MISC4.UFN 28572 . 29122) (\MISC5.UFN 29124 . 29277) (\MISC6.UFN 29279 . -29529) (\MISC7.UFN 29531 . 30016) (\MISC8.UFN 30018 . 30319) (\MISC10.UFN 30321 . 30647)) (30703 38152 - (\BLKFDIFF.UFN 30713 . 31278) (\BLKFPLUS.UFN 31280 . 31852) (\BLKFTIMES.UFN 31854 . 32429) ( -\BLKSEP.UFN 32431 . 33562) (\BLKPERM.UFN 33564 . 34033) (\BLKEXPONENT.UFN 34035 . 34445) ( -\BLKFLOATP2COMP.UFN 34447 . 35031) (\BLKSMALLP2FLOAT.UFN 35033 . 35392) (\BLKMAG.UFN 35394 . 36045) ( -\FLOATTOBYTE.UFN 36047 . 36626) (\BLKFMAX.UFN 36628 . 37020) (\BLKFMIN.UFN 37022 . 37411) ( -\BLKFABSMAX.UFN 37413 . 37782) (\BLKFABSMIN.UFN 37784 . 38150)) (38192 40010 (\P-MISC2.UFN 38202 . -38443) (\LINES-EQUAL-P 38445 . 38829) (\GET-NEXT-RUN 38831 . 40008)) (40011 44190 (IBLT1 40021 . 42023 -) (IBLT2 42025 . 44188))))) + (FILEMAP (NIL (4747 5450 (BACKSPACEDEL 4757 . 5448)) (5545 5978 (PERIODICALLYRECLAIM 5555 . 5976)) ( +6208 7899 (\DIRTYBACKGROUND 6218 . 6640) (\SAVEVMBACKGROUND 6642 . 7426) (COPYVM 7428 . 7897)) (8320 +9519 (SETTIME 8330 . 9517)) (9520 13551 (RINGBELLS 9530 . 10023) (FLASHWINDOW 10025 . 11953) (PLAYTUNE + 11955 . 13549)) (13813 19345 (DISPLAYDOWN 13823 . 14211) (SETDISPLAYHEIGHT 14213 . 17013) (VIDEORATE +17015 . 19343)) (19769 20490 (DOAROUNDEXITFORMS 19779 . 20488)) (20693 22408 (REALMEMORYSIZE 20703 . +20861) (LISPVERSION 20863 . 21016) (MICROCODEVERSION 21018 . 21176) (BCPLVERSION 21178 . 21331) ( +REQUIREVERSION 21333 . 22406)) (22445 27023 (APROPOS 22455 . 26471) (APROPRINT 26473 . 27021)) (27049 +30957 (READPRINTERPORT 27059 . 27200) (WRITEPRINTERPORT 27202 . 27357) (\READPRINTERPORT.UFN 27359 . +27548) (\WRITEPRINTERPORT.UFN 27550 . 27748) (\MISC1.UFN 27750 . 27903) (\MISC2.UFN 27905 . 28143) ( +\MISC3.UFN 28145 . 28878) (\MISC4.UFN 28880 . 29430) (\MISC5.UFN 29432 . 29585) (\MISC6.UFN 29587 . +29837) (\MISC7.UFN 29839 . 30324) (\MISC8.UFN 30326 . 30627) (\MISC10.UFN 30629 . 30955)) (31011 38460 + (\BLKFDIFF.UFN 31021 . 31586) (\BLKFPLUS.UFN 31588 . 32160) (\BLKFTIMES.UFN 32162 . 32737) ( +\BLKSEP.UFN 32739 . 33870) (\BLKPERM.UFN 33872 . 34341) (\BLKEXPONENT.UFN 34343 . 34753) ( +\BLKFLOATP2COMP.UFN 34755 . 35339) (\BLKSMALLP2FLOAT.UFN 35341 . 35700) (\BLKMAG.UFN 35702 . 36353) ( +\FLOATTOBYTE.UFN 36355 . 36934) (\BLKFMAX.UFN 36936 . 37328) (\BLKFMIN.UFN 37330 . 37719) ( +\BLKFABSMAX.UFN 37721 . 38090) (\BLKFABSMIN.UFN 38092 . 38458)) (38500 40318 (\P-MISC2.UFN 38510 . +38751) (\LINES-EQUAL-P 38753 . 39137) (\GET-NEXT-RUN 39139 . 40316)) (40319 44498 (IBLT1 40329 . 42331 +) (IBLT2 42333 . 44496))))) STOP diff --git a/sources/DMISC.LCOM b/sources/DMISC.LCOM index f5707affaf0594097c88976cdb82dd5eb1595169..dc27968812427d18b04ea3893434af344c31c111 100644 GIT binary patch delta 1769 zcmbu9TTC2P7=VFp3msblODVNr4@-d=V3(O$W-qg_%h{Q;bjs|`GBdmMLe&M9mXuq; zYFlG4vGG!CLOQ-Q#%iqA#2Bp-Uq}pn(KIAB;jO`_)tIP>O}y5a_~3sQ*iaLnx)0y} z_y7F=oSDzg7oU5%c&=xbVc58)6U8LhCMt3xzvn=9!Xxsch=h>L2W7$UMyz{ia(rrZ zEH{iMCm@JYwask4Pf!+lS?X}3!RcI~5tBPTH9gZPqqvT({ry@}HTuygbdRTX z9jzCj`ChNrjfS&N!08HwH`EQex&IwdZLdr*5zozE72fhcM z+SaxE!senP7xtkmCk9IvV?Olu*o{HgV)rLu=c{eCrH3mkT-wLY7q{=M;Eol+kD(YW zTD-R4RBvyay?VT&h!w;Tis^>Ziv&SJS~5dSyB`UB0I8Y-WV8I;pqaI>gHeApI z3Ur{1rV>Ljbi+jcU?IWJZ*+9rqltbRmeTPdi_4cu!F>n{$Vl6%v<))HP^XYSLKVNkVs=!XrYpVh&_D^;eyX|z%5yunQstFhoxr7C z7`Uy5%34hn+%MJi(UdQD|4E~kYo7u|t6QS`rPbqm7r;=ACaK|MeH-v{eHge>-wSMV zQ%<{&0mI^?gPL7VqTyjkIo@!G*3C2y(aeRWbHHfxHQ+DJw}H#-E#Q0H3h;&27U#nj zD=!^%j+z0^j#u2KKgp z18f)eIB|Y>P5PWao|m3q)0c%&kiz0c;7##KAn{!V{_OiA&v%^1q!37#qygYvX#{xG ze;6oqyPXw3^;HFifTsgAq7CnL{s<6|nyV$SyPK9Iz47WitIPV##=2RzhCGp~2j39Gwkx3gW;@@>~3P>mb~z7?VN zEm3-kp=fJ@qd$hd=ZzaMOs&TzX2QlXo&49E)O0YJDcl!DCQ)>(CHk>uqYe)C5e-1y zeckOqyITUD@2-VMvl{JW168GKiu0>$hby0RySvJ}9%11O$s`i^AoBBkq06c@-^54F zjvI4OTE`yXS?mLTfayJ0!S%p@Fm2x!YpGr>+lLw(h@r!0&9o4FU7WF4T47kMs3$oqaeuR}> zx)dSC6bKX-s`VF@zYFUCaA9ST+wADoBZ z{Li`P-gEAmd*{SV<7cND&!na)Z@+G6ils@8rXre)1fDD$32N@r8Y6+hV30+ z!?A!6LJ$(+#YpU4VN>Dlb_! za<`(GX`4Z{$?}nj>Qvn=4I*e14M;WE8YB*h5kX{y|Cg9!C|Obl?5w0{s znWm>38>#u1SFD2dKFsC@+2naq|~feMrWLcXst#prkcl!j#sQo5cOw z+8=>mKium-y|SU9S>n<810zifGLPP4%(U1`UY)XwRv zFK{TYtD32phH0UA^nOq*zI-6^FDo1-VOc}kV>@sl(^++ z11BIe=VWsZXoez_oLokeLLsPvwA5|X(MNuQt`ydt2a?9cTH~NyhO6RQS2LdLY=fTz2z z0F&O^Ko4^R_y_YH@EgAm|K+n?wHsgZ`(1T>HRUysmq!Y|?f2m0JFkIT4;%u{1v~JK zz~GWf1#_<22mCYmI`Fk!w}8{^7JM#LT2hFnGGJ1J^|vJTJ-{@O3c@>LXdkd%GV8^-_1Cg_2a&y|rF^NI{tDiNJu; zQwCn_AxpLPk}Z$+lJwVmiHA*$0AEe)1>Q*zf4+~DHQ(pohlW+%a`uornzGDXMrFuD zd6!*U0}Y#&o^muR?MSkrJvf@t4RBdmX|NAjnqo+LdPve86lN&wPsSioF}Vwflcdzo zlUw2A-HpcY#5U}|XZ%w_R!V98mNrOMScsG)M zH!esF4c*fe2l}Jg5UVJi5Id&$wk?a5wSLpm3^N567!>?wDSTPkvf1pfJgSnfcS|KL+^mg0L@^Zfn)(}RZ{X1Y From fe62e8e6e23983ff461e0dc09686cdba76e048c1 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 21:09:15 -0800 Subject: [PATCH 07/10] LLCHAR: Extend STRING.EQUAL to take CASEARRAY as argument still defaults to the previously built-in reference to UPPERCASEARRAY --- sources/LLCHAR | 526 +++++++++++++++++++++----------------------- sources/LLCHAR.LCOM | Bin 22220 -> 22298 bytes 2 files changed, 256 insertions(+), 270 deletions(-) diff --git a/sources/LLCHAR b/sources/LLCHAR index c42762ae..db262b7d 100644 --- a/sources/LLCHAR +++ b/sources/LLCHAR @@ -1,9 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Jun-2021 18:08:19"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;6 108072 - previous date%: "19-Jun-2021 10:00:42" -{DSK}kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;5) +(FILECREATED " 8-Jan-2022 19:08:41" {DSK}kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;8 106473 + + :CHANGES-TO (FNS STRING.EQUAL) + + :PREVIOUS-DATE "21-Jun-2021 18:08:19" +{DSK}kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;6) (* ; " @@ -18,8 +20,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE GLC GLCCODE STREQUAL STRING.EQUAL STRINGP CHCON1 U-CASE L-CASE U-CASEP \SMASHABLESTRING \MAKEWRITABLESTRING \SMASHSTRING \FATTENSTRING) - (COMS (* ; - "Temporary until low level system is changed to call STRING.EQUAL again") + (COMS (* ; + "Temporary until low level system is changed to call STRING.EQUAL again") (P (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T) (MOVD? 'STRING.EQUAL 'CL::SIMPLE-STRING-EQUAL NIL T))) (FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString) @@ -30,11 +32,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (MACROS \PNAMESTRINGPUTCHAR) (OPTIMIZERS FCHARACTER) (I.S.OPRS inpname inatom instring) - (* ; - "For use when the inner-loop test in the generic operators is too expensive") + (* ; + "For use when the inner-loop test in the generic operators is too expensive") (I.S.OPRS infatatom inthinatom infatstring inthinstring) (MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP) - (* ; "For benefit of Masterscope") + (* ; "For benefit of Masterscope") (MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN) (MACROS \PUTBASECHAR \GETBASECHAR) (MACROS \CHARSET \CHAR8CODE) @@ -48,7 +50,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING) (P (MOVD? 'CHARACTER 'FCHARACTER NIL T)) [COMS (FNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY) - (* ; "For MAKEINIT") + (* ; "For MAKEINIT") (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)) (* "So %%COPY-ONED-ARRAY will compile properly") @@ -59,7 +61,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY] (DECLARE%: DONTCOPY EVAL@COMPILE (LOCALVARS . T)) - (* ;; "Arrange for the proper compiler") + (* ;; "Arrange for the proper compiler") (PROP FILETYPE LLCHAR))) (DEFINEQ @@ -966,10 +968,14 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (GO SLOWLP]) (STRING.EQUAL - [LAMBDA (X Y) (* ; - "Edited 12-Jan-94 10:01 by sybalsky:mv:envos") + [LAMBDA (X Y CASEARRAY) (* ; "Edited 8-Jan-2022 19:08 by rmk") + (* ; + "Edited 12-Jan-94 10:01 by sybalsky:mv:envos") -(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case") +(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case.") + + (* ;; + "RMK: Added CASEARRAY argument, silly not to extend this to other than the default UPPERCASEARRAY.") (PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2) (COND @@ -1012,28 +1018,32 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (SETQ OFFSETY (ffetch (STRINGP OFFST) of Y)) (SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y))) (T (RETURN NIL))) + (CL:UNLESS CASEARRAY (SETQ CASEARRAY UPPERCASEARRAY)) [COND - ((NEQ (ffetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY 'ARRAYP)) - \ST.BYTE) (* ; - "Someone smashed UPPERCASEARRAY ?") - (SETQ UPPERCASEARRAY (UPPERCASEARRAY] - (SETQ CABASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY)) + ((NEQ (ffetch (ARRAYP TYP) of (\DTEST CASEARRAY 'ARRAYP)) + \ST.BYTE) + (IF (EQ CASEARRAY UPPERCASEARRAY) + THEN + (* ;; "Did someone smashed the UPPERCASEARRAY? We can repair it") + + (SETQ CASEARRAY (SETQ UPPERCASEARRAY (UPPERCASEARRAY))) + ELSE (\ILLEGAL.ARG CASEARRAY] + (SETQ CABASE (ffetch (ARRAYP BASE) of CASEARRAY)) (RETURN (COND - [(OR FATPX FATPY) (* ; "Slow case") - (for BNX from OFFSETX as BNY from OFFSETY as I to - LEN + [(OR FATPX FATPY) (* ; "Slow case") + (for BNX from OFFSETX as BNY from OFFSETY as I to LEN always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX)) - (SETQ C2 (\GETBASECHAR FATPY BASEY BNY)) - (COND - ((OR (IGREATERP C1 \MAXTHINCHAR) - (IGREATERP C2 \MAXTHINCHAR)) - (* ; "Fat chars not alphabetic") - (EQ C1 C2)) - (T (EQ (\GETBASEBYTE CABASE C1) - (\GETBASEBYTE CABASE C2] - (T (for BNX from OFFSETX as BNY from OFFSETY as I - to LEN always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX)) - (\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY]) + (SETQ C2 (\GETBASECHAR FATPY BASEY BNY)) + (COND + ((OR (IGREATERP C1 \MAXTHINCHAR) + (IGREATERP C2 \MAXTHINCHAR)) + (* ; "Fat chars not alphabetic") + (EQ C1 C2)) + (T (EQ (\GETBASEBYTE CABASE C1) + (\GETBASEBYTE CABASE C2] + (T (for BNX from OFFSETX as BNY from OFFSETY as I to LEN + always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX)) + (\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY]) (STRINGP [LAMBDA (OBJECT) (* jop%: "24-Sep-86 22:58") @@ -1374,141 +1384,136 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (ACCESSFNS STRINGP ((XREADONLY (fetch (ARRAY-HEADER READ-ONLY-P) of DATUM) - (replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE - )) - (XBASE ([OPENLAMBDA (STRING) - (COND - ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) - (%%ARRAY-BASE STRING)) - (T (fetch (ARRAY-HEADER BASE) of STRING] - DATUM) - ((OPENLAMBDA (STRING NV) - (replace (ARRAY-HEADER INDIRECT-P) of STRING with - NIL) - (replace (ARRAY-HEADER BASE) of STRING with NV) - NV) - DATUM NEWVALUE)) - (TYP ((OPENLAMBDA (STRING) - (SELECTC (COND - ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) - (%%ARRAY-TYPE-NUMBER STRING)) - (T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING))) - (%%THIN-CHAR-TYPENUMBER - \ST.BYTE) - (%%FAT-CHAR-TYPENUMBER - \ST.POS16) - (SHOULDNT "Unknown type-number"))) - DATUM) - ([OPENLAMBDA (STRING NV) - (LET [(%%NEW-TYPE-NUMBER (SELECTC NV - (\ST.BYTE %%THIN-CHAR-TYPENUMBER) - (\ST.POS16 %%FAT-CHAR-TYPENUMBER) - (SHOULDNT "Unknown typ value"] - (COND + (replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE)) + (XBASE ([OPENLAMBDA (STRING) + (COND + ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) + (%%ARRAY-BASE STRING)) + (T (fetch (ARRAY-HEADER BASE) of STRING] + DATUM) + ((OPENLAMBDA (STRING NV) + (replace (ARRAY-HEADER INDIRECT-P) of STRING with NIL) + (replace (ARRAY-HEADER BASE) of STRING with NV) + NV) + DATUM NEWVALUE)) + (TYP ((OPENLAMBDA (STRING) + (SELECTC (COND ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) - (%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER)) - (T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING - with %%NEW-TYPE-NUMBER] - DATUM NEWVALUE)) - (LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM) - ((OPENLAMBDA (STRING NV) - (replace (ARRAY-HEADER FILL-POINTER) of STRING with - NV) - (replace (ARRAY-HEADER TOTAL-SIZE) of STRING with - NV) - [COND - ((%%GENERAL-ARRAY-P STRING) - (freplace (GENERAL-ARRAY DIMS) of STRING - with (LIST NV] - NV) - DATUM NEWVALUE)) - (OFFST ([OPENLAMBDA (STRING) - (COND - ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) - (%%ARRAY-OFFSET STRING)) - (T (fetch (ARRAY-HEADER OFFSET) of STRING] - DATUM) - ([OPENLAMBDA (STRING NV) - (COND - ((NOT (EQ 0 NV)) - (replace (ARRAY-HEADER DISPLACED-P) of STRING - with T))) - (COND - ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) - (%%SET-ARRAY-OFFSET STRING NV)) - (T (replace (ARRAY-HEADER OFFSET) of STRING with - NV] - DATUM NEWVALUE)) + (%%ARRAY-TYPE-NUMBER STRING)) + (T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING))) + (%%THIN-CHAR-TYPENUMBER + \ST.BYTE) + (%%FAT-CHAR-TYPENUMBER + \ST.POS16) + (SHOULDNT "Unknown type-number"))) + DATUM) + ([OPENLAMBDA (STRING NV) + (LET [(%%NEW-TYPE-NUMBER (SELECTC NV + (\ST.BYTE %%THIN-CHAR-TYPENUMBER) + (\ST.POS16 %%FAT-CHAR-TYPENUMBER) + (SHOULDNT "Unknown typ value"] + (COND + ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) + (%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER)) + (T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING with + %%NEW-TYPE-NUMBER + ] + DATUM NEWVALUE)) + (LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM) + ((OPENLAMBDA (STRING NV) + (replace (ARRAY-HEADER FILL-POINTER) of STRING with NV) + (replace (ARRAY-HEADER TOTAL-SIZE) of STRING with NV) + [COND + ((%%GENERAL-ARRAY-P STRING) + (freplace (GENERAL-ARRAY DIMS) of STRING with (LIST NV] + NV) + DATUM NEWVALUE)) + (OFFST ([OPENLAMBDA (STRING) + (COND + ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) + (%%ARRAY-OFFSET STRING)) + (T (fetch (ARRAY-HEADER OFFSET) of STRING] + DATUM) + ([OPENLAMBDA (STRING NV) + (COND + ((NOT (EQ 0 NV)) + (replace (ARRAY-HEADER DISPLACED-P) of STRING with T))) + (COND + ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) + (%%SET-ARRAY-OFFSET STRING NV)) + (T (replace (ARRAY-HEADER OFFSET) of STRING with NV] + DATUM NEWVALUE)) - (* ;; "The rest of these fields only appear when smashing") + (* ;; "The rest of these fields only appear when smashing") - (XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM) - 15) - ((OPENLAMBDA (STRING) - (replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with - NIL) - (replace (ARRAY-HEADER DISPLACED-P) of STRING with - NIL) - (replace (ARRAY-HEADER FILL-POINTER-P) of STRING - with NIL) - (replace (ARRAY-HEADER EXTENDABLE-P) of STRING with - NIL)) - DATUM))) - [ACCESSFNS STRINGP - ((ORIG ((OPENLAMBDA (STRING) - 1) - DATUM) - ((OPENLAMBDA (STRING NV) - (COND - ((NOT (EQ NV 1)) - (ERROR "Il:stringp's are always origin 1"))) - NV) - DATUM NEWVALUE)) (* ; "An inoperative field") - (SUBSTRINGED ((OPENLAMBDA (STRING) - NIL) - DATUM) - ((OPENLAMBDA (STRING NV) - (OR (NULL NV) - (ERROR "Substringed field not supported"))) - DATUM NEWVALUE)) - (READONLY (ffetch (STRINGP XREADONLY) of DATUM) - (freplace (STRINGP XREADONLY) of DATUM with - NEWVALUE)) - (FATSTRINGP ((OPENLAMBDA (STRING) - (EQ (COND - ((fetch (ARRAY-HEADER INDIRECT-P) - of STRING) - (%%ARRAY-TYPE-NUMBER STRING)) - (T (fetch (ARRAY-HEADER TYPE-NUMBER) - of STRING))) - %%FAT-CHAR-TYPENUMBER)) - DATUM) - ([OPENLAMBDA (STRING NV) - (LET [(%%NEW-TYPE-NUMBER (COND - (NV %%FAT-CHAR-TYPENUMBER) - (T %%THIN-CHAR-TYPENUMBER] - (COND - ((fetch (ARRAY-HEADER INDIRECT-P) of STRING) - (%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER)) - (T (replace (ARRAY-HEADER TYPE-NUMBER) - of STRING with %%NEW-TYPE-NUMBER] - DATUM NEWVALUE)) - (BASE (ffetch (STRINGP XBASE) of DATUM) - (freplace (STRINGP XBASE) of DATUM with NEWVALUE] - (CREATE (create ONED-ARRAY - BASE _ XBASE - READ-ONLY-P _ XREADONLY - STRING-P _ T - DISPLACED-P _ (NOT (EQ OFFST 0)) - TYPE-NUMBER _ (COND - ((EQ TYP \ST.POS16) - %%FAT-CHAR-TYPENUMBER) - (T %%THIN-CHAR-TYPENUMBER)) - OFFSET _ OFFST - FILL-POINTER _ LENGTH - TOTAL-SIZE _ LENGTH)) - (TYPE? (CL:STRINGP DATUM)) - OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0) + (XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM) + 15) + ((OPENLAMBDA (STRING) + (replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with NIL) + (replace (ARRAY-HEADER DISPLACED-P) of STRING with NIL) + (replace (ARRAY-HEADER FILL-POINTER-P) of STRING with NIL) + (replace (ARRAY-HEADER EXTENDABLE-P) of STRING with NIL)) + DATUM))) + [ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING) + 1) + DATUM) + ((OPENLAMBDA (STRING NV) + (COND + ((NOT (EQ NV 1)) + (ERROR "Il:stringp's are always origin 1"))) + NV) + DATUM NEWVALUE)) + (* ; "An inoperative field") + (SUBSTRINGED ((OPENLAMBDA (STRING) + NIL) + DATUM) + ((OPENLAMBDA (STRING NV) + (OR (NULL NV) + (ERROR "Substringed field not supported"))) + DATUM NEWVALUE)) + (READONLY (ffetch (STRINGP XREADONLY) of DATUM) + (freplace (STRINGP XREADONLY) of DATUM with NEWVALUE)) + (FATSTRINGP ((OPENLAMBDA (STRING) + (EQ (COND + ((fetch (ARRAY-HEADER INDIRECT-P) + of STRING) + (%%ARRAY-TYPE-NUMBER STRING)) + (T (fetch (ARRAY-HEADER TYPE-NUMBER) + of STRING))) + %%FAT-CHAR-TYPENUMBER)) + DATUM) + ([OPENLAMBDA (STRING NV) + (LET [(%%NEW-TYPE-NUMBER (COND + (NV + %%FAT-CHAR-TYPENUMBER + ) + (T + %%THIN-CHAR-TYPENUMBER + ] + (COND + ((fetch (ARRAY-HEADER INDIRECT-P) + of STRING) + (%%SET-ARRAY-TYPE-NUMBER STRING + %%NEW-TYPE-NUMBER)) + (T (replace (ARRAY-HEADER TYPE-NUMBER) + of STRING with %%NEW-TYPE-NUMBER] + DATUM NEWVALUE)) + (BASE (ffetch (STRINGP XBASE) of DATUM) + (freplace (STRINGP XBASE) of DATUM with NEWVALUE] + (CREATE (create ONED-ARRAY + BASE _ XBASE + READ-ONLY-P _ XREADONLY + STRING-P _ T + DISPLACED-P _ (NOT (EQ OFFST 0)) + TYPE-NUMBER _ (COND + ((EQ TYP \ST.POS16) + %%FAT-CHAR-TYPENUMBER) + (T %%THIN-CHAR-TYPENUMBER)) + OFFSET _ OFFST + FILL-POINTER _ LENGTH + TOTAL-SIZE _ LENGTH)) + (TYPE? (CL:STRINGP DATUM)) + OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -1531,27 +1536,25 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. ) (DECLARE%: EVAL@COMPILE -(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) - (* ; - "For stuffing chars into resource \PNAMESTRING") - (\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE))) +(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* ; + "For stuffing chars into resource \PNAMESTRING") + (\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE))) ) (DEFOPTIMIZER FCHARACTER (NUM) - `([OPENLAMBDA (N) - (COND - ((IGREATERP N \MAXTHINCHAR) - (* ; - "The character we're getting is NOT a thin character -- do it the hard way") - (CHARACTER N)) - ((IGREATERP N (CHARCODE 9)) - (\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10))) - ((IGEQ N (CHARCODE 0)) - (IDIFFERENCE N (CHARCODE 0))) - (T (* ; - "The common case -- just add on the one-atom base.") - (\ADDBASE \OneCharAtomBase N] - ,NUM)) + `([OPENLAMBDA (N) + (COND + ((IGREATERP N \MAXTHINCHAR) (* ; + "The character we're getting is NOT a thin character -- do it the hard way") + (CHARACTER N)) + ((IGREATERP N (CHARCODE 9)) + (\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10))) + ((IGEQ N (CHARCODE 0)) + (IDIFFERENCE N (CHARCODE 0))) + (T (* ; + "The common case -- just add on the one-atom base.") + (\ADDBASE \OneCharAtomBase N] + ,NUM)) (DECLARE%: EVAL@COMPILE (I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET) @@ -1563,30 +1566,26 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. `(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) first [PROG NIL - $$RETRY - (COND - ((STRINGP $$BODY) - (SETQ $$BASE (ffetch (STRINGP BASE) - of $$BODY)) - (SETQ $$OFFSET (SUB1 (ffetch (STRINGP - OFFST) - of $$BODY))) - (SETQ $$END (IPLUS $$OFFSET (ffetch - (STRINGP - LENGTH) - of $$BODY))) - (SETQ $$FATP (ffetch (STRINGP - FATSTRINGP) - of $$BODY))) - ((LITATOM $$BODY) - (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) - of $$BODY)) - (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) - of $$BASE)) - (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) - of $$BODY))) - (T (SETQ $$BODY (MKSTRING $$BODY)) - (GO $$RETRY] + $$RETRY + (COND + ((STRINGP $$BODY) + (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) + (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) + of $$BODY))) + (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH + ) + of $$BODY))) + (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) + of $$BODY))) + ((LITATOM $$BODY) + (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) + of $$BODY)) + (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) + of $$BASE)) + (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) + of $$BODY))) + (T (SETQ $$BODY (MKSTRING $$BODY)) + (GO $$RETRY] eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) @@ -1603,10 +1602,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (GETDUMMYVAR)) '(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) - first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY - )) - (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE) - ) + first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) + (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) @@ -1624,13 +1621,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (GETDUMMYVAR)) '(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP) - first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) - of $$BODY))) + first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY))) (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) of $$BODY))) - (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) - of $$BODY)) + (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) @@ -1648,10 +1643,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (GETDUMMYVAR)) '(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END) - first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) - of $$BODY)) - (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) - of $$BASE)) + first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) + (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) @@ -1665,10 +1658,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (GETDUMMYVAR)) '(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END) - first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) - of $$BODY)) - (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) - of $$BASE)) + first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) + (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) @@ -1682,12 +1673,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (GETDUMMYVAR)) '(bind $$BODY _ BODY $$END $$OFFSET $$BASE declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE) - first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) - of $$BODY))) - (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY - )) - (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP - LENGTH) + first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY))) + (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) + (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) of $$BODY))) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) @@ -1703,11 +1691,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. '(bind $$BODY _ BODY $$END $$OFFSET $$BASE declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE) first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) - of $$BODY))) - (SETQ $$BASE (ffetch (STRINGP BASE) of - $$BODY)) - (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP - LENGTH) + of $$BODY))) + (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) + (SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH) of $$BODY))) eachtime (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) @@ -1717,20 +1703,20 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. ) (DECLARE%: EVAL@COMPILE -(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ; - "used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses") - (AND (SMALLP X) - (IGEQ X 0)))) +(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ; + "used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses") + (AND (SMALLP X) + (IGEQ X 0)))) -(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ; - "Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses") - (AND (SMALLP X) - (IGREATERP X \MAXTHINCHAR)))) +(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ; + "Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses") + (AND (SMALLP X) + (IGREATERP X \MAXTHINCHAR)))) (PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X) - (AND (SMALLP X) - (IGEQ X 0) - (ILEQ X \MAXTHINCHAR)))) + (AND (SMALLP X) + (IGEQ X 0) + (ILEQ X \MAXTHINCHAR)))) ) (DECLARE%: EVAL@COMPILE @@ -1745,22 +1731,22 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (DECLARE%: EVAL@COMPILE (PUTPROPS \PUTBASECHAR MACRO [OPENLAMBDA (FATP BASE OFFSET CODE) - (COND - (FATP (\PUTBASEFAT BASE OFFSET CODE)) - (T (\PUTBASETHIN BASE OFFSET CODE]) + (COND + (FATP (\PUTBASEFAT BASE OFFSET CODE)) + (T (\PUTBASETHIN BASE OFFSET CODE]) (PUTPROPS \GETBASECHAR MACRO [(FATP BASE N) - (COND - (FATP (\GETBASEFAT BASE N)) - (T (\GETBASETHIN BASE N]) + (COND + (FATP (\GETBASEFAT BASE N)) + (T (\GETBASETHIN BASE N]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \CHARSET MACRO ((CHARCODE) - (LRSH CHARCODE 8))) + (LRSH CHARCODE 8))) (PUTPROPS \CHAR8CODE MACRO ((CHARCODE) - (LOGAND CHARCODE 255))) + (LOGAND CHARCODE 255))) ) (DECLARE%: EVAL@COMPILE @@ -1787,10 +1773,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (DECLARE%: EVAL@COMPILE (PUTPROPS \NATOMCHARS DMACRO ((AT) - (fetch (LITATOM PNAMELENGTH) of AT))) + (fetch (LITATOM PNAMELENGTH) of AT))) (PUTPROPS \NSTRINGCHARS DMACRO ((S) - (fetch (STRINGP LENGTH) of S))) + (fetch (STRINGP LENGTH) of S))) ) (* "END EXPORTED DEFINITIONS") @@ -1866,10 +1852,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (ADDTOVAR INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)) (ADDTOVAR INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) - CMLARRAY-SUPPORT)) + CMLARRAY-SUPPORT)) -(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN - \GETBASEFAT \PUTBASECHAR) +(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT + \PUTBASECHAR) (ADDTOVAR DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY) ) @@ -1889,16 +1875,16 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3970 73876 (ALLOCSTRING 3980 . 6003) (MKATOM 6005 . 6640) (SUBATOM 6642 . 8512) ( -CHARACTER 8514 . 9518) (\PARSE.NUMBER 9520 . 25240) (\INVALID.DOTTED.SYMBOL 25242 . 25737) ( -\INVALID.INTEGER 25739 . 27191) (\MKINTEGER 27193 . 29900) (MKSTRING 29902 . 32045) ( -\PRINDATUM.TO.STRING 32047 . 38225) (BKSYSBUF 38227 . 39761) (NCHARS 39763 . 41463) (NTHCHARCODE 41465 - . 43511) (RPLCHARCODE 43513 . 44574) (\RPLCHARCODE 44576 . 46111) (NTHCHAR 46113 . 46306) (RPLSTRING -46308 . 49519) (SUBSTRING 49521 . 52444) (GNC 52446 . 52619) (GNCCODE 52621 . 53389) (GLC 53391 . -53564) (GLCCODE 53566 . 54331) (STREQUAL 54333 . 56447) (STRING.EQUAL 56449 . 60507) (STRINGP 60509 . -60660) (CHCON1 60662 . 61449) (U-CASE 61451 . 64678) (L-CASE 64680 . 68540) (U-CASEP 68542 . 69116) ( -\SMASHABLESTRING 69118 . 69580) (\MAKEWRITABLESTRING 69582 . 70018) (\SMASHSTRING 70020 . 73726) ( -\FATTENSTRING 73728 . 73874)) (74061 79223 (\GETBASESTRING 74071 . 74725) (\PUTBASESTRING 74727 . -77466) (\PUTBASESTRINGFAT 77468 . 78214) (GetBcplString 78216 . 78881) (SetBcplString 78883 . 79221)) -(104450 107264 (%%COPY-ONED-ARRAY 104460 . 106310) (%%COPY-STRING-TO-ARRAY 106312 . 107262))))) + (FILEMAP (NIL (4009 74195 (ALLOCSTRING 4019 . 6042) (MKATOM 6044 . 6679) (SUBATOM 6681 . 8551) ( +CHARACTER 8553 . 9557) (\PARSE.NUMBER 9559 . 25279) (\INVALID.DOTTED.SYMBOL 25281 . 25776) ( +\INVALID.INTEGER 25778 . 27230) (\MKINTEGER 27232 . 29939) (MKSTRING 29941 . 32084) ( +\PRINDATUM.TO.STRING 32086 . 38264) (BKSYSBUF 38266 . 39800) (NCHARS 39802 . 41502) (NTHCHARCODE 41504 + . 43550) (RPLCHARCODE 43552 . 44613) (\RPLCHARCODE 44615 . 46150) (NTHCHAR 46152 . 46345) (RPLSTRING +46347 . 49558) (SUBSTRING 49560 . 52483) (GNC 52485 . 52658) (GNCCODE 52660 . 53428) (GLC 53430 . +53603) (GLCCODE 53605 . 54370) (STREQUAL 54372 . 56486) (STRING.EQUAL 56488 . 60826) (STRINGP 60828 . +60979) (CHCON1 60981 . 61768) (U-CASE 61770 . 64997) (L-CASE 64999 . 68859) (U-CASEP 68861 . 69435) ( +\SMASHABLESTRING 69437 . 69899) (\MAKEWRITABLESTRING 69901 . 70337) (\SMASHSTRING 70339 . 74045) ( +\FATTENSTRING 74047 . 74193)) (74380 79542 (\GETBASESTRING 74390 . 75044) (\PUTBASESTRING 75046 . +77785) (\PUTBASESTRINGFAT 77787 . 78533) (GetBcplString 78535 . 79200) (SetBcplString 79202 . 79540)) +(102859 105673 (%%COPY-ONED-ARRAY 102869 . 104719) (%%COPY-STRING-TO-ARRAY 104721 . 105671))))) STOP diff --git a/sources/LLCHAR.LCOM b/sources/LLCHAR.LCOM index 032a8d9921fe1661488c3a10d025ff063ee7ab13..b2e9905752b99f2c958fbae78c4293b170f93997 100644 GIT binary patch delta 664 zcmah_U2D@&7;f4kt{1`(ET|XnB9-ML;hdbLO|rJ`v^~i((>5lltYa5jO%caFU~|GQ zhA4O|j(``UKf#X~z23d(@9?(%f|*3nfx4ZG_v7Jx-{(2c*SFlOcifAG8>Ly(c39hE zG+-UzK@%6(wnQ1pGGN_6nxWvs_3GozeQ|RfZjASvyW4v^_r|+T$7wH6Pny$&WJ^7@ zr5Q3ZRD}n=-S4`|aWQ2G`4T+X0^S@r4xFBsB#DP`?cq55=N+9F5{Yo0#%P|a+&@Dk zlrX9)H3CMWx@R$84Eiu@_I&UI&+b_gyECAU0EX+ayLNxzi=D&};AJc>?qz;pz*_1D z)}!~_&1?VXs>VOK*ZOrC+SF&%^XL#T3<1HCAV7ZkQZ84B-pqaH9!1aUtlRoLwVF%b zsCXewU-E_ZNxahvSJQ6taddn!Ey`&a6+bM~sjSL>Dm*%w&W zB%3)pImq&HE2=k!+(GoRQRU3&TcdoL5LmGthgsB-sAqv9s}b&9>7W`^Dw$%jZ<;;} zfavHq)Jnbsq=sO{VnN!N_L2)kCD6V7%S0eVi|3nHIfW<$2CmDzKOPWS{|mw@WOT_H Lq{Yu~HOoH%)l{!@ delta 598 zcmbQWj`7S|#t9xu8g8CGuFgTOjv=lt3Q9(Xx?ZJux<&>@h6;ujRt6SUMkW)p&Fa%L zOLTKnQ*u%(?TYhDi;`1|?R96&nOT`wC@F9$Is5wt0FBoL z*^#28keR2T&wQ;phU;qL(5OIo$IqSpbI1Uh797JpgcjN@oNlaUqn>PM8_H@i) z;Q|SK0P~e6+uLgKP6jL4(4PR3m|STa$vA29Wm_|;Xn(QnEAe9c{Uv~u#D0IN>?<3t zFld+KGK{7^&;;<`(Q4qF@a4E=BR8srRA2R0EXXO1CcXrKU=1R7&t Ky7`X1oj3seE~9Y( From 293c973f1d96dfad6edec019573aefec66a68f39 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 21:10:45 -0800 Subject: [PATCH 08/10] EDITINTERFACE: bug fix in date-comment recognition, improvements to dated change-note behavior --- sources/EDITINTERFACE | 113 +++++++++++++++++++------------------ sources/EDITINTERFACE.LCOM | Bin 16204 -> 16579 bytes 2 files changed, 57 insertions(+), 56 deletions(-) diff --git a/sources/EDITINTERFACE b/sources/EDITINTERFACE index d9f2a03f..fa5cd573 100644 --- a/sources/EDITINTERFACE +++ b/sources/EDITINTERFACE @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 8-Dec-2021 18:25:33"  -{DSK}kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;29 47473 +(FILECREATED "19-Jan-2022 23:09:02"  +{DSK}kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;34 47559 - :CHANGES-TO (FNS EDITDATE? EDITDATE) + :CHANGES-TO (FNS FIXEDITDATE EDITDATE?) - :PREVIOUS-DATE " 8-Dec-2021 16:11:23" -{DSK}kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;27) + :PREVIOUS-DATE "19-Jan-2022 10:22:03" +{DSK}kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;31) (* ; " @@ -109,7 +109,7 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. (DEFGLOBALVAR XCL::ED-LAST-INFO NIL "used in ED to stash last call info so (ED NIL) will restart last edit") -(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz") +(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz") (* ;;; "Standard Common Lisp editor entry. CLtL say's ED does something reasonable when passed a pathname. We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit that. Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.") @@ -627,13 +627,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. OLDATE INITLS]) (FIXEDITDATE - [LAMBDA (EXPR) + [LAMBDA (EXPR) (* ; "Edited 19-Jan-2022 23:08 by rmk") (* ;; "Edited 8-Dec-2021 16:11 by rmk: Updated to add dates to the initial undated comments that begins with current-editor initials, to provide a kind of dated change-log capability.") - (* ; "Edited 3-Dec-2021 15:03 by rmk") - (* ; "Edited 22-Oct-2021 16:58 by rmk:") - (* ; "Edited 27-Sep-2018 22:04 by rmk:") - (* ; "Edited 31-Mar-2000 17:13 by rmk:") + (* ; "Edited 27-Sep-2018 22:04 by rmk:") + (* ; "Edited 31-Mar-2000 17:13 by rmk:") (* ; "Edited 17-Jul-89 11:13 by jtm:") (* ; "18-JUL-78 21:11") @@ -722,56 +720,57 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. ELSEIF (SETQ PARSE (EDITDATE? (CAR E) T)) THEN - (* ;; "Attach the new timestamp at the beginning of E, provided the new date is either more than a day later than the previous one or by a different editor.") + (* ;; "If edited by the same editor within a day, then update the previous timestamp rather than cluttering with a new one. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ") - (* ;; "If edited by the same editor within a day, then update the previous timestamp rather than just leaving the original time. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ") - - (IF (STRING.EQUAL INITLS (CADR PARSE)) + (IF [AND (STRING.EQUAL INITLS (CADR PARSE)) + (ILEQ (IDIFFERENCE (IDATE) + (IDATE (CAR PARSE))) + (CONSTANT (TIMES 24 3600] THEN - (* ;; "Another edit by the same author. If not dated but contains a rest, then upgrade the rest comment with a date Otherwise,If more than a day later, add a new date. If less than a day, assume we are in essentially the same session, and update (CAR E) to the current time.") + (* ;; "Same edit session with the same author: update the last previous timestamp. If the (CAR PARSE) is NIL, we are looking at an initialed comment that becomes a timestamp, and we convert it. If just after this we see another timestamp for the same session, we take that out.") - [IF (NULL (CAR PARSE)) - THEN - (* ;; "If no date but %"INITIALS: xxx%", we definitely want to upgraded to the Edited... initials: xxx format") - - (/RPLACA E (EDITDATE (CAR E) - INITLS - (CADDR PARSE))) - ELSEIF (IGREATERP (IDIFFERENCE (IDATE) + (/RPLACA E (EDITDATE (CAR E) + INITLS + (CADDR PARSE))) + (CL:WHEN [AND (SETQ PARSE (EDITDATE? (CADR E) + T)) + (NULL (CADDR PARSE)) + (STRING.EQUAL INITLS (CADR PARSE)) + (ILEQ (IDIFFERENCE (IDATE) (IDATE (CAR PARSE))) - (TIMES 24 3600)) - THEN - (* ;; - "If we aren't upgrading, then we don't want to propagate the previous REST.") - - (/ATTACH (EDITDATE NIL INITLS) - E) - ELSE - (* ;; - "Same author, within a day. Just change the date, keep the REST.") - - (/RPLACA E (EDITDATE (CAR E) - INITLS - (CADDR PARSE] + (CONSTANT (TIMES 24 3600] + (/RPLACD E (CDDR E))) ELSE + (* ;; + "Different edit sequence, attach a new timestamp in front of any old ones.") - (* ;; "Not a previous date, or not one with this author. Add a new one. If rmk is editing and sees an lmm: rest, we don't want to attribute that rest to rmk in the new one.") + (/ATTACH (EDITDATE NIL INITLS (CADDR PARSE)) + E)) - (/ATTACH (EDITDATE NIL INITLS) - E)) + (* ;; "If the new date has an upgraded comment-level, update all of the previous dates so that they align on the left instead of the right.") + + (CL:UNLESS (EQ (CADR (CAR E)) + ';) + (FOR PREV (NEWTYPE _ (CADR (CAR E))) IN (CDR E) + WHILE (EDITDATE? PREV T) UNTIL (EQ (CADR PREV) + NEWTYPE) + DO (/RPLACA (CDR PREV) + NEWTYPE))) ELSE - (* ;; "Need a new date, didn't even see %" by %", and returns a parsed pair (DATE INITIALS).") @@ -818,12 +817,14 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. (CL:WHEN (SETQ REST (SUBSTRING STRING (ADD1 IENDPOS))) (SETQ REST (CL:STRING-TRIM `(#\Space) REST))) - (IF (IGREATERP (NCHARS REST) - 0) - THEN - (* ;; "Could be %": abc%" to be upgraded with a date") + (IF (AND REST (IGREATERP (NCHARS REST) + 0)) + THEN (CL:WHEN RESTOK - (CL:WHEN RESTOK (LIST DATE I REST)) + (* ;; "Could be %": abc%" , we fill in the date") + + (LIST (DATE (DATEFORMAT NO.SECONDS)) + I REST)) ELSEIF DATE THEN (* ;; "If we saw just initials") @@ -928,11 +929,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. ) (PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4086 10381 (ED 4086 . 10381)) (10383 14359 (INSTALL-PROTOTYPE-DEFN 10383 . 14359)) ( -14360 31143 (EDITDEF.FNS 14370 . 15706) (EDITF 15708 . 16588) (EDITFB 16590 . 17438) (EDITFNS 17440 . -18760) (EDITLOADFNS? 18762 . 22562) (EDITMODE 22564 . 24574) (EDITP 24576 . 25087) (EDITV 25089 . -25728) (DC 25730 . 26411) (DF 26413 . 27455) (DP 27457 . 28541) (DV 28543 . 29115) (EDITPROP 29117 . -29336) (EF 29338 . 29667) (EP 29669 . 29852) (EV 29854 . 30033) (EDITE 30035 . 30913) (EDITL 30915 . -31141)) (31493 46618 (NEW/EDITDATE 31503 . 31725) (FIXEDITDATE 31727 . 39874) (EDITDATE? 39876 . 43363 -) (EDITDATE 43365 . 44621) (SETINITIALS 44623 . 46616))))) + (FILEMAP (NIL (4089 10388 (ED 4089 . 10388)) (10390 14366 (INSTALL-PROTOTYPE-DEFN 10390 . 14366)) ( +14367 31150 (EDITDEF.FNS 14377 . 15713) (EDITF 15715 . 16595) (EDITFB 16597 . 17445) (EDITFNS 17447 . +18767) (EDITLOADFNS? 18769 . 22569) (EDITMODE 22571 . 24581) (EDITP 24583 . 25094) (EDITV 25096 . +25735) (DC 25737 . 26418) (DF 26420 . 27462) (DP 27464 . 28548) (DV 28550 . 29122) (EDITPROP 29124 . +29343) (EF 29345 . 29674) (EP 29676 . 29859) (EV 29861 . 30040) (EDITE 30042 . 30920) (EDITL 30922 . +31148)) (31500 46704 (NEW/EDITDATE 31510 . 31732) (FIXEDITDATE 31734 . 39753) (EDITDATE? 39755 . 43449 +) (EDITDATE 43451 . 44707) (SETINITIALS 44709 . 46702))))) STOP diff --git a/sources/EDITINTERFACE.LCOM b/sources/EDITINTERFACE.LCOM index fa7db4824c165b09bc1789a4d12bfbd3a1736ecd..8fb4fe31ea663d3709cd185ed13561e97968595e 100644 GIT binary patch delta 2229 zcmZuyO>7%Q6!xqG4M|DXP5KiP=)+L3)jHjo{dYj|#$IQ)vDc1wlWn1hq;*R|e-9Pn zM`{$r4V9lRQV{|n#DQySr{{pm0V*yW3kL+Zo=Bx~rOeLSj#FVvJ8#~b_vV{<-+S}R z)!S?66Mq!z*<(u=vqT^Sh?o=foIpN3=Z}d}22#C7OhO~kKmC1tu2(-XF_D7C(v>rf z|64E0smwsSWS7lC-84M2xN}i=$MG-KwP{`VlR<)C z8kTh_f@YRLR`pJ``d7ygJn2khAsK=E%*5dCrNjRJhmH@5a)S zPT*+0RyGO-t;&!Yt5N+;fh1Cs;dw^E0*NRQ>%+>Fu-Nt~f~d=2v#Jy|n(VfO!S(94 zGc#e%%^PJ96|w6*MQPP>H$arMt_4K8iCtU`w-B-32}bK@XD}fuw{WW|AiB^6Nwjup zh7pLWZbv2x=}xGR+&OcRwnDkrf-$VR^V89WfOQod&!TOrUZ@sL(8NxCfTVOp+V&(` zIFo>>xo8&3M&0o2s^cEY0aghVs+EfAc%||TUNJS+X6o?t-d7u06@pegeVAyOJ+Rcw0$pjA8^y zz@RA-y*-g8mPx^W^{PRu4*F4y%b!b}+Oc3I0+S(Q;7Gj-bilvi9ui*UZD`na^qd)N-`OdWU{A0;v?x zBc{y83VXAG-f7o=fEG?Llv|>YVr;E17JQJaYAp9#tx+~M;>`n_(W5bbBX6@*^2`!P sw<4O@Val+e2M=;D+L*pey-cUDdZ(0iJyWgsjG)oW-L8?=QvM(RH3RMaX_3K6{{S#Mj#HQlddGF1<_kQo~ zo%hk*D<3tV0*iL6Ozqmauvt5%7JA>mid5E@5am3kmw+(k}5*6Y#UzH3JZ}Bxr!G;#xkAAq}E5E zC*`4753J*k-v|rI$pdcbTXB(yS1(sNqIRaZpN8UJhW0#`2k!JP)Hyi(96}SZHF64l z9e*(r2`6|LEnQ5}pIdr@ZERgFt-WTi?Vd}J$CKr@{mERi$9wtt5kk95Dpi&DRpX^Md*ORhkVp-b%EI*XUbICHfo+)wMiS(_3B_5^M!uTzzFmu3099q4@ zEH*md*$6eqHf|%uJRJZ-o76dAty!eHWj7P0F5c5eK_F#qel&z6p|Q=6?N z{t2UbWzgSt<3BxMT~rA_`|qCNNq zOt$$-O5Sy#>50^3leR^KwpRs(jnMu;Bz2R0b)Y4!S+$vb#&g_E4u~j2ZvUz9&G|En zc}fJCeiE{@!lVz?6$&l9OBYJoEL{c2TCL^ow@cRgG>H;R)APG&h3OOe22N^a0L3?^ p{e98KS5Yf{^Y&~sdA;PY67f+Q-AYGJQVv~?vxg6Mt{uh${{tY3#V7y( From f531e89ddec9a26cbf9963e63d488d49d5c5d9ce Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 21:12:56 -0800 Subject: [PATCH 09/10] COREIO: More accurate directory name processing, added FILEDIRCASEARRAY FILEDIRCASEARRAY does upper/lower case equivalents plus /<> for testing directory string equivalents. Could be in COREIO, but that's probably too early in the loadup. --- sources/COREIO | 140 ++++++++++++++++++++++++++++++++------------ sources/COREIO.LCOM | Bin 16649 -> 17223 bytes 2 files changed, 101 insertions(+), 39 deletions(-) diff --git a/sources/COREIO b/sources/COREIO index c92dc071..c1b40da7 100644 --- a/sources/COREIO +++ b/sources/COREIO @@ -1,11 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Jan-2022 20:02:51" {DSK}kaplan>Local>medley3.5>my-medley>sources>COREIO.;4 55136 +(FILECREATED "18-Jan-2022 11:22:04" {DSK}kaplan>Local>medley3.5>my-medley>sources>COREIO.;14 58002 - :CHANGES-TO (FNS \CORE.SETFILEINFO) + :CHANGES-TO (FNS \CORE.DIRECTORYNAMEP) - :PREVIOUS-DATE "22-Nov-2021 09:25:42" -{DSK}kaplan>Local>medley3.5>my-medley>sources>COREIO.;3) + :PREVIOUS-DATE "11-Jan-2022 16:45:02" +{DSK}kaplan>Local>medley3.5>my-medley>sources>COREIO.;13) (* ; " @@ -27,6 +27,8 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. \CORE.SETACCESSTIME \CORE.SETFILEINFO \CORE.GETNEXTBUFFER \CORE.UNPACKFILENAME) (FNS COREDEVICE \CREATECOREDEVICE) (FNS \NODIRCOREFDEV \NODIRCORE.OPENFILE) + (FNS FILEDIRCASEARRAY) + (VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY))) (DECLARE%: DONTCOPY (RECORDS CORE.PAGEENTRY COREFILEINFOBLK CORESTREAM COREDEVICE COREGENFILESTATE)) (INITRECORDS COREFILEINFOBLK) @@ -90,10 +92,34 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. (RETURN (fetch IOFILEFULLNAME of INFOBLOCK]) (\CORE.DIRECTORYNAMEP - [LAMBDA (DIRNAME DEV) (* ; "Edited 19-Feb-93 16:04 by jds") - (LET [(DIR (UNPACKFILENAME.STRING DIRNAME 'DIRECTORY] - (AND DIRNAME DIR (> (NCHARS DIR) - 0]) + [LAMBDA (DIRNAME DEV) (* ; "Edited 18-Jan-2022 11:17 by rmk") + (* ; "Edited 10-Jan-2022 22:33 by rmk") + + (* ;; + "Edited 9-Jan-2022 12:42 by rmk: Using the new FILEDIRCASEARRAY so that slashes and brackets match") + + (* ;; "Edited 5-Jan-2022 15:03 by rmk: The previous definition didn't actually check to see if the directory existed. %"existed%" for COREIO means there is at least one file currently in that directory.") + + (* ;; "Edited 19-Feb-93 16:04 by jds") + + (CL:WHEN DIRNAME + + (* ;; "The DIRNAME could be just {CORE}, which always is OK, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.") + + (IF (EQ (CHARCODE }) + (NTHCHARCODE DIRNAME -1)) + ELSE (CL:UNLESS (MEMB (NTHCHARCODE DIRNAME -1) + (CHARCODE (> /))) + (SETQ DIRNAME (CONCAT DIRNAME ">"))) + + (* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)") + + (FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY)) + FIRST (CL:UNLESS (EQ DIRPOS 1) + (SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS))) + IN (CDR (FETCH COREDIRECTORY OF DEV)) WHEN (STRPOS DIRNAME (CAR ENTRY) + 1 NIL T NIL FILEDIRCASEARRAY) + DO (RETURN T))))]) (\CORE.FINDPAGE [LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32") @@ -351,28 +377,30 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. (RETURN INFOBLOCK]) (\CORE.NAMESCAN - [LAMBDA (NAME NAMELST CREATEFLG) (* ; "Edited 23-Oct-87 17:11 by bvm:") + [LAMBDA (NAME NAMELST CREATEFLG) + + (* ;; "Edited 11-Jan-2022 09:30 by rmk: Matching with FILEDIRCASEARRAY, for /") + + (* ;; "Edited 23-Oct-87 17:11 by bvm:") + (COND ((LISTP NAMELST) (bind NEWSEG NEXTNAME while [AND (CDR NAMELST) - (COND - ((STRING-EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST) - )) - NAME) + (COND + ((STRING.EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST))) + NAME FILEDIRCASEARRAY) (* ; "Found it") - (RETURN (CADR NAMELST))) - (T (UALPHORDER NEXTNAME NAME] - do (* ; - "Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME") - (SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND - ((AND CREATEFLG (SETQ NEWSEG - ( - \CORE.NAMESEGMENT - NAME))) - (RPLACD NAMELST - (CONS NEWSEG - (CDR NAMELST))) - NEWSEG]) + (RETURN (CADR NAMELST))) + (T (ALPHORDER NEXTNAME NAME FILEDIRCASEARRAY] + do (* ; + "Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME") + (SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND + ((AND CREATEFLG (SETQ NEWSEG + (\CORE.NAMESEGMENT + NAME))) + (RPLACD NAMELST (CONS NEWSEG + (CDR NAMELST))) + NEWSEG]) (\CORE.NAMESEGMENT [LAMBDA (NAME) (* rmk%: "24-FEB-84 21:14") @@ -710,7 +738,12 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. (RETURN T]) (\CORE.UNPACKFILENAME - [LAMBDA (NAME) (* ; "Edited 3-Nov-87 12:12 by bvm:") + [LAMBDA (NAME) (* ; "Edited 10-Jan-2022 22:42 by rmk") + + (* ;; "rmk; Convert / in ROOT to < or >") + (* ; "Edited 10-Jan-2022 21:14 by rmk") + + (* ;; "Edited 3-Nov-87 12:12 by bvm:") (* ;; "Breaks up a file name atom into its fields which it sets freely in its caller") @@ -729,6 +762,17 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. (SETQ DOT SEMI))) (SETQ ROOT (OR (SUBSTRING NAME START (SUB1 DOT)) "")) + (CL:WHEN (STRPOS "/" ROOT) + + (* ;; "If ROOT has slashes, convert to < ..> ..>") + + (SETQ ROOT (DSUBST (CHARCODE >) + (CHARCODE /) + (CHCON ROOT))) + (CL:WHEN (EQ (CAR ROOT) + (CHARCODE >)) + (RPLACA ROOT (CHARCODE <))) + (SETQ ROOT (CONCATCODES ROOT))) (SETQ EXT (COND ((< DOT (- SEMI 1)) (SUBSTRING NAME (ADD1 DOT) @@ -858,6 +902,24 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. (\CORE.SETACCESSTIME NAME ACCESS) NAME]) ) +(DEFINEQ + +(FILEDIRCASEARRAY + [LAMBDA NIL (* ; "Edited 8-Jan-2022 20:15 by rmk") + + (* ;; "Returns a case array suitable for case insensitive directory matching: <, >, and / all map together in any position. Presumably there are other well-formedness conditions that put < and > only in their proper positions.") + (* ; "Edited 8-Jan-2022 20:12 by rmk") + (for I (CA _ (CASEARRAY)) from (CHARCODE a) to (CHARCODE z) + do [SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a) + (CHARCODE A] + finally (SETCASEARRAY CA (CHARCODE <) + (CHARCODE /)) + (SETCASEARRAY CA (CHARCODE >) + (CHARCODE /)) + (RETURN CA]) +) + +(RPAQ FILEDIRCASEARRAY (FILEDIRCASEARRAY)) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE @@ -955,16 +1017,16 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. (PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1993 1999 2018)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1707 44342 (\CORE.CLOSEFILE 1717 . 2490) (\CORE.DELETEFILE 2492 . 4478) ( -\CORE.DIRECTORYNAMEP 4480 . 4741) (\CORE.FINDPAGE 4743 . 7972) (\CORE.GENERATEFILES 7974 . 10561) ( -\CORE.NEXTFILEFN 10563 . 11062) (\CORE.FILEINFOFN 11064 . 11293) (\CORE.GETFILEHANDLE 11295 . 13449) ( -\CORE.GETFILEINFO 13451 . 14414) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14416 . 15953) (\CORE.GETFILENAME -15955 . 18244) (\CORE.GETINFOBLOCK 18246 . 20869) (\CORE.NAMESCAN 20871 . 22638) (\CORE.NAMESEGMENT -22640 . 23077) (\CORE.OPENFILE 23079 . 26198) (\COREFILE.SETPARAMETERS 26200 . 28381) ( -\CORE.PACKFILENAME 28383 . 28778) (\CORE.RELEASEPAGES 28780 . 29381) (\CORE.SETFILEPTR 29383 . 30482) -(\CORE.UPDATEOF 30484 . 32113) (\CORE.BACKFILEPTR 32115 . 34323) (\CORE.SETEOFPTR 34325 . 36194) ( -\CORE.SETACCESSTIME 36196 . 36821) (\CORE.SETFILEINFO 36823 . 39125) (\CORE.GETNEXTBUFFER 39127 . -43083) (\CORE.UNPACKFILENAME 43085 . 44340)) (44343 47976 (COREDEVICE 44353 . 44524) ( -\CREATECOREDEVICE 44526 . 47974)) (47977 50278 (\NODIRCOREFDEV 47987 . 48584) (\NODIRCORE.OPENFILE -48586 . 50276))))) + (FILEMAP (NIL (1796 46254 (\CORE.CLOSEFILE 1806 . 2579) (\CORE.DELETEFILE 2581 . 4567) ( +\CORE.DIRECTORYNAMEP 4569 . 6250) (\CORE.FINDPAGE 6252 . 9481) (\CORE.GENERATEFILES 9483 . 12070) ( +\CORE.NEXTFILEFN 12072 . 12571) (\CORE.FILEINFOFN 12573 . 12802) (\CORE.GETFILEHANDLE 12804 . 14958) ( +\CORE.GETFILEINFO 14960 . 15923) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15925 . 17462) (\CORE.GETFILENAME +17464 . 19753) (\CORE.GETINFOBLOCK 19755 . 22378) (\CORE.NAMESCAN 22380 . 23927) (\CORE.NAMESEGMENT +23929 . 24366) (\CORE.OPENFILE 24368 . 27487) (\COREFILE.SETPARAMETERS 27489 . 29670) ( +\CORE.PACKFILENAME 29672 . 30067) (\CORE.RELEASEPAGES 30069 . 30670) (\CORE.SETFILEPTR 30672 . 31771) +(\CORE.UPDATEOF 31773 . 33402) (\CORE.BACKFILEPTR 33404 . 35612) (\CORE.SETEOFPTR 35614 . 37483) ( +\CORE.SETACCESSTIME 37485 . 38110) (\CORE.SETFILEINFO 38112 . 40414) (\CORE.GETNEXTBUFFER 40416 . +44372) (\CORE.UNPACKFILENAME 44374 . 46252)) (46255 49888 (COREDEVICE 46265 . 46436) ( +\CREATECOREDEVICE 46438 . 49886)) (49889 52190 (\NODIRCOREFDEV 49899 . 50496) (\NODIRCORE.OPENFILE +50498 . 52188)) (52191 53096 (FILEDIRCASEARRAY 52201 . 53094))))) STOP diff --git a/sources/COREIO.LCOM b/sources/COREIO.LCOM index 97dd3e7a8c6494f9f8d6e3ec4e5ad7cfd428b3ae..b7187bd1f88992b18e3d6dd920215cd40b50495d 100644 GIT binary patch delta 1226 zcmZvb&uiRP5XU8L+Sp1`)~4h~8_FP(unMfKr`7(jVlR3ty^XZpmDW$PlRzNYmch#^ ziAf7B4XtS@A-&Zo{R2vSNFV{@buNXnr&4;$AuZ&TQxClv`UkX6^44~0>-6S3^XAQb zH1o|@{I3uAZ?CD%(FB|H#1WWf;mhawP z>%}V(h%2A2-TUaGk*t+Y-|XE1sX5n^=_Kkk~Bf zh>9fG_+oY(=^&PCs;VX5^JkM!O7C2f!RS)5;QI4H(Pr1#ZM0u9s$?Z=8~05f4K52t zZXKFXg7i7tr4|kdrWD_hfxDmMIl+v!Zr%Pze9|{&|TT;)!+uwO&y4f`r>g1juTg|WYKbbAQzuH?J#clNRj&ObRPp*Ja z34)Mz{Qzn;2<98iaJ{Qg)&Gy^wzD)qB2TjJctV7c# z3+x0H4Wt=q5_A=$x&&Gc3QW?g^5EyU{>rCZ&{14Wp67Bnw>>kF=diFPVS(o(bM8di z!T>t-sfnnD~&us&DCCA{zpT&z~DW!>= z;5vVAoomH2@l@8;u$8u%9b5U98^!QyS9kj_Z*2a~SgH_^aBp^@RDILdSiR>D2Cz={ z20g7|@YwiKAWbh2kNDw*1xy3T7V_YR99CpmhC^L8T-m z;CfBJ(f&{dF?lgd-cMyVjjlzYFgNeBZB3OlkC>?S76JuAmX=K`?c%vZ#T~9;@MZm> F@GllCDXjni delta 684 zcmZuv&5P4e5KmHZ*|3LJMNxDaf=Y8pn!F^7eSS2r=}QwgO+u2Y1rOG3k!sytWDysU z1rMS(CF)raZwg|2l|A}TcoDn^dJz8sU$!nR>N`AUn3>BbUZ$0K2zrb-q;)eX~s)yRP3gkJKaZmP5xFh~d~;o9B8yAE0%BMY1P51veF z0xtDr;7;%yC)hVQ_Qc|=@SHte@CGmEi|ppFGFL?=gp4^!LD!%g#>81J+=ryYHjyQM z*k*1lX!!|svMA}XY_hrkTX~DYUtsVhQkvpQnIpmnAOg=1>>Z}(+bk*1;ul1?F1-KJ zoF1@uc&|+7iARKEM?J=G*8dnS7*pEr&@cnTfG!DQFG^Z80cOq#Fi!nW98hH@N|}5= za`rI)CabW_FN%KXXUsg)l0tDHyT{QCmSxDlHfZkH2j_~4 X%<^~5#k_ATb0Vma$?{~|ek}Y30LZIv From c7272e78f28812d109a01ed02dff4cf2a67c0cf5 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 25 Jan 2022 17:24:19 -0800 Subject: [PATCH 10/10] ADIR: Only first colon before marks a device #651 --- sources/ADIR | 33 ++++++++++++++++----------------- sources/ADIR.LCOM | Bin 24318 -> 24297 bytes 2 files changed, 16 insertions(+), 17 deletions(-) diff --git a/sources/ADIR b/sources/ADIR index c2f27f11..638c2267 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,11 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Jan-2022 11:06:37" {DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;10 65596 +(FILECREATED "25-Jan-2022 17:19:00" {DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;11 65609 :CHANGES-TO (FNS UNPACKFILENAME.STRING) - :PREVIOUS-DATE "13-Jun-2021 11:25:58" -{DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;9) + :PREVIOUS-DATE " 5-Jan-2022 11:06:37" +{DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;10) (* ; " @@ -286,7 +286,8 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T]) (UNPACKFILENAME.STRING - [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 5-Jan-2022 11:03 by rmk") + [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 25-Jan-2022 17:16 by rmk") + (* ; "Edited 5-Jan-2022 11:03 by rmk") (* ; "Edited 30-Mar-90 22:37 by nm") (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") @@ -350,9 +351,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo ((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /)) FILE POS)) (EQ (CHARCODE %:) - (NTHCHARCODE FILE TEM)) - (SETQ TEM (LASTCHPOS (CHARCODE %:) - FILE TEM))) (* ; + (NTHCHARCODE FILE TEM))) (* ;  "all device returned have DEVICE.END on it so that NIL: will work") (UNPACKFILE1 'DEVICE POS (if CLFLG then (SUB1 TEM) @@ -1157,14 +1156,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (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 (2686 13811 (DELFILE 2696 . 2857) (FULLNAME 2859 . 3226) (INFILE 3228 . 3376) (INFILEP -3378 . 3513) (IOFILE 3515 . 3655) (OPENFILE 3657 . 4057) (OPENSTREAM 4059 . 8399) (OUTFILE 8401 . 8552 -) (OUTFILEP 8554 . 8690) (RENAMEFILE 8692 . 8998) (SIMPLE.FINDFILE 9000 . 9410) (VMEMSIZE 9412 . 9579) - (\COPYSYS 9581 . 12530) (\FLUSHVM 12532 . 13604) (\LOGOUT0 13606 . 13809)) (14183 34403 ( -UNPACKFILENAME 14193 . 14379) (UNPACKFILENAME.STRING 14381 . 31282) (LASTCHPOS 31284 . 31978) ( -\UPF.NEXTPOS 31980 . 32625) (\UPF.TEMPFILEP 32627 . 33204) (FILENAMEFIELD 33206 . 33691) (PACKFILENAME - 33693 . 34036) (PACKFILENAME.STRING 34038 . 34401)) (56043 63223 (LOGOUT 56053 . 56970) (MAKESYS -56972 . 58601) (SYSOUT 58603 . 60155) (SAVEVM 60157 . 60957) (HERALD 60959 . 61119) (INTERPRET.REM.CM -61121 . 62846) (\USEREVENT 62848 . 63221)) (63405 65132 (USERNAME 63415 . 64371) (SETUSERNAME 64373 . -65130))))) + (FILEMAP (NIL (2687 13812 (DELFILE 2697 . 2858) (FULLNAME 2860 . 3227) (INFILE 3229 . 3377) (INFILEP +3379 . 3514) (IOFILE 3516 . 3656) (OPENFILE 3658 . 4058) (OPENSTREAM 4060 . 8400) (OUTFILE 8402 . 8553 +) (OUTFILEP 8555 . 8691) (RENAMEFILE 8693 . 8999) (SIMPLE.FINDFILE 9001 . 9411) (VMEMSIZE 9413 . 9580) + (\COPYSYS 9582 . 12531) (\FLUSHVM 12533 . 13605) (\LOGOUT0 13607 . 13810)) (14184 34416 ( +UNPACKFILENAME 14194 . 14380) (UNPACKFILENAME.STRING 14382 . 31295) (LASTCHPOS 31297 . 31991) ( +\UPF.NEXTPOS 31993 . 32638) (\UPF.TEMPFILEP 32640 . 33217) (FILENAMEFIELD 33219 . 33704) (PACKFILENAME + 33706 . 34049) (PACKFILENAME.STRING 34051 . 34414)) (56056 63236 (LOGOUT 56066 . 56983) (MAKESYS +56985 . 58614) (SYSOUT 58616 . 60168) (SAVEVM 60170 . 60970) (HERALD 60972 . 61132) (INTERPRET.REM.CM +61134 . 62859) (\USEREVENT 62861 . 63234)) (63418 65145 (USERNAME 63428 . 64384) (SETUSERNAME 64386 . +65143))))) STOP diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 370a9cb699b04f4b8227d8af234c12688a2e3515..da993a541c98b349093af4cf87206cc5d59de729 100644 GIT binary patch delta 3440 zcmZuzJ#U;v5a!YVhlCPhLc2O8!d7HwXZHJuNG|8s*unOhyK^8C5{i-tSr`Z?1ypZG zML~2wfG#y65~4{%OU)0UL_$i$4~Tg7z4v4H;F|YlcV>6ynP+D9#nawjPkTRnxW;Dl z=AAD#SuzW9LkdI1k3O3)ZHNKuZja^A@Q~aE@XtOgtX^_{)_VmvKI^I{uH|8Ymkfml52z4I!O z=v!lDSp3)vYa&&op|nHg7Jv8NJwx)zo@x^;deTG{^Z;nkI$FJio^Ntcy}}%PqqtT6l*a%zA>9m_YU8KNGgh>`Q$(t z_C{<^i(AEX22Hk{YO;}uCX@L1_-JQqUK||75RZf*>r#Ef&9mdOKAL29nDo_QjTh2} z?rf<{E9l@W|7t}Y93^{DTya8s@3VMI?b-iF%fbDF_p6|_4b%m#t>?^MTOB%8Ro&h= zW5SBAF_aq{S?2C&O?f`FvMV-9r$}ifReoknOPW#5(&P&SG#ibpG3h$u+pH`XloFRN zji%Gl?adn_WLrxLVzj?M8Q0ON5X|D)+i#WD3oI2M9FO*e3P9s9l4*wjD$Td@-Znrf zkF6SC<#BLFIOUM})D`7a?whh9g{UlqvQpUQ}8Wpl(iWqozsFz=CnX5 zbs?6qQYhHGx+qX?Lmp)7d?9c0`XrCmp29}X z&Ur^Dnp{J!lrKrOVj^RRZ9N2Vs=eY6TrRkH@e5X*8JDehp^@w|it5&te|1+$lHyT$X(KTFKHIJx&G zhnU?6p!jHB94i_v4>P<5<{u_r!f}le;)44Cr2}|MthR4 zh`pUS6?pOB+FGdsj@sUv7UTJ3dK=5=9Xor){0|i9X#Vw zQHDfh#w4kCFXB#SwAxM^-8((Yc(eHG+W9r(D)c)&qkY^Mo8=ttHZ+FLc5!QOj07s* z{sj{g9fUb8=Eu`Rp?p|;FON#R83u#+nhMpIz||-de2?GAb$o%VtiBG9nkZYewD>is z!gY*%?KU77-w6s0VBG?ICoFID;S@Sks~Yc%LRlFSk~FxA<0Pop86hvx9c-vzl^9%! zf6xD4_LE13;hyWBwAS~?){ z##?WKLNlrGP!ewdxPu`O?U#6Pz~iVD9P*oZ!`2wcWvyz#$5u6#T=a%DMtWz{7pxdC z#GT4v;KA&$62CD5e9=U^g9!OYR_2qmF%0WCqBJ@>$9)Fx_A4|tre{-=f zR@0JB?VP@SSM&~7lZg6r%cAk`foV#@4 zgR9rO&*68c|Mb_{o&MG9r^D*~N8Ohno-b@Brpu$@(O^EDjdEd>vSP8iwph-`)3>l> z6PAPJ>{uA~PK@UHjeNdXzGKsg)nU?>Na&Z6n?J8*Pq-ulK*6T!H zTT6|o)s^+y87sGBja8|#;UaZMYfkf_mD|!$CPqptGU=TmEpbLQlS?-UXx0*!L(+A? zx87NAXd^CO9L(o~n+Mkh$hMY>#9%U+4eRKnbmjN2?-t5uQeZQGXEm4z<$=dE&}o7H zI?lMtd{#rHG8}CXRvE5tDW@EAA3LL*Nxf4}wjdS3UuDUrIwrUg@fxVbj8XM4b(a8*; zN|2~VPD)$IUqk0Y&HSarBB?mxi44O&5Mx7Jf==uIZezYhK` zF!sVAAJ3*3UpQHY$Vay@MMPqaR=PDAC#md%TL8g~ODHZpPGdSQl&P@NA9rLa7CBSYwj6I$eRu z4j95oO95*;eC