github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-05-05 07:34:31 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #777 from Interlisp/rmk42--ADIR-has-new-UNPACKFILENAME.STRING

Browse Source 
ADIR, TESTUPF:  New version of UNPACKFILENAME.STRING with test tool
This commit is contained in:
rmkaplan
2022-06-04 15:24:27 -07:00
committed by GitHub
parent 7eb0f28db4 d3d2534eb1
commit 894ecd6d0c
7 changed files with 1038 additions and 427 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
internal/MEDLEY-UTILS
View File

@@ -1,12 +1,10 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "12-Mar-2022 12:46:25"  (FILECREATED "31-May-2022 09:37:37" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;3| 12695
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>internal>MEDLEY-UTILS.;2| 12734
:CHANGES-TO (FNS MAKE-WHEREIS-HASH) :CHANGES-TO (FNS HCFILES)
:PREVIOUS-DATE "20-Feb-2022 12:59:27" :PREVIOUS-DATE "12-Mar-2022 12:46:25" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;1|)
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>internal>MEDLEY-UTILS.;1|)
(PRETTYCOMPRINT MEDLEY-UTILSCOMS) (PRETTYCOMPRINT MEDLEY-UTILSCOMS)
@@ -161,58 +159,65 @@
(DEFINEQ (DEFINEQ
(HCFILES (HCFILES
(LAMBDA (TFILE PREFIX DEST REDOFLG TOPDIRLEN) (* \; "Edited 20-Feb-2022 12:16 by larry") (LAMBDA (TFILE DEST REDOFLG TOPDIRLEN) (* \; "Edited 31-May-2022 09:31 by larry")
(* \; "Edited 20-Feb-2022 12:16 by larry")
(* \; "Edited 21-Aug-2021 20:56 by larry") (* \; "Edited 21-Aug-2021 20:56 by larry")
(DECLARE (SPECVARS TFILE)) (DECLARE (SPECVARS TFILE))
(|if| (NULL TFILE)
|then| (SETQ TFILE MEDLEYDIR))
(COND (COND
((NULL TFILE)
(HCFILES MEDLEYDIR))
((DIRECTORYNAMEP TFILE) ((DIRECTORYNAMEP TFILE)
(* |;;| "canonicalize")
(SETQ TFILE (DIRECTORYNAME TFILE)) (SETQ TFILE (DIRECTORYNAME TFILE))
(OR TOPDIRLEN (SETQ TOPDIRLEN (IPLUS 1 (CL:LENGTH (MKSTRING (FILENAMEFIELD TFILE 'DIRECTORY)) (OR TOPDIRLEN (SETQ TOPDIRLEN (CL:LENGTH (FILENAMEFIELD.STRING TFILE 'DIRECTORY))))
)))) (CL:UNLESS DEST
(OR DEST (SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T))) (|ShellCommand| (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR")
"/tmp/psfiles/"))
(SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T)))
(* |;;| "first deal with files in this directory") (* |;;| "first deal with files in this directory")
(|for| X |in| (|if| (EQ REDOFLG 'REV) (|for| X |in| (DIRECTORY (CONCAT TFILE "*.TED*;")) |do| (HCFILES X DEST REDOFLG TOPDIRLEN))
|then| (REVERSE (DIRECTORY (CONCAT TFILE "*.TED*;")))
|else| (DIRECTORY (CONCAT TFILE "*.TED*;")))
|do| (HCFILES X PREFIX DEST REDOFLG TOPDIRLEN))
(* |;;| " then deal with subdirs ") (* |;;| " then deal with subdirs ")
(|for| X |in| (|if| (EQ REDOFLG 'REV) (|for| X |in| (DIRECTORY (CONCAT TFILE "*"))
|then| (REVERSE (DIRECTORY (CONCAT TFILE "*")))
|else| (DIRECTORY (CONCAT TFILE "*")))
|when| (|for| SKIP |in| '(">." ">dinfo>") |always| (NOT (STRPOS SKIP (L-CASE X)))) |when| (|for| SKIP |in| '(">." ">dinfo>") |always| (NOT (STRPOS SKIP (L-CASE X))))
|when| (DIRECTORYNAMEP X) |do| (HCFILES X PREFIX DEST REDOFLG TOPDIRLEN))) |when| (DIRECTORYNAMEP X) |do| (HCFILES X DEST REDOFLG TOPDIRLEN)))
((SETQ TFILE (INFILEP TFILE)) ((SETQ TFILE (INFILEP TFILE))
(PROG ((PSFILE (PACKFILENAME.STRING 'EXTENSION (|if| (EQ REDOFLG 'IP) (LET* ((TF (UNPACKFILENAME.STRING TFILE))
|then| 'IP (NAME (LISTGET TF 'NAME))
|else| "PS") (DIR (LISTGET TF 'DIRECTORY))
'NAME (PSFILE (PACKFILENAME.STRING
(CONCAT (OR PREFIX "") 'EXTENSION
(|if| PREFIX (|if| (EQ REDOFLG 'IP)
|then| "-" |then| "IP"
|else| "") |else| "PS")
(PACK (SUBST '- '> (UNPACK (SUBSTRING (FILENAMEFIELD 'NAME
TFILE (|if| (EQ DEST T)
'DIRECTORY) |then| (* \; "with the tedit file")
(IPLUS 1 TOPDIRLEN) NAME
-1)))) |else| (CONCAT (PACK (SUBST '- '> (UNPACK (SUBSTRING DIR (IPLUS 2 TOPDIRLEN
"-" )
(FILENAMEFIELD TFILE 'NAME)) -1))))
'DIRECTORY DEST)) "-" NAME))
'HOST
(LISTGET TF 'HOST)
'DIRECTORY
(|if| (EQ DEST T)
|then| DIR
|else| DEST)))
(TEXTSTREAM)) (TEXTSTREAM))
(|if| (AND (NOT REDOFLG) (|if| (AND (NOT REDOFLG)
(INFILEP PSFILE)) (INFILEP PSFILE))
|then| (* \; " do nothing") |then| (* \; " do nothing")
(PRINTOUT T PSFILE " already there" T) (PRINTOUT T PSFILE " already there" T)
|elseif| (EQ REDOFLG 'TEST) |elseif| (EQ REDOFLG 'TEST)
|then| (PRINTOUT T "TESTING " TFILE) |then| (PRINTOUT T TFILE "-> " PSFILE T)
(CLOSEF (OPENTEXTSTREAM TFILE)) (CLOSEF (OPENTEXTSTREAM TFILE))
|else| (PRINTOUT T "Converting " TFILE "...") |else| (PRINTOUT T "Converting " TFILE " to " PSFILE "...")
(TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM TFILE)) (TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM TFILE))
PSFILE T NIL NIL NIL (|if| (EQ REDOFLG 'IP) PSFILE T NIL NIL NIL (|if| (EQ REDOFLG 'IP)
|then| 'INTERPRESS |then| 'INTERPRESS
@@ -224,7 +229,7 @@
(RPAQ? HCFILES ) (RPAQ? HCFILES )
(DECLARE\: DONTCOPY (DECLARE\: DONTCOPY
(FILEMAP (NIL (753 7201 (GATHER-INFO 763 . 6303) (MEDLEY-FIX-LINKS 6305 . 6828) (MEDLEY-FIX-DATES 6830 (FILEMAP (NIL (699 7147 (GATHER-INFO 709 . 6249) (MEDLEY-FIX-LINKS 6251 . 6774) (MEDLEY-FIX-DATES 6776
. 7199)) (7300 9150 (MAKE-EXPORTS-ALL 7310 . 8326) (MAKE-WHEREIS-HASH 8328 . 9148)) (9185 12689 ( . 7145)) (7246 9096 (MAKE-EXPORTS-ALL 7256 . 8272) (MAKE-WHEREIS-HASH 8274 . 9094)) (9131 12650 (
HCFILES 9195 . 12687))))) HCFILES 9141 . 12648)))))
STOP STOP

BIN
internal/MEDLEY-UTILS.LCOM
View File

Binary file not shown.

811
sources/ADIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Mar-2022 09:39:50" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;13 67302 (FILECREATED "23-May-2022 12:02:10" {DSK}<users>kaplan>local>medley3.5>working-medley>sources>ADIR.;14 65884
:CHANGES-TO (VARS ADIRCOMS) :CHANGES-TO (FNS UNPACKFILENAME.STRING)
(FNS FILENAMEFIELD.STRING) (VARS ADIRCOMS)
:PREVIOUS-DATE "26-Jan-2022 10:18:43" :PREVIOUS-DATE "26-Mar-2022 09:39:50"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;12) {DSK}<users>kaplan>local>medley3.5>working-medley>sources>ADIR.;13)
(* ; " (* ; "
@@ -26,10 +26,16 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(* ;; "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] (MOVD? 'NILL 'CL:PATHNAMEP]
(COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP [COMS (FNS UNPACKFILENAME.STRING \UPF.DIRECTORY)
FILENAMEFIELD FILENAMEFIELD.STRING PACKFILENAME PACKFILENAME.STRING) (DECLARE%: DONTCOPY (MACROS \UPF.EXTRACT \UPF.DIRTYPE)
(DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY (CONSTANTS (FILENAMECODES (CHARCODE (%: < > / %. ; ! %')))
PACKFILENAME.ASSEMBLE UNPACKFILE1)) (MINFILENAMECODE (APPLY (FUNCTION IMIN)
FILENAMECODES))
(MAXFILENAMECODE (APPLY (FUNCTION IMAX)
FILENAMECODES]
(COMS (FNS UNPACKFILENAME LASTCHPOS FILENAMEFIELD FILENAMEFIELD.STRING PACKFILENAME
PACKFILENAME.STRING)
(DECLARE%: DONTCOPY (MACROS PACKFILENAME.ASSEMBLE))
(VARS \FILENAME.SYNTAX) (VARS \FILENAME.SYNTAX)
(FNS FILEDIRCASEARRAY) (FNS FILEDIRCASEARRAY)
(VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY))) (VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY)))
@@ -284,273 +290,427 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
) )
(DEFINEQ (DEFINEQ
(UNPACKFILENAME
[LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:")
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])
(UNPACKFILENAME.STRING (UNPACKFILENAME.STRING
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 25-Jan-2022 17:16 by rmk") [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 28-Apr-2022 11:40 by rmk")
(* ; "Edited 5-Jan-2022 11:03 by rmk") (* ; "Edited 24-Apr-2022 14:11 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.") (* ;;
 "Given a string or atom representation of a file name, unpack it into its component parts.")
(PROG ((POS 1) (* ;; "From the front, the host and device are unmistakable:")
(LEN (NCHARS FILE))
TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) (* ;; " host is marked with { } [ ] or ( ); if no closer, then the whole thing is host")
(* ;; " device follows host until first colon; no device if directory bracket comes first (originally: Only / or > could be in the device")
(* ;; "Fom the back, version and extension are unmistakable:")
(* ;; " version is preceded by last ; Version can't contain directory brackets (but can contain dots??)")
(* ;; " extension is preceded by last . (not following a version ;)")
(* ;; "Then the directory and name fight it out in the middle:")
(* ;;
 " If there is < or / anywhere else but no closing / or >, then the whole thing is a name ")
(* ;;
 " If it begins with < or / but no closing / or >, then directory is < and the rest is name")
(* ;; "")
(* ;; " If there is at least one / or > then the last one ends the directory, anything before is possibly a relative or subdirectory. Anything after is a name")
(* ; "")
(* ;; " (Rationale: Those are not sub-directory brackets)")
(* ;;
 "Leading < duplicates are discarded. But internal << duplicates are retained (abc<<xyz) ")
(* ;; "")
(* ;; "Strategy:")
(* ;; "Peel off the host, since that may control a later pattern. Then 2 phases: A single left-to-right parse of the string to find the component positions, and a separate phase to assemble the value. ")
(* ;;
 "The component positions include the identifying punctuation marks, those are stripped at the end.")
(* ;; "")
(PROG NIL
(COND (COND
((NULL FILE) ((NULL FILE)
(RETURN NIL)) (RETURN NIL))
((OR (LITATOM FILE) ((OR (STRINGP FILE)
(STRINGP FILE) (LITATOM FILE)))
(NUMBERP FILE))) ((NUMBERP FILE) (* ;
 "Extraction is simpler if string pointer")
(SETQ FILE (MKSTRING FILE)))
((TYPEP FILE 'PATHNAME) ((TYPEP FILE 'PATHNAME)
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG))) (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
[(STREAMP FILE) (* ; [(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) (SETQ FILE (MKSTRING (OR (ffetch FULLFILENAME of FILE)
(RETURN (COND (RETURN (CL:IF ONEFIELDFLG
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME) (AND (EQ ONEFIELDFLG 'NAME)
FILE)) FILE)
(T (LIST 'NAME FILE] (LIST 'NAME FILE))]
(T (\ILLEGAL.ARG FILE))) (T (\ILLEGAL.ARG FILE)))
(COND
((SELCHARQ (NTHCHARCODE FILE 1) (* ;;
({ (* ; "normal use in Interlisp-D")  "Parse the string to find marker positions. The format (parens mean optional, [ ] group, | disjoins")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
FILE 2) (* ;; " ({host}) (device :) ( ([<|>]) (directory >) ) (name) (. (extension)) (; (version))")
0))))
(%[ (* ; (* ;; " where: if the directory field begins with < or > but doesn't end later in >, directory is the < or >")
 "some Xerox and Arpanet systems use '[' for host")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") (* ;;
FILE 2)  " name doesn't contain <, >, or ;, May begin with . (differs from original)")
0))))
(%( (* ; (* ;; " extension doesn't contain . and version doesn't contain ")
 "this is the 'proposed standard' for Xerox servers")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") (* ;; "")
FILE 2)
0)))) (* ;; "NOTE: We use FILE's block coorinate system for all markers.")
NIL)
(UNPACKFILE1 'HOST 2 TEM) (RETURN
[COND (FOR C HOST HOSTSTART HOSTEND HOSTENDCHAR STARTPOS DEVICESTART DEVICEEND DIRSTART DIREND
((EQ TEM -1) (* ; DIRBRKSTART DIRBRKEND DIRDIRTY NAMESTART NAMEEND EXTENSIONSTART EXTENSIONEND
 "Started with the host field delimiter, but there was no corresponding terminating delimiter .") VERSIONSTART VERSIONEND INPNAME FILE
FIRST
(* ;; "Host: { for Medley, [ for some arpanet, ( proposed for Xerox. If the host doesn't end its the whole string")
(CL:WHEN [SETQ HOSTENDCHAR (CADR (ASSOC (\GETBASECHAR $$FATP $$BASE $$OFFSET)
(CHARCODE (({ })
(%( %))
(%[ %]]
(SETQ HOSTSTART $$OFFSET)
[SETQ HOSTEND (FOR I CH FROM (ADD1 HOSTSTART) TO $$END
DO (* ; "Skip the opening bracket")
(SETQ CH (\GETBASECHAR $$FATP $$BASE I))
(IF (EQ CH HOSTENDCHAR)
THEN (RETURN I)
ELSEIF (EQ CH (CHARCODE %'))
THEN (ADD I 1)) FINALLY
(* ;;
 "The %"bracket%" is just past the end")
(RETURN (ADD1 $$END]
(SETQ HOST (\UPF.EXTRACT (ADD1 HOSTSTART)
(SUB1 HOSTEND))) (* ; "Needed for GETHOSTINFO")
(CL:WHEN (IGEQ HOSTEND $$END) (* ; "Only a host")
(GO RETURNVALUE))
(SETQ $$OFFSET (ADD1 HOSTEND)))
(* ;; "")
(* ;; "STARTPOS starts after host, is updated after device for later fields")
(SETQ STARTPOS $$OFFSET) WHEN (AND (IGEQ C MINFILENAMECODE)
(ILEQ C MAXFILENAMECODE))
DO
(* ;; "Test interval because SELCHARQ doesn't compile as a dispatch.")
COERCE
(SELCHARQ C
(%: (* ;
 "Device ends on the first colon before any other marker")
(CL:UNLESS (OR DEVICESTART DIRSTART NAMESTART EXTENSIONSTART VERSIONSTART)
(SETQ DEVICESTART STARTPOS)
(SETQ DEVICEEND $$OFFSET)
(SETQ STARTPOS (ADD1 $$OFFSET))))
(< (CL:UNLESS (OR EXTENSIONSTART VERSIONSTART)
(* ; (* ;
 "I'm not sure why the name is dealt with the host name.")  "Ordinary character if already started directory or in an extension")
(RETURN (DREVERSE VAL] (IF DIRSTART
(SETQ POS (IPLUS TEM 2)) THEN
[if (EQ OSTYPE T) (* ;; "DIRECTORY advances over initial duplicate brackets (but DIRSTART could be a subdirectory character instead)")
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.") (CL:WHEN [AND (EQ DIRSTART (SUB1 $$OFFSET))
(FMEMB (\GETBASECHAR $$FATP $$BASE (SUB1 $$OFFSET
))
(CHARCODE (> / <]
(SETQ DIRSTART $$OFFSET))
ELSE (SETQ DIRSTART STARTPOS)
(COND (* ;;
((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /))  "DIRSTART updates for duplicates, but NAME may want all the brackets")
FILE POS))
(EQ (CHARCODE %:)
(NTHCHARCODE 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))
(SETQ POS (ADD1 TEM))
(SETQ HOSTP T)))
(COND
((EQ DIRFLG 'RETURN) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")
(LET ((TYPE 'DIRECTORY)
(START (SELCHARQ (NTHCHARCODE FILE POS)
(NIL (* ; "just host, return")
(RETURN (DREVERSE VAL)))
((/ <) (* ;
 "Started with the initial directory delimiter.")
(ADD1 POS))
POS))
END)
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
((/ >)
[COND
((EQ START POS) (* ;
 "Didn't start with a directory delimiter,")
(COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
(SETQ TYPE 'SUBDIRECTORY))
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
(SETQ TYPE 'RELATIVEDIRECTORY]
(COND
((EQ LEN POS) (* ;
 "Only the initial directory is specified (i.e. %"{DSK}/%").")
(SETQ START POS)
-1)
(T -2)))
(PROGN [COND
[(EQ START POS) (* ;
 "Both of the initial and trail delimiters are omitted.")
(COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
(SETQ TYPE 'SUBDIRECTORY))
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
(SETQ TYPE 'RELATIVEDIRECTORY]
(T (COND
((EQ LEN POS)
(* ;
 "Only the initial directory is specified (i.e. %"{DSK}<%").")
(SETQ START POS]
-1)))
(UNPACKFILE1.DIRECTORY TYPE START END))
(RETURN (DREVERSE VAL)))
((SELCHARQ (NTHCHARCODE FILE POS)
(/ (* ;
 "unix and the 'xerox standard' use / for delimiter")
(* ;
 "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
(SETQ TEM (LASTCHPOS (CHARCODE (/ >))
FILE
(ADD1 POS)))
T)
((< >) (* ;
 "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
(* ;
 "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
FILE
(ADD1 POS)))
T)
NIL)
(* ;; "allow {DSK}/etc to be a directory specification.") (SETQ DIRBRKSTART STARTPOS))
[SETQ NAMESTART (SETQ NAMEEND (SETQ EXTENSIONSTART (SETQ VERSIONSTART
NIL]))
((> /) (* ; "Preceding string is for sure a directory that maybe ends here (unless we're already in an extension")
(IF DIRSTART
THEN
(* ;;
 "Advance over initial duplicate brackets (but DIRSTART could be a subdirectory character)")
(if TEM (CL:WHEN [AND (EQ DIRSTART (SUB1 $$OFFSET))
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS) (FMEMB (\GETBASECHAR $$FATP $$BASE (SUB1 $$OFFSET))
(SUB1 TEM)) (CHARCODE (> / <]
(SETQ POS (ADD1 TEM)) (SETQ DIRSTART $$OFFSET))
else ELSE (SETQ DIRSTART STARTPOS)
(* ;; "{DSK}/foo: the directory is /, the name is foo") (SETQ DIRBRKSTART STARTPOS))
(IF DIREND
THEN (CL:UNLESS (EQ DIREND (SUB1 $$OFFSET))
(CL:WHEN [OR (EQ (\GETBASECHAR $$FATP $$BASE DIREND)
(CHARCODE /))
(FMEMB (\GETBASECHAR $$FATP $$BASE (ADD1 DIREND)
)
(CHARCODE (> /]
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS) (* ;;
(SETQ POS (ADD1 POS)))  "Previous end may have started an internal duplicate run that needs to be cleaned up")
(SETQ HOSTP T))
((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
FILE POS)) (* ; " {eris}abc> relative")
(* ;; (SETQ DIRDIRTY T))
 " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.") (SETQ DIREND $$OFFSET))
ELSE
(* ;;
 "If this is the last bracket, it will be thrown out so it doesn't matter if it is /")
[COND (SETQ DIREND $$OFFSET))
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
then 'DIRECTORY
else 'SUBDIRECTORY)
POS
(SUB1 TEM)))
(T (* ; "True %"relative pathname%".")
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
then 'DIRECTORY
else 'RELATIVEDIRECTORY)
POS
(SUB1 TEM]
(SETQ POS (ADD1 TEM))
(SETQ HOSTP T)))
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (DREVERSE VAL)))
(if (EQ OSTYPE T)
then (* ;
 "There wasn't a host field in the name, so we have no clue")
(SETQ OSTYPE NIL))
NAMELP
(* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.") (* ;; "NAME keeps duplicates, may want all the brackets.")
(SELCHARQ CODE (SETQ DIRBRKEND $$OFFSET)
(%. (* ;
 "Note position for later--we only want to deal with the last set of dots") (* ;; "Toss all prior guesses")
(if BEYONDNAME
then (* ; [SETQ NAMESTART (SETQ NAMEEND (SETQ EXTENSIONSTART (SETQ VERSIONSTART NIL])
 "no longer of interest (probably a bad name, too)") (%. (CL:UNLESS NAMESTART
elseif FIRSTDOT (SETQ NAMESTART (IF DIREND
then (* ; "We're recording the second dot") THEN (ADD1 DIRBRKEND)
(if SECONDDOT ELSE STARTPOS)))
then (* ; (CL:UNLESS (EQ NAMESTART $$OFFSET) (* ;
 "Note only the two most recent dots")  "Allow . in first NAME position : .git")
(SETQ FIRSTDOT SECONDDOT)) (SETQ NAMEEND (SUB1 $$OFFSET))
(SETQ SECONDDOT TEM) (SETQ EXTENSIONSTART $$OFFSET)))
else (SETQ FIRSTDOT TEM))) (; (CL:WHEN VERSIONSTART (* ; "What about x;1;2")
((! ; NIL) (* ;
 "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now") (* ;; "This gives old behavior is NAME=x, VERSION=1;2")
(if (SELCHARQ CODE
(! (* ; (* ;;
 "! is only a delimiter on IFS, so ignore it if we know the ostype is something else")  "If take this out: NAME=x;1, VERSION=2. I.e. move the previous version to an earlier field")
(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") (GO $$ITERATE))
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
NIL) (* ;; "Starting a version, close up preceders")
then (GO NEXTCHAR))
(if FIRSTDOT (CL:UNLESS NAMESTART (* ; "We haven't seen a directory")
then (* ; (SETQ NAMESTART (IF DIREND
 "Have a name and/or extension to parse now") THEN (ADD1 DIRBRKEND)
(if ELSE STARTPOS)))
[AND SECONDDOT (CL:IF EXTENSIONSTART
(NOT (if OSTYPE (SETQ EXTENSIONEND (SUB1 $$OFFSET))
then (* ; (SETQ NAMEEND (SUB1 $$OFFSET)))
 "Known OS type must be Tops20 for second dot to mean version") (SETQ VERSIONSTART $$OFFSET))
(EQ OSTYPE 'TOPS20) (%'
else (* ; (* ;;
 "Unknown OS type, so check that %"version%" is numeric or wildcard")  "Quote the next character (if there is one: original returns empty string in this case).")
(AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM)
bind CH (* ;; "But this is odd: Shouldn't quotes be removed from our value, and reinserted by PACKFILENAME ? Do devices know about our quoting conventions? What about back-slash quoting?")
always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I
))) (ADD $$OFFSET 1))
(EQ CH (CHARCODE *] (!
(SELCHARQ CODE (* ;; "! is a Xerox IFS version marker, coerce to ;")
(NIL (* ; "end of file name, ok")
T) (CL:WHEN (FMEMB OSTYPE '(T NIL))
(; (* ; (SETQ OSTYPE (OR (GETHOSTINFO HOST 'OSTYPE)
 "This semi-colon better not be introducing a version") 'IFS)))
(\UPF.TEMPFILEP FILE (ADD1 TEM))) (CL:WHEN (EQ OSTYPE 'IFS)
NIL] (SETQ C (CHARCODE ;))
then (* ; (GO COERCE)))
 "Second dot is not intoducing a version") NIL)
(SETQ FIRSTDOT SECONDDOT) FINALLY
(SETQ SECONDDOT NIL))
(UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT)) (* ;; "Adjudicate directory and name. Empty NAME uses DIRBRKSTART and DIRBRKEND, since names retain duplicate brackets.")
(SETQ POS (ADD1 (if SECONDDOT
then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT) (IF DIREND
(SUB1 SECONDDOT)) THEN
(SETQ BEYONDEXT T) (* ;;
SECONDDOT  "NAME is squeezed between directory and extension, version, or end. ")
else FIRSTDOT)))
(SETQ BEYONDNAME T) (CL:UNLESS NAMESTART
(SETQ FIRSTDOT NIL)) (CL:WHEN (OR NAMEEND (ILESSP DIRBRKEND $$END))
(UNPACKFILE1 (COND (SETQ NAMESTART (ADD1 DIRBRKEND))))
((NOT BEYONDNAME) ELSEIF DIRSTART
(SETQQ BEYONDNAME NAME)) THEN (* ; "DIR ran off the end")
((NOT BEYONDEXT) (IF (FMEMB (\GETBASECHAR $$FATP $$BASE DIRSTART)
'EXTENSION) (CHARCODE (< /)))
((AND (EQ BEYONDEXT (CHARCODE ";")) THEN (SETQ DIREND DIRSTART) (* ; "<aaa -> DIR < NAME aaa")
(\UPF.TEMPFILEP FILE POS))) (CL:UNLESS (EQ DIRSTART $$END)
(T (* ; (SETQ NAMESTART (ADD1 DIRBRKSTART)))
 "Everything after the semi was version") ELSE (SETQ NAMESTART DIRBRKSTART)
'VERSION)) (* ; "aaaa<xxx --> NAME aaa<xxx")
POS (SETQ DIRSTART NIL))
(SUB1 TEM)) ELSEIF (ILEQ STARTPOS $$END)
(if (NULL CODE) THEN
then (* ; "End of string") (* ;; "Host/device were not exhaustive")
(RETURN (DREVERSE VAL)))
(SETQ BEYONDEXT CODE) (* ; (SETQ NAMESTART STARTPOS))
 "Note the character that terminated the name/ext")
(SETQ POS (ADD1 TEM))) (* ;; "")
(%' (* ; "Quoter")
(add TEM 1)) (* ;; " DIRFLG is RETURN on calls (\UPFDirectoryNameP CL:USER-HOMEDIR-PATHNAME) where FILE is known to have no more than a directory, but the directory might not end with / or > (e.g. %"{DSK}/Users/kaplan%". If we don't do something, %"kaplan%" would be seen as the NAME. ")
NIL)
NEXTCHAR (CL:WHEN [AND (EQ DIRFLG 'RETURN)
(SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (NOT (FMEMB (\GETBASECHAR $$FATP $$BASE $$END)
(GO NAMELP]) (CHARCODE (> / <]
(SETQ DIRSTART STARTPOS)
(SETQ DIREND (ADD1 $$END))
(SETQ DIRDIRTY T)
(SETQ NAMESTART (SETQ EXTENSIONSTART (SETQ VERSIONSTART NIL))))
(* ;;
 "Construct the return value. DIRFLG=FIELD on calls from FILENAMEFIELD, with a ONEFIELDFLG.")
(* ;; "Fields are interrogated backwards so no need to reverse")
RETURNVALUE
(RETURN (FOR F FVAL
INSIDE (OR ONEFIELDFLG
'(VERSION EXTENSION NAME RELATIVEDIRECTORY SUBDIRECTORY
DIRECTORY DEVICE HOST))
WHEN (SETQ FVAL
(SELECTQ F
(HOST HOST)
(DEVICE (CL:WHEN DEVICESTART
(* ;;
 "Unless CLFLG, include the colon so NIL: works as atom")
(\UPF.EXTRACT DEVICESTART (CL:IF CLFLG
(SUB1 DEVICEEND)
DEVICEEND))))
(DIRECTORY
(* ;; "Subtypes move up to DIRECTORY if FIELD")
(CL:WHEN [AND DIRSTART (OR (EQ 'DIRECTORY
(\UPF.DIRTYPE
DIRSTART))
(EQ DIRFLG
'FIELD]
(\UPF.DIRECTORY DIRSTART DIREND DIRDIRTY
$$BASE $$FATP $$READONLY)))
((SUBDIRECTORY RELATIVEDIRECTORY)
(CL:WHEN (AND DIRSTART (EQ F (\UPF.DIRTYPE DIRSTART))
(NEQ DIRFLG 'FIELD))
(\UPF.DIRECTORY DIRSTART DIREND DIRDIRTY $$BASE
$$FATP $$READONLY)))
(NAME (CL:WHEN NAMESTART
(OR (\UPF.EXTRACT NAMESTART (OR NAMEEND $$END))
"")))
(EXTENSION (CL:WHEN EXTENSIONSTART
(OR (\UPF.EXTRACT (ADD1 EXTENSIONSTART)
(OR EXTENSIONEND $$END))
"")))
(VERSION (CL:WHEN VERSIONSTART
(OR (\UPF.EXTRACT (ADD1 VERSIONSTART)
$$END)
"")))
NIL)) DO (CL:WHEN PACKFLG
(SETQ FVAL (CL:UNLESS (EQ 0 (NCHARS FVAL))
(* ;;
 "Empty string goes to NIL, not empty atom")
(MKATOM FVAL))))
(CL:WHEN ONEFIELDFLG (RETURN FVAL))
(PUSH $$VAL F FVAL])
(\UPF.DIRECTORY
[LAMBDA (DIRSTART DIREND DIRDIRTY $$BASE $$FATP $$READONLY)(* ; "Edited 28-Apr-2022 09:15 by rmk")
(* ; "Edited 27-Apr-2022 08:50 by rmk")
(* ; "Edited 23-Apr-2022 17:09 by rmk")
(* ;; "Relative directory {abc}<foo or {abc}< with no >, subdirectory >foo or > with no host or device (DIRSTART=1). ")
(* ;; "Advance DIRSTART through initial duplicates")
(LET ((BRACKET (SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
((< /)
"<")
(> ">")
NIL)))
(IF (EQ DIREND DIRSTART)
THEN
(* ;; "If EQ, the directory is just the bracket, the rest is must be the name.")
BRACKET
ELSE (CL:WHEN BRACKET (* ; "Skip the < or /")
(ADD DIRSTART 1))
(* ;;
 "Convert / to >, remove all // /> >> duplicate sequences (keep the first, skip the others)")
(IF DIRDIRTY
THEN (FOR DIROFF C DEST DESTBASE (DESTPOS _ -1) FROM DIRSTART TO DIREND
FIRST (SETQ DEST (ALLOCSTRING (ADD1 (IDIFFERENCE DIREND DIRSTART))
NIL NIL $$FATP))
(SETQ DESTBASE (FETCH (STRINGP BASE) OF DEST))
DO (ADD DESTPOS 1)
(SETQ C (\GETBASECHAR $$FATP $$BASE DIROFF))
(SELCHARQ C
((> /)
(\PUTBASECHAR $$FATP DESTBASE DESTPOS (CHARCODE >))
(* ;; "Advance past duplicates")
(FIND I FROM (ADD1 DIROFF) TO DIREND
WHILE (FMEMB (\GETBASECHAR $$FATP $$BASE I)
(CHARCODE (> /)))
FINALLY (SETQ DIROFF (SUB1 I))))
(\PUTBASECHAR $$FATP DESTBASE DESTPOS C))
FINALLY (REPLACE (STRINGP LENGTH) OF DEST WITH DESTPOS)
(RETURN DEST))
ELSE (\UPF.EXTRACT DIRSTART (SUB1 DIREND])
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS \UPF.EXTRACT MACRO ((STARTOFFSET ENDOFFSET) (* ; "Substring in base coordinates")
(CREATE STRINGP
OFFST _ STARTOFFSET
LENGTH _ (ADD1 (IDIFFERENCE ENDOFFSET STARTOFFSET))
BASE _ $$BASE
READONLY _ $$READONLY)))
(PUTPROPS \UPF.DIRTYPE MACRO [(DIRSTART) (* ; "Edited 20-Apr-2022 20:14 by rmk")
(SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
((< > /) (* ; "Seems to match the old version")
'DIRECTORY)
(CL:IF (OR HOST DEVICESTART)
'RELATIVEDIRECTORY
'SUBDIRECTORY)])
)
(DECLARE%: EVAL@COMPILE
(RPAQ FILENAMECODES (CHARCODE (%: < > / %. ; ! %')))
(RPAQ MINFILENAMECODE (APPLY (FUNCTION IMIN)
FILENAMECODES))
(RPAQ MAXFILENAMECODE (APPLY (FUNCTION IMAX)
FILENAMECODES))
(CONSTANTS (FILENAMECODES (CHARCODE (%: < > / %. ; ! %')))
(MINFILENAMECODE (APPLY (FUNCTION IMIN)
FILENAMECODES))
(MAXFILENAMECODE (APPLY (FUNCTION IMAX)
FILENAMECODES)))
)
)
(DEFINEQ
(UNPACKFILENAME
[LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:")
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])
(LASTCHPOS (LASTCHPOS
[LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER") [LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER")
@@ -564,26 +724,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(add START 1)) (add START 1))
(RETURN RESULT]) (RETURN RESULT])
(\UPF.NEXTPOS
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND
((EQMEMB NCH CHAR)
(RETURN POS))
((EQ NCH (CHARCODE %'))
(add POS 1)))
(add POS 1])
(\UPF.TEMPFILEP
[LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:")
(* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.")
(SELCHARQ (NTHCHARCODE FILENAME START)
((T S) (* ; "Funny temp stuff")
(AND (EQ START (NCHARS FILENAME))
'TEMPORARY))
NIL])
(FILENAMEFIELD (FILENAMEFIELD
[LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm") [LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm")
(UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME
@@ -626,94 +766,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE
(PUTPROPS CANONICAL.DIRECTORY MACRO
[OPENLAMBDA (SRCSTRING)
(AND
SRCSTRING
(LET
((LEN (NCHARS SRCSTRING)))
(COND
((EQ LEN 1)
(if (STREQUAL SRCSTRING "/")
then "<"
else SRCSTRING))
(T
(LET*
((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
(DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
(DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
(DSTPOS 0)
(NEXTPOS -1))
(if (NOT FATP)
then [for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
(if (> SRCPOS LEN)
then (RETURN "<"))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
(SETQ NEXTPOS (add DSTPOS 1))))
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASETHIN DSTBASE DSTPOS
(NTHCHARCODE SRCSTRING (add SRCPOS 1)))
(add DSTPOS 1)))
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS]
else (for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
(SETQ NEXTPOS (add DSTPOS 1))))
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE
SRCSTRING
(add SRCPOS 1)))
(add DSTPOS 1)))
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS])
(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
(LET* ((OLDDIR (SUBSTRING FILE ST END))
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND
(PACKFLG (AND NEWDIR
(MKATOM NEWDIR)))
(T (OR NEWDIR "")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
(T (OR NEWDIR ""])
(PUTPROPS PACKFILENAME.ASSEMBLE MACRO (PUTPROPS PACKFILENAME.ASSEMBLE MACRO
[NIL [NIL
(PROG ((BLIP "") (PROG ((BLIP "")
@@ -925,20 +977,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
((%. ! ;) ((%. ! ;)
(SUBSTRING VERSION 2 -1)) (SUBSTRING VERSION 2 -1))
VERSION]) VERSION])
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND
(PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
"")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
""])
) )
) )
@@ -1188,15 +1226,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 (PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
1991 1992 1920 2017 2020 2021)) 1991 1992 1920 2017 2020 2021))
(DECLARE%: DONTCOPY (DECLARE%: DONTCOPY
(FILEMAP (NIL (2837 13962 (DELFILE 2847 . 3008) (FULLNAME 3010 . 3377) (INFILE 3379 . 3527) (INFILEP (FILEMAP (NIL (3179 14304 (DELFILE 3189 . 3350) (FULLNAME 3352 . 3719) (INFILE 3721 . 3869) (INFILEP
3529 . 3664) (IOFILE 3666 . 3806) (OPENFILE 3808 . 4208) (OPENSTREAM 4210 . 8550) (OUTFILE 8552 . 8703 3871 . 4006) (IOFILE 4008 . 4148) (OPENFILE 4150 . 4550) (OPENSTREAM 4552 . 8892) (OUTFILE 8894 . 9045
) (OUTFILEP 8705 . 8841) (RENAMEFILE 8843 . 9149) (SIMPLE.FINDFILE 9151 . 9561) (VMEMSIZE 9563 . 9730) ) (OUTFILEP 9047 . 9183) (RENAMEFILE 9185 . 9491) (SIMPLE.FINDFILE 9493 . 9903) (VMEMSIZE 9905 . 10072
(\COPYSYS 9732 . 12681) (\FLUSHVM 12683 . 13755) (\LOGOUT0 13757 . 13960)) (14334 35147 ( ) (\COPYSYS 10074 . 13023) (\FLUSHVM 13025 . 14097) (\LOGOUT0 14099 . 14302)) (14676 36581 (
UNPACKFILENAME 14344 . 14530) (UNPACKFILENAME.STRING 14532 . 31445) (LASTCHPOS 31447 . 32141) ( UNPACKFILENAME.STRING 14686 . 33960) (\UPF.DIRECTORY 33962 . 36579)) (38109 40781 (UNPACKFILENAME
\UPF.NEXTPOS 32143 . 32788) (\UPF.TEMPFILEP 32790 . 33367) (FILENAMEFIELD 33369 . 33854) ( 38119 . 38305) (LASTCHPOS 38307 . 39001) (FILENAMEFIELD 39003 . 39488) (FILENAMEFIELD.STRING 39490 .
FILENAMEFIELD.STRING 33856 . 34435) (PACKFILENAME 34437 . 34780) (PACKFILENAME.STRING 34782 . 35145)) 40069) (PACKFILENAME 40071 . 40414) (PACKFILENAME.STRING 40416 . 40779)) (55251 56164 (
(56669 57582 (FILEDIRCASEARRAY 56679 . 57580)) (57749 64929 (LOGOUT 57759 . 58676) (MAKESYS 58678 . FILEDIRCASEARRAY 55261 . 56162)) (56331 63511 (LOGOUT 56341 . 57258) (MAKESYS 57260 . 58889) (SYSOUT
60307) (SYSOUT 60309 . 61861) (SAVEVM 61863 . 62663) (HERALD 62665 . 62825) (INTERPRET.REM.CM 62827 . 58891 . 60443) (SAVEVM 60445 . 61245) (HERALD 61247 . 61407) (INTERPRET.REM.CM 61409 . 63134) (
64552) (\USEREVENT 64554 . 64927)) (65111 66838 (USERNAME 65121 . 66077) (SETUSERNAME 66079 . 66836))) \USEREVENT 63136 . 63509)) (63693 65420 (USERNAME 63703 . 64659) (SETUSERNAME 64661 . 65418)))))
))
STOP STOP

BIN
sources/ADIR.LCOM
View File

Binary file not shown.

546
sources/TESTUPF Normal file
View File

@@ -0,0 +1,546 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-May-2022 12:30:29" 
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>TESTUPF.;1 32843 )
(PRETTYCOMPRINT TESTUPFCOMS)
(RPAQQ TESTUPFCOMS
((COMS (* ; "Original code")
(FNS OLD-UNPACKFILENAME.STRING \UPF.NEXTPOS \UPF.TEMPFILEP)
(DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY UNPACKFILE1)))
(* ;; "Debugging")
(* ;; "DOTTEDNAMES: mismatch intended")
(* ;; "RETURNFAILS: mismatch with DIRFLG=RETURN, DIRECTORY and SUBDIRECTORY are swapped. But original doesn't agree with its own complete analaysis.")
(VARS DOTTEDNAMES TESTS RETURNFAILS)
(FNS TRY TRYALL DT)))
(* ; "Original code")
(DEFINEQ
(OLD-UNPACKFILENAME.STRING
[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")
(* ;;; "rmk: devices must come before directories.")
(PROG ((POS 1)
(LEN (NCHARS FILE))
TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI)
(COND
((NULL FILE)
(RETURN NIL))
((OR (LITATOM FILE)
(STRINGP FILE)
(NUMBERP FILE)))
((TYPEP FILE 'PATHNAME)
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
[(STREAMP FILE) (* ;
 "For streams, use full name. If anonymous, fake it")
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
(RETURN (COND
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
FILE))
(T (LIST 'NAME FILE]
(T (\ILLEGAL.ARG FILE)))
(COND
((SELCHARQ (NTHCHARCODE FILE 1)
({ (* ; "normal use in Interlisp-D")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
FILE 2)
0))))
(%[ (* ;
 "some Xerox and Arpanet systems use '[' for host")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
FILE 2)
0))))
(%( (* ;
 "this is the 'proposed standard' for Xerox servers")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
FILE 2)
0))))
NIL)
(UNPACKFILE1 'HOST 2 TEM)
[COND
((EQ TEM -1) (* ;
 "Started with the host field delimiter, but there was no corresponding terminating delimiter .")
(* ;
 "I'm not sure why the name is dealt with the host name.")
(RETURN (DREVERSE VAL]
(SETQ POS (IPLUS TEM 2))
[if (EQ OSTYPE T)
then (* ;
 "Use actual host to determine os type")
(SETQ OSTYPE (GETHOSTINFO (CAR VAL)
'OSTYPE]
(SETQ HOSTP T)))
(* ;; "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
((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /))
FILE POS))
(EQ (CHARCODE %:)
(NTHCHARCODE 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))
(SETQ POS (ADD1 TEM))
(SETQ HOSTP T)))
(COND
((EQ DIRFLG 'RETURN) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")
(LET ((TYPE 'DIRECTORY)
(START (SELCHARQ (NTHCHARCODE FILE POS)
(NIL (* ; "just host, return")
(RETURN (DREVERSE VAL)))
((/ <) (* ;
 "Started with the initial directory delimiter.")
(ADD1 POS))
POS))
END)
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
((/ >)
[COND
((EQ START POS) (* ;
 "Didn't start with a directory delimiter,")
(COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
(SETQ TYPE 'SUBDIRECTORY))
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
(SETQ TYPE 'RELATIVEDIRECTORY]
(COND
((EQ LEN POS) (* ;
 "Only the initial directory is specified (i.e. %"{DSK}/%").")
(SETQ START POS)
-1)
(T -2)))
(PROGN [COND
[(EQ START POS) (* ;
 "Both of the initial and trail delimiters are omitted.")
(COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
(SETQ TYPE 'SUBDIRECTORY))
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
(SETQ TYPE 'RELATIVEDIRECTORY]
(T (COND
((EQ LEN POS)
(* ;
 "Only the initial directory is specified (i.e. %"{DSK}<%").")
(SETQ START POS]
-1)))
(UNPACKFILE1.DIRECTORY TYPE START END))
(RETURN (DREVERSE VAL)))
((SELCHARQ (NTHCHARCODE FILE POS)
(/ (* ;
 "unix and the 'xerox standard' use / for delimiter")
(* ;
 "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
(SETQ TEM (LASTCHPOS (CHARCODE (/ >))
FILE
(ADD1 POS)))
T)
((< >) (* ;
 "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
(* ;
 "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
FILE
(ADD1 POS)))
T)
NIL)
(* ;; "allow {DSK}/etc to be a directory specification.")
(if TEM
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
(SUB1 TEM))
(SETQ POS (ADD1 TEM))
else
(* ;; "{DSK}/foo: the directory is /, the name is foo")
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
(SETQ POS (ADD1 POS)))
(SETQ HOSTP T))
((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
FILE POS)) (* ; " {eris}abc> relative")
(* ;;
 " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
[COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
then 'DIRECTORY
else 'SUBDIRECTORY)
POS
(SUB1 TEM)))
(T (* ; "True %"relative pathname%".")
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
then 'DIRECTORY
else 'RELATIVEDIRECTORY)
POS
(SUB1 TEM]
(SETQ POS (ADD1 TEM))
(SETQ HOSTP T)))
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (DREVERSE VAL)))
(if (EQ OSTYPE T)
then (* ;
 "There wasn't a host field in the name, so we have no clue")
(SETQ OSTYPE NIL))
NAMELP
(* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.")
(SELCHARQ CODE
(%. (* ;
 "Note position for later--we only want to deal with the last set of dots")
(if BEYONDNAME
then (* ;
 "no longer of interest (probably a bad name, too)")
elseif FIRSTDOT
then (* ; "We're recording the second dot")
(if SECONDDOT
then (* ;
 "Note only the two most recent dots")
(SETQ FIRSTDOT SECONDDOT))
(SETQ SECONDDOT TEM)
else (SETQ FIRSTDOT TEM)))
((! ; NIL) (* ;
 "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
(if (SELCHARQ CODE
(! (* ;
 "! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
(AND OSTYPE (NEQ OSTYPE 'IFS)))
(; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S")
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
NIL)
then (GO NEXTCHAR))
(if FIRSTDOT
then (* ;
 "Have a name and/or extension to parse now")
(if
[AND SECONDDOT
(NOT (if OSTYPE
then (* ;
 "Known OS type must be Tops20 for second dot to mean version")
(EQ OSTYPE 'TOPS20)
else (* ;
 "Unknown OS type, so check that %"version%" is numeric or wildcard")
(AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM)
bind CH
always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I
)))
(EQ CH (CHARCODE *]
(SELCHARQ CODE
(NIL (* ; "end of file name, ok")
T)
(; (* ;
 "This semi-colon better not be introducing a version")
(\UPF.TEMPFILEP FILE (ADD1 TEM)))
NIL]
then (* ;
 "Second dot is not intoducing a version")
(SETQ FIRSTDOT SECONDDOT)
(SETQ SECONDDOT NIL))
(UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
(SETQ POS (ADD1 (if SECONDDOT
then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
(SUB1 SECONDDOT))
(SETQ BEYONDEXT T)
SECONDDOT
else FIRSTDOT)))
(SETQ BEYONDNAME T)
(SETQ FIRSTDOT NIL))
(UNPACKFILE1 (COND
((NOT BEYONDNAME)
(SETQQ BEYONDNAME NAME))
((NOT BEYONDEXT)
'EXTENSION)
((AND (EQ BEYONDEXT (CHARCODE ";"))
(\UPF.TEMPFILEP FILE POS)))
(T (* ;
 "Everything after the semi was version")
'VERSION))
POS
(SUB1 TEM))
(if (NULL CODE)
then (* ; "End of string")
(RETURN (DREVERSE VAL)))
(SETQ BEYONDEXT CODE) (* ;
 "Note the character that terminated the name/ext")
(SETQ POS (ADD1 TEM)))
(%' (* ; "Quoter")
(add TEM 1))
NIL)
NEXTCHAR
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
(GO NAMELP])
(\UPF.NEXTPOS
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND
((EQMEMB NCH CHAR)
(RETURN POS))
((EQ NCH (CHARCODE %'))
(add POS 1)))
(add POS 1])
(\UPF.TEMPFILEP
[LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:")
(* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.")
(SELCHARQ (NTHCHARCODE FILENAME START)
((T S) (* ; "Funny temp stuff")
(AND (EQ START (NCHARS FILENAME))
'TEMPORARY))
NIL])
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS CANONICAL.DIRECTORY MACRO
[OPENLAMBDA (SRCSTRING)
(AND
SRCSTRING
(LET
((LEN (NCHARS SRCSTRING)))
(COND
((EQ LEN 1)
(if (STREQUAL SRCSTRING "/")
then "<"
else SRCSTRING))
(T
(LET*
((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
(DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
(DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
(DSTPOS 0)
(NEXTPOS -1))
(if (NOT FATP)
then [for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
(if (> SRCPOS LEN)
then (RETURN "<"))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
(SETQ NEXTPOS (add DSTPOS 1))))
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASETHIN DSTBASE DSTPOS
(NTHCHARCODE SRCSTRING (add SRCPOS 1)))
(add DSTPOS 1)))
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS]
else (for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
(SETQ NEXTPOS (add DSTPOS 1))))
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE
SRCSTRING
(add SRCPOS 1)))
(add DSTPOS 1)))
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS])
(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
(LET* ((OLDDIR (SUBSTRING FILE ST END))
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND
(PACKFLG (AND NEWDIR
(MKATOM NEWDIR)))
(T (OR NEWDIR "")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
(T (OR NEWDIR ""])
(PUTPROPS 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)
""])
)
)
(* ;; "Debugging")
(* ;; "DOTTEDNAMES: mismatch intended")
(* ;;
"RETURNFAILS: mismatch with DIRFLG=RETURN, DIRECTORY and SUBDIRECTORY are swapped. But original doesn't agree with its own complete analaysis."
)
(RPAQQ DOTTEDNAMES (".x" ">.git" "x.y.100"))
(RPAQQ TESTS
("*,;" "*.*;*" "*.;" "*.;*" "///abc/x" "/abc.x" "<" "<<<abc" "<<<abc>" "<<<abc>>" "<<<abc>x"
"<<abc" "<<xyz>>>zz" "<<xyz>>>zzz/" "<<xyz>>zz" "<<xyz>zz" "<ABC>" "<XYZ>aa" "<a.b>"
"<a;b>" "<ab;c" "<ab>" "<abc" "<abc*." "<abc.x" "<abc.x;1" "<abc;x" "<abc<<<x"
"<abc<xyz<foo" "<abc<xyz>qrs" "<abc>" "<abc>;1" "<abc>xyz" "<abc>xyz>foo" "<xxx"
"<xy>>zz" "<xyz>>>zzz/" ">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx"
"A.B.C" "XXX<yyy" "a;b" "a;b/d" "a;b;c" "a;b;c;d" "aa" "aa;" "aa;NEWEST" "aa;newest"
"aaa" "aaa/bbb" "aaa/bbb/" "aaa/xyz;x;m" "aaa<bbb" "aaa<bbb/" "aaa<xyz>" "aaa>bbb>"
"aaa>xyz.e;m;n" "aaa>xyz>qrs" "abc" "abc...c" "abc///XYZ//" "abc/d" "abc/xyz"
"abc/xyz.qrs" "abc/xyz.qrs;2" "abc:x<qrs>z" "abc<<<XYZ//" "abc<x" "abc<xyz"
"abc<xyz>qq" "abc<xyzqq" "abc>;1" "abc>qr.x" "abc>xy" "abc>xyz" "abc>xyz;2"
"dev:aaa>xyz>qrs" "foo:" "foo:aaa<xyz" "foo:aaa<xyz>" "foo:x<qrs>z" "foo<a:B>" "s;n;b"
"x.y.z;w" "x.y;z" "x;y" "x<abc<xyz>qrs" "x<abc<z" "x<abc>z" "xxx<yyy" "xxx<yyy>"
"xxx<yyy>zzz" "xxx>yyy" "xxx>yyy>" "{ABC}" "{ABC}XXX:" "{DSK}" "{DSK}*.;*" "{DSK}...<a"
"{DSK}<a" "{DSK}xxx<a" "{DSK}xxx<xxx>yyy" "{DSK}xxx>xxx" "{DSK}xxx>yyy"
"{HOST}foo:x<qrs>z" "{HOST}x<qrs>z" "{abc}" "{dsk}foo:aaa>b>.c.e.g;f"
"{dsk}foo:aaa>b>.c.e;f" "{dsk}foo:aaa>b>c.e;f" "{eris}abc>" "{host}abc/xyz;2"
"{host}abc>xyz;2" "{x}abc<xyz>qq" "{x}abc<xyzqq" "<abc<xyz>abc" "<abc<xyz>qrs"
"<abc<xyz>"))
(RPAQQ RETURNFAILS (">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx" ">" ">>>abc/x"
">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx"))
(DEFINEQ
(TRY
[LAMBDA (FILE ONEFIELDFLG DIRFLG) (* ; "Edited 23-May-2022 12:09 by rmk")
(* ; "Edited 25-Apr-2022 14:15 by rmk")
(* ; "Edited 24-Apr-2022 08:45 by rmk")
(* ; "Edited 21-Apr-2022 15:36 by rmk")
(CL:WHEN (LISTP (CAR (LISTP FILE)))
(SETQ FILE (CAR FILE)))
(LET (ORIG NEW)
(CL:WHEN (LISTP FILE)
(SETQ ONEFIELDFLG (CADR FILE))
(SETQ DIRFLG (CADDR FILE))
(SETQ FILE (CAR FILE)))
(SETQ ORIG (OLD-UNPACKFILENAME.STRING FILE ONEFIELDFLG DIRFLG))
(SETQ NEW (UNPACKFILENAME.STRING FILE ONEFIELDFLG DIRFLG))
(LIST (LIST FILE ONEFIELDFLG DIRFLG)
(AND (EQUAL ORIG NEW)
'=)
ORIG NEW])
(TRYALL
[LAMBDA (FILES ALLFLAG ONEFIELDFLG DIRFLG) (* ; "Edited 21-Apr-2022 17:56 by rmk")
(* ; "Edited 2-Apr-2022 23:50 by rmk")
(* ; "Edited 31-Mar-2022 22:57 by rmk")
(CL:WHEN (LISTP FILES)
(SETQ FILES (FOR F IN FILES COLLECT (CL:IF (LISTP (CAR (LISTP F)))
(CAR F)
F))))
(FOR FILE INFO (SAME _ 0)
(DIFF _ 0) IN FILES EACHTIME (SETQ INFO (TRY FILE ONEFIELDFLG DIRFLG))
(CL:IF (CADR INFO)
(ADD SAME 1)
(ADD DIFF 1)) UNLESS (AND (CADR INFO)
(NOT ALLFLAG))
COLLECT (PRINTOUT T .P2 (CAAR INFO)
31)
(IF (CADR INFO)
THEN (PRINTOUT T " = " .P2 (CADDR INFO))
(CL:WHEN (OR (CADAR INFO)
(CADDAR INFO))
(PRINTOUT T 60 (CADAR INFO)
%,,
(CADDAR INFO))
(TERPRI T))
ELSE (PRINTOUT T " ~= " -2 "old: " .P2 (CADDR INFO))
(CL:WHEN (OR (CADAR INFO)
(CADDAR INFO))
(PRINTOUT T 60 (CADAR INFO)
%,,
(CADDAR INFO))
(TERPRI T))
(PRINTOUT T 37 "new: " .P2 (CADDDR INFO)
T))
INFO FINALLY (PRINTOUT T SAME " matches, " DIFF " mismatches" T])
(DT
[LAMBDA (STRINGS ALLFLAG) (* ; "Edited 21-Apr-2022 17:53 by rmk")
(* ; "Edited 19-Apr-2022 20:55 by rmk")
(* ;; "Tests the DIRFLG options on STRINGS. If an element of STRINGS is a list, it is assumed to be a (STRING ONEFIELD DIRFLG), STRING is extracted.")
(SETQ STRINGS (FOR S INSIDE STRINGS COLLECT (CL:IF (LISTP S)
(CAR S)
S)))
[AND NIL (FOR ONEFIELD IN '(NAME DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY)
JOIN (FOR DIR ORIG NEW SAME IN '(FIELD RETURN)
JOIN (PRINTOUT T T "ONEFIELDFLG = " ONEFIELD -3 "DIRFLG = " DIR T T)
(TRYALL STRINGS ALLFLAG ONEFIELD DIR))
FINALLY (FOR INFO SAME (DIFF _ 0) IN $$VAL DO (CL:IF (CADR INFO)
(ADD SAME 1)
(ADD DIFF 1))
FINALLY (SETQ SAME (IDIFFERENCE (LENGTH STRINGS)
DIFF))
(PRINTOUT T T "Overall: " SAME " matched, " DIFF " mismatched" T]
(TRYALL (FOR S IN STRINGS JOIN (FOR ONEFIELD IN '(NAME DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY)
JOIN (FOR DIR IN '(FIELD RETURN)
COLLECT (LIST S ONEFIELD DIR])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (893 18981 (OLD-UNPACKFILENAME.STRING 903 . 17808) (\UPF.NEXTPOS 17810 . 18396) (
\UPF.TEMPFILEP 18398 . 18979)) (28216 32820 (TRY 28226 . 29192) (TRYALL 29194 . 31111) (DT 31113 .
32818)))))
STOP

BIN
sources/TESTUPF.LCOM Normal file
View File

Binary file not shown.

23
sources/TESTUPF.TXT Normal file
View File

@@ -0,0 +1,23 @@
TESTUPF contains functions for testing the new implementation of UNPACKFILENAME.STRING (now in ADIR) and the original definition.
The original definition is also provided here, under the name OLD-UNPACKFILENAME.STRING
TESTUPF also includes some test functions, and some of the strings that I have been testing with.
(TRY FILE ONEDIRFLG DIRFLG)
returns a comparison of the behavior of the original version and the new version in a list of the form
(FILE ONEDIRFLG DIRFLG) MATCH ORIG NEW)
where MATCH is = if ORIG and NEW are EQUAL, otherwise NIL. (For convenience, a list of this form can also be passed in as an argument.)
(TRYALL FILES ALLFLG ONDIRFLG DIRFLG)
applies TRY to each file-string in FILES, prints and reports what it discovers. If ALLFLG, it prints the result on every file, otherwise just the mismatches. Value is a list of TRY values that it printed.
(DT FILES) sets up a call to TRYALL for DIRFLG testing (setting DIRFLG NIL, FIELD, RETURN for each file in FILES).
The variable TESTS has the strings that I have tested against, the variable DOTTEDNAMES has the strings that I intend to be different (.cshrc as NAME, not EXTENSION). The new behavior avoids the bug that (PACKFILENAME.STRING 'EXTENSION "txt "BODY ".bashrc") produces ".txt" instead of ".bashrc.txt".
The variable RETURNFAILS is a list of strings with DIRFLG=RETURN that also don¹t match, in that the DIRECTORY and SUBDIRECTORY classifications are inverted between old and new for strings beginning with ª>". But the old code is inconsistent for these inputs: it returns different classifications of those substrings with or without the RETURN. (I think RETURN is for the case "/Users/kaplan" where the caller knows that the whole thing is a directory, doesn¹t want ªkaplanº to be parsed as a name. Just wants it to be normalized, with host and device stripped off.)