From 311e4f049c9f76c073c5ddf24dc09fabb07b94fe Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 24 Jan 2022 20:55:52 -0800 Subject: [PATCH] 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|%%