From 51d9e995e1a9b4cdb08a1b227e923779e09d4a00 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 23 May 2022 12:48:41 -0700 Subject: [PATCH 1/2] ADIR, TESTUPF: New version of UNPACKFILENAME.STRING with test tool See TESTUPF.TXT for testing information --- sources/ADIR | 811 ++++++++++++++++++++++--------------------- sources/ADIR.LCOM | Bin 24825 -> 19430 bytes sources/TESTUPF | 546 +++++++++++++++++++++++++++++ sources/TESTUPF.LCOM | Bin 0 -> 13624 bytes sources/TESTUPF.TXT | 23 ++ 5 files changed, 993 insertions(+), 387 deletions(-) create mode 100644 sources/TESTUPF create mode 100644 sources/TESTUPF.LCOM create mode 100644 sources/TESTUPF.TXT diff --git a/sources/ADIR b/sources/ADIR index 26e56a82..b549694b 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Mar-2022 09:39:50" {DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;13 67302 +(FILECREATED "23-May-2022 12:02:10" {DSK}kaplan>local>medley3.5>working-medley>sources>ADIR.;14 65884 - :CHANGES-TO (VARS ADIRCOMS) - (FNS FILENAMEFIELD.STRING) + :CHANGES-TO (FNS UNPACKFILENAME.STRING) + (VARS ADIRCOMS) - :PREVIOUS-DATE "26-Jan-2022 10:18:43" -{DSK}kaplan>Local>medley3.5>my-medley>sources>ADIR.;12) + :PREVIOUS-DATE "26-Mar-2022 09:39:50" +{DSK}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.") (MOVD? 'NILL 'CL:PATHNAMEP] - (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP - FILENAMEFIELD FILENAMEFIELD.STRING PACKFILENAME PACKFILENAME.STRING) - (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY - PACKFILENAME.ASSEMBLE UNPACKFILE1)) + [COMS (FNS UNPACKFILENAME.STRING \UPF.DIRECTORY) + (DECLARE%: DONTCOPY (MACROS \UPF.EXTRACT \UPF.DIRTYPE) + (CONSTANTS (FILENAMECODES (CHARCODE (%: < > / %. ; ! %'))) + (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) (FNS FILEDIRCASEARRAY) (VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY))) @@ -284,273 +290,427 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo ) (DEFINEQ -(UNPACKFILENAME - [LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:") - (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T]) - (UNPACKFILENAME.STRING - [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 25-Jan-2022 17:16 by rmk") - (* ; "Edited 5-Jan-2022 11:03 by rmk") - (* ; "Edited 30-Mar-90 22:37 by nm") + [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 28-Apr-2022 11:40 by rmk") + (* ; "Edited 24-Apr-2022 14:11 by rmk") -(* ;;; "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) - (LEN (NCHARS FILE)) - TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) + (* ;; "From the front, the host and device are unmistakable:") + + (* ;; " 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<]) (directory >) ) (name) (. (extension)) (; (version))") + + (* ;; " where: if the directory field begins with < or > but doesn't end later in >, directory is the < or >") + + (* ;; + " name doesn't contain <, >, or ;, May begin with . (differs from original)") + + (* ;; " extension doesn't contain . and version doesn't contain ") + + (* ;; "") + + (* ;; "NOTE: We use FILE's block coorinate system for all markers.") + + (RETURN + (FOR C HOST HOSTSTART HOSTEND HOSTENDCHAR STARTPOS DEVICESTART DEVICEEND DIRSTART DIREND + DIRBRKSTART DIRBRKEND DIRDIRTY NAMESTART NAMEEND EXTENSIONSTART EXTENSIONEND + 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.") - (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))) + "Ordinary character if already started directory or in an extension") + (IF DIRSTART + THEN + (* ;; "DIRECTORY advances over initial duplicate brackets (but DIRSTART could be a subdirectory character instead)") - (* ;; "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 (%: < /)) - 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} /)) - FILE - (ADD1 POS))) - T) - NIL) + (* ;; + "DIRSTART updates for duplicates, but NAME may want all the brackets") - (* ;; "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 - then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS) - (SUB1 TEM)) - (SETQ POS (ADD1 TEM)) - else - (* ;; "{DSK}/foo: the directory is /, the name is foo") + (CL:WHEN [AND (EQ DIRSTART (SUB1 $$OFFSET)) + (FMEMB (\GETBASECHAR $$FATP $$BASE (SUB1 $$OFFSET)) + (CHARCODE (> / <] + (SETQ DIRSTART $$OFFSET)) + ELSE (SETQ DIRSTART STARTPOS) + (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))) - (SETQ HOSTP T)) - ((SETQ TEM (LASTCHPOS (CHARCODE (/ >)) - FILE POS)) (* ; " {eris}abc> relative") + (* ;; + "Previous end may have started an internal duplicate run that needs to be cleaned up") - (* ;; - " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.") + (SETQ DIRDIRTY T)) + (SETQ DIREND $$OFFSET)) + ELSE + (* ;; + "If this is the last bracket, it will be thrown out so it doesn't matter if it is /") - [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 - + (SETQ DIREND $$OFFSET)) - (* ;; "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 - (%. (* ; - "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]) + (SETQ DIRBRKEND $$OFFSET) + + (* ;; "Toss all prior guesses") + + [SETQ NAMESTART (SETQ NAMEEND (SETQ EXTENSIONSTART (SETQ VERSIONSTART NIL]) + (%. (CL:UNLESS NAMESTART + (SETQ NAMESTART (IF DIREND + THEN (ADD1 DIRBRKEND) + ELSE STARTPOS))) + (CL:UNLESS (EQ NAMESTART $$OFFSET) (* ; + "Allow . in first NAME position : .git") + (SETQ NAMEEND (SUB1 $$OFFSET)) + (SETQ EXTENSIONSTART $$OFFSET))) + (; (CL:WHEN VERSIONSTART (* ; "What about x;1;2") + + (* ;; "This gives old behavior is NAME=x, VERSION=1;2") + + (* ;; + "If take this out: NAME=x;1, VERSION=2. I.e. move the previous version to an earlier field") + + (GO $$ITERATE)) + + (* ;; "Starting a version, close up preceders") + + (CL:UNLESS NAMESTART (* ; "We haven't seen a directory") + (SETQ NAMESTART (IF DIREND + THEN (ADD1 DIRBRKEND) + ELSE STARTPOS))) + (CL:IF EXTENSIONSTART + (SETQ EXTENSIONEND (SUB1 $$OFFSET)) + (SETQ NAMEEND (SUB1 $$OFFSET))) + (SETQ VERSIONSTART $$OFFSET)) + (%' + (* ;; + "Quote the next character (if there is one: original returns empty string in this case).") + + (* ;; "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?") + + (ADD $$OFFSET 1)) + (! + (* ;; "! is a Xerox IFS version marker, coerce to ;") + + (CL:WHEN (FMEMB OSTYPE '(T NIL)) + (SETQ OSTYPE (OR (GETHOSTINFO HOST 'OSTYPE) + 'IFS))) + (CL:WHEN (EQ OSTYPE 'IFS) + (SETQ C (CHARCODE ;)) + (GO COERCE))) + NIL) + FINALLY + + (* ;; "Adjudicate directory and name. Empty NAME uses DIRBRKSTART and DIRBRKEND, since names retain duplicate brackets.") + + (IF DIREND + THEN + (* ;; + "NAME is squeezed between directory and extension, version, or end. ") + + (CL:UNLESS NAMESTART + (CL:WHEN (OR NAMEEND (ILESSP DIRBRKEND $$END)) + (SETQ NAMESTART (ADD1 DIRBRKEND)))) + ELSEIF DIRSTART + THEN (* ; "DIR ran off the end") + (IF (FMEMB (\GETBASECHAR $$FATP $$BASE DIRSTART) + (CHARCODE (< /))) + THEN (SETQ DIREND DIRSTART) (* ; " DIR < NAME aaa") + (CL:UNLESS (EQ DIRSTART $$END) + (SETQ NAMESTART (ADD1 DIRBRKSTART))) + ELSE (SETQ NAMESTART DIRBRKSTART) + (* ; "aaaa NAME aaa (e.g. %"{DSK}/Users/kaplan%". If we don't do something, %"kaplan%" would be seen as the NAME. ") + + (CL:WHEN [AND (EQ DIRFLG 'RETURN) + (NOT (FMEMB (\GETBASECHAR $$FATP $$BASE $$END) + (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}, 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 [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)) (RETURN RESULT]) -(\UPF.NEXTPOS - [LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41") - (bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND - ((EQMEMB NCH CHAR) - (RETURN POS)) - ((EQ NCH (CHARCODE %')) - (add POS 1))) - (add POS 1]) - -(\UPF.TEMPFILEP - [LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:") - - (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.") - - (SELCHARQ (NTHCHARCODE FILENAME START) - ((T S) (* ; "Funny temp stuff") - (AND (EQ START (NCHARS FILENAME)) - 'TEMPORARY)) - NIL]) - (FILENAMEFIELD [LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm") (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME @@ -626,94 +766,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE -(PUTPROPS CANONICAL.DIRECTORY MACRO - [OPENLAMBDA (SRCSTRING) - (AND - SRCSTRING - (LET - ((LEN (NCHARS SRCSTRING))) - (COND - ((EQ LEN 1) - (if (STREQUAL SRCSTRING "/") - then "<" - else SRCSTRING)) - (T - (LET* - ((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING)) - (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T))) - (DSTBASE (ffetch (STRINGP BASE) of DSTSTRING)) - (DSTPOS 0) - (NEXTPOS -1)) - (if (NOT FATP) - then [for SRCPOS from 1 to LEN bind CODE - first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) - (CHARCODE (< / >))) do (add SRCPOS 1)) - (if (> SRCPOS LEN) - then (RETURN "<")) - do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) - ((> /) - (if (> DSTPOS NEXTPOS) - then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >)) - (SETQ NEXTPOS (add DSTPOS 1)))) - (%' (\PUTBASETHIN DSTBASE DSTPOS CODE) - (add DSTPOS 1) - (if (NEQ SRCPOS LEN) - then (\PUTBASETHIN DSTBASE DSTPOS - (NTHCHARCODE SRCSTRING (add SRCPOS 1))) - (add DSTPOS 1))) - (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE) - (add DSTPOS 1))) - finally (RETURN (if (EQ DSTPOS LEN) - then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) - (CHARCODE (> /))) - then (SUBSTRING DSTSTRING 1 -2) - else DSTSTRING) - elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) - (CHARCODE (> /))) - then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) - else (SUBSTRING DSTSTRING 1 DSTPOS] - else (for SRCPOS from 1 to LEN bind CODE - first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) - (CHARCODE (< / >))) do (add SRCPOS 1)) - do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) - ((> /) - (if (> DSTPOS NEXTPOS) - then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >)) - (SETQ NEXTPOS (add DSTPOS 1)))) - (%' (\PUTBASEFAT DSTBASE DSTPOS CODE) - (add DSTPOS 1) - (if (NEQ SRCPOS LEN) - then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE - SRCSTRING - (add SRCPOS 1))) - (add DSTPOS 1))) - (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE) - (add DSTPOS 1))) - finally (RETURN (if (EQ DSTPOS LEN) - then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) - (CHARCODE (> /))) - then (SUBSTRING DSTSTRING 1 -2) - else DSTSTRING) - elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) - (CHARCODE (> /))) - then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) - else (SUBSTRING DSTSTRING 1 DSTPOS]) - -(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END) - (LET* ((OLDDIR (SUBSTRING FILE ST END)) - (NEWDIR (CANONICAL.DIRECTORY OLDDIR))) - (COND - [(NOT ONEFIELDFLG) - (SETQ VAL (CONS (COND - (PACKFLG (AND NEWDIR - (MKATOM NEWDIR))) - (T (OR NEWDIR ""))) - (CONS NAM VAL] - ((EQMEMB NAM ONEFIELDFLG) - (RETURN (COND - (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) - (T (OR NEWDIR ""]) - (PUTPROPS PACKFILENAME.ASSEMBLE MACRO [NIL (PROG ((BLIP "") @@ -925,20 +977,6 @@ 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 - (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 1991 1992 1920 2017 2020 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2837 13962 (DELFILE 2847 . 3008) (FULLNAME 3010 . 3377) (INFILE 3379 . 3527) (INFILEP -3529 . 3664) (IOFILE 3666 . 3806) (OPENFILE 3808 . 4208) (OPENSTREAM 4210 . 8550) (OUTFILE 8552 . 8703 -) (OUTFILEP 8705 . 8841) (RENAMEFILE 8843 . 9149) (SIMPLE.FINDFILE 9151 . 9561) (VMEMSIZE 9563 . 9730) - (\COPYSYS 9732 . 12681) (\FLUSHVM 12683 . 13755) (\LOGOUT0 13757 . 13960)) (14334 35147 ( -UNPACKFILENAME 14344 . 14530) (UNPACKFILENAME.STRING 14532 . 31445) (LASTCHPOS 31447 . 32141) ( -\UPF.NEXTPOS 32143 . 32788) (\UPF.TEMPFILEP 32790 . 33367) (FILENAMEFIELD 33369 . 33854) ( -FILENAMEFIELD.STRING 33856 . 34435) (PACKFILENAME 34437 . 34780) (PACKFILENAME.STRING 34782 . 35145)) -(56669 57582 (FILEDIRCASEARRAY 56679 . 57580)) (57749 64929 (LOGOUT 57759 . 58676) (MAKESYS 58678 . -60307) (SYSOUT 60309 . 61861) (SAVEVM 61863 . 62663) (HERALD 62665 . 62825) (INTERPRET.REM.CM 62827 . -64552) (\USEREVENT 64554 . 64927)) (65111 66838 (USERNAME 65121 . 66077) (SETUSERNAME 66079 . 66836))) -)) + (FILEMAP (NIL (3179 14304 (DELFILE 3189 . 3350) (FULLNAME 3352 . 3719) (INFILE 3721 . 3869) (INFILEP +3871 . 4006) (IOFILE 4008 . 4148) (OPENFILE 4150 . 4550) (OPENSTREAM 4552 . 8892) (OUTFILE 8894 . 9045 +) (OUTFILEP 9047 . 9183) (RENAMEFILE 9185 . 9491) (SIMPLE.FINDFILE 9493 . 9903) (VMEMSIZE 9905 . 10072 +) (\COPYSYS 10074 . 13023) (\FLUSHVM 13025 . 14097) (\LOGOUT0 14099 . 14302)) (14676 36581 ( +UNPACKFILENAME.STRING 14686 . 33960) (\UPF.DIRECTORY 33962 . 36579)) (38109 40781 (UNPACKFILENAME +38119 . 38305) (LASTCHPOS 38307 . 39001) (FILENAMEFIELD 39003 . 39488) (FILENAMEFIELD.STRING 39490 . +40069) (PACKFILENAME 40071 . 40414) (PACKFILENAME.STRING 40416 . 40779)) (55251 56164 ( +FILEDIRCASEARRAY 55261 . 56162)) (56331 63511 (LOGOUT 56341 . 57258) (MAKESYS 57260 . 58889) (SYSOUT +58891 . 60443) (SAVEVM 60445 . 61245) (HERALD 61247 . 61407) (INTERPRET.REM.CM 61409 . 63134) ( +\USEREVENT 63136 . 63509)) (63693 65420 (USERNAME 63703 . 64659) (SETUSERNAME 64661 . 65418))))) STOP diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 685d6ed82b637de70e27247819bfda995b36505e..de42a63f5e65b7c7a6e5d32e45b24fed8b87d663 100644 GIT binary patch delta 4496 zcma)AZERE58MYmofY)YD;s(gtaPX4U4#D_-*s)D&d~ILHPV9Ru`zA}$z#ZU-1RH4S zs;%m#3mvTclm?f!RMV!4F($N1^9T9SkL{|Nw6;hsOpT`GAHVi%Kg=pkT2+<3=UgXo zOtdvWeBS$>_v1P5*F87?dEfkx*Ui72>f-jNkG{B{^{^~r*r10GvVlv5-F+`SKX>-| zP~qsa#iOS~#WTl`7DK1z^2NCqIkz|T-7{wk3#U(Ls(Gh}cOeJMHW={-`Qae%b)aKs z=Z>E__3T1%E^kH0=Z~H~G536bP`l*oR?)&~`koG7gv3 z8BeCfXjT+tF$O|S;MpMKaiEuCx$z&2{I3ISZ#=}+D^4cyL~ef!Pyh%Y9R92kK~Esa1%h4xVg3Io8bIuN z#AS_%DNShGS)H_09@BJhn-&&!Xcue;)$OqZCR1xTf33Vt+hKygsuIp~;aYVH7TZV!&5 zuM}f7Wk^rnwwO-V=4+*Ik|R|1CEwpp%-uG%5uNufw_6a|2FV4*t>d9emx`T(`_*yxmGrPoOllprV1+xt1BKIv)J=lbqEi=j-8kV%?o5*%1gB? zuvgkye5!T@vxVjJ6bj7LN{ARV7Rj@p>Nf zmkQ@#H>2l^(L0t`fD`_>MNb!2L2eZQgkWPE4t!Vk%j-zn}LBm7Ut^2HEnn6H=3 ze+7D^R+-VU19slV1MpkL_Ql6>yJA;%>GR5f;!u#%TQ>hHQCO|r0;5;KSYZ{cUZlhl zSgYO47Z22~6I++{h4cFSt&b9lT`w)cmU9H>E@Z|Go|uUp35i`@yOTTduGjb41j zOZA_SxI+;3Ztzk%NLZD>eKp6Go7C}diSiP-tq!Po=ne8zSOH@{GAN1};2x;M)fSW| z07-ZG!3#xqtOU@BOZ7QaM=J%CzK7O9CBa&5-?Y~L1G4@8+Z`++^=MC zk6KtMjbeM{pi$9whytl-JH%jwq--q)zrl8;8xPjN&n{50<6TNGWX7)l6t_b`T_(oVX=*NUoVgN91_8Mcwx(=yuO>EEjDuuVzOrt|4}75g6Qx&(Bccm;PB zR?p*3Y$L4~r>z&?XuUeAjMZCj%xJx_hSn=vK3GRsDMEDMl|EdczsC9Ast1`GJAv)E8$SUF8^Z3#TFGE2Te61WA2ytyUUNPSvw=>o z^*pOI(O<LZ%@Jiv&P~R#Vv=Tn`DLy9#}Ht3`$Fz7Eg6 zE%7j3yXOZyFd)SB>zI zz?puI2k3gC!{go(-~hOsp#Vn!;K)M&X9&PS3}OV_6a_c60S-u&yi1hXI=Wc{-Rv4V z0?uefC3da+#rI>CT{uSHlqYMyuT$sdm6$GE#xWZdR}6=HdX%tU{vu;?vYvnkrN;#s zrxEM%dyoWIAh_+ob}RL67p(4JOC(O{yHjZRP|(WK@(BI438iI7U3*dj5jjyvXAtj46H-Qqj%NfpAqi>GO)VT7MF4vP z<+@?G5ikiUbTydge0<|0%Xm=??$%Kn zI}VW~LgWGr%8K$tRzd;JkCO2mtcW{dp&ezV8giTf-$mwKQ4wCM5Atw|a&%g@M1Dwm{ zvNn}>Fy^;9Q^@H>eSMJl7?x7gh=+%`AZHK<1g#(z#i07ZsSF)KBPGRIilpH*Ly3d?^6Z)xf+y`;2*`5U+$E+LiC*j3yq z-7SVbhKpsVR1AHf3vi`<=k2k4^0Vq59n{9C+8DiTG~8USj}=x+-xw<_&y@ad7{Tp^ z5!|kR0N3l~!=;PZR@^2TgAvHqbu#~m?F}88Ec5JhCcv`ob!{NhZ2EUshZyvyD zn7=|{m7M-PxVvw>y6TjA#2CC%6z=VkXsDZXo5{)XO{0h7niwqa+dQ0D&byfr;5Ltp z;Q$g+DI7J%hRZ4?yHZfS&|i*_1F=5j7=e#q?enh}wNJS3RiE~r8_?eLwW&?x6Dkir zC!;ALEA|HwRF@pZnQ7!q3(+jj8NyKNSs^N~YmzPky(pHTwj?FGP1+!eV3CAJ|RVAGMB?r0imR}M?@Msdv$fejW@?{JnAzIe z+8y?H&i(H9Xh|en*{ZGG;t#36`@Z*_^E>z4d(XXHsq|1bpY9pT=F&ac{E!qo3TAS| z+?^JIY`&Z>=CY+iK7p(Ori>+oJ-zP8@yU_<`vYyUbL!*n7JX?nX0Fr%~6atolEtW%EfGcx0ppQhQ@L^;jXB+w>KavQ}gKMS`G9Ex_|v( zg8}hdjZL)2`oh7G7)WN!{O)wArz}O+9~op?qo0VRegvLNUE3E5}Mb zDe!~YF+6odvBL-s81aD!==58WKh)ixO6Q2GVjvZ7@5+g;Aor%bTlhMBK3_|s^6YG5 zrm?&+aV3I2zpu-PhzS%*m%)Wxx_eVTo7>dYy@@zLtg$OHL@}L|yG2m!rP>N8-J1A^ zRLQf64fONVjVo;lzq#^>`zf@)wbsoajirETeSF&b_<>nbG0$@+>It)*il8%nePUvF zx~%0w#QMcVHkV89HgmmZad-Eou2@LOTq<2Ei)dKn(|3zVgd%RE&v2AJMJUEUMo2)S z(&ng$S|2Fhy$N_)n?Bc|3oQxm82|eO^+{7H6cpKfVXQ0+v{6WN9jML-a#K;2=&HY9 z)6HSPCZ_>CUX*u_7ZvajR7G-~j&?frI2|QUuHCgkSb zs%=RmSGFZ8vyDrYr9LIH<7Se@B80qG$_)0&19Kyt42c5C2 zQ6<+@wB|pT#x{sJJOWlO8hLj@Kw2%)IcJH^exIpi>0I4pDc#?iSl(7yz9zv+-Va%Y zuD{aJuQBKwSCe659pQ?s8IK-^NKshw;YbG$rIZ~l*nx9(UWDE}T{{*9i2Rgp;&oixiYd`aKMF}9( zU_nIs(7EIY1xSFkK@sY+b3m>})1!mvZ^VG4rN&A2(7klBEFn)cKkPwL*~mR za}O*ufdmGctzKI?F9Sh35^ZX@{GW9Qe{mN!@m#y#$1&U+rpG=@r!C&86qzEJQ&!Du z!$>Mz{vP29PpcaE zKezgN_Io@E&YJOOFK=1gawz-$h0LMsdt9Qv@ZpA8POWpz^~}sROl_eU41;32lrE2? z#|NcZq*)#;NaoV8zs5_0V?!_(5kZ!5x>%G&5rS|}q|EVhb~GInAtNq`7c7~fpn*U> zX+kFBaWR(9?(Kn^Oy~DNpP-?k+*m2IXB27`=7$pq+l8WWF)=n&>Sc>44`G4S1HlGN z64JLR*m=qHP*ILDdr4ioKxe=(acX59yIN+AAdtF76aCS(TENK1dXi-JM`B*B9j`1W_vy-{@Na1|gY*5CkY`#Gx;NFW?v84ty>k`r;xmfB4vm&tkPQ zAJ~L4B5=1Xj`Ugux;NSUaLndWGdm)!9K_vjQ2=Bocrq@I71X+`0A=Qlf{k`Q z#!B@vJ8(^&9@wW;iv|}_ z&Rv2;!3ae}AbIr2k?8~TvsjMK&tjb^h-)x5C~4}5IC6AeeCGJ<{IpOE6$i0+MLIxj zr=OUfp7SOH=XUDRW79`GshdO}B!#%#qsHC?T_eYeFn)W|dy{EMS1KT2WZ6|5oIO(U zQ~?>v$=wjYpsnkn)&VbCEcwBQmc&XstF)C3i7#wwp~a4^25hT&Ebj)ZT@%(kCANDE zA@gdrJd~rQ7z-vEAhWzJVa^QBy3KNLZPs+SPFs4i)BuQzWRBXf)Cay`>#0uggidMe z^k(a?_WOJr=9G2Y@hg8vF}E-N8&^Gkryg{3%a0kI{%Y&H zuP0|47e`yT4EGl6gW1W=3jB!-cVge7Obl~kb)c~bFg`In_ueDJlULU#x7N*-V(Qt1 z+$yi;ytOUP_o^<>z56=VJ*WtFX`$_3@mC_lm9HdLjpZ-(SpFh)-l^B`e6Cot8c)n7-1H{hEz5B&_rla$o#NiJu9^BS=p;Fz|SiGSwmotsUEpqb-2Adms%_CV#3|E|W<^3Az- zCf}^r-jQ!sWbX%yQZabJ_gB?hU}niKd9!@$AJyf}$aZs`Gc}g*LGh@c3UeD@UX_!Q z2{rQJ7?UEjNd{=bpO56{L4(~TxhwTX*7kty{$^_ zuxYe|X|#iBw1a8%HpcQc(dcdYqYut5_`c*6`!Nsc$2_F#tRd~AA^oDd>!0{6y3wH0 zM9F)E0N?%o>>~apA+yuOg7p;}$$_u`YoEI%9w{2G$|a zWUy{7-IRJp1}hg?8XuKG3$=2Qw9FO@l5){(ybR^?K0dZD{)f~Bl(@9;$%mElK_TGq zlT~iiZ^4;q^(n1L=H6wNyg6IDo*=5QxOG+P7wa>Z7B&nILpSsQ#LzR7#rk9cNGr&q zLR#L1v|&bCeqE&H-5AnH%hcsCke0ELHssDlNJ{}}gM_q1U1k_*!$8_SGB1~v6h&+) zim((#Sc)PnMay8`GD*>LMGmhI%x!#GHs_=yxkyN} z`|%o!kcJe}hJdsosaC*~ah);F z8RINSLv!dpkVd}_(wb;AVAE)TX*9qz8fc;s2E<5Pb4WlM4{09_$wHbvC<|$nB3~n< zc_<2`af+LyXH=9YGZB@L)=Z!~^tkWfao@2nfp+PPyEx;nbqF+>!%TStke0KNmTR6L z7q0v!&ohmsEoR%Lg)6_rA#*!E9|GcX5d5n)T8PUL;y&@;xp5$_qOftqg^fdujU($~ zI~QT20&MIjY}{9uGmMQxjEy528)cjCW#)UC`Ce|~dqo~v zjg5-j&)C=xuIy)Q9Aa!xJnDC0qdBL84Z9yr*w`=cBW$1`V}qN(7=Vra@(^L;pvJ}? z&Cxx~(LK!ig9;l5fsKQ5ztRGGb;iA%aWAv};GEn~*q~nr8%;FYXVYjO(`X;lXkQbJ zG&a^860pHT+DAjOuwf6%!Um-%YIW9 zuZ>vDD+6-#*@d>-Ec;XKttDpgY4*qIlGgSZ&ZX=cFWM(AoWHGU!gq&l8kTkfFp)U<`oLNqL5#bV@_%xE6rp zEC9z@Qcfu-odT3j$&(67^E%@^XPjqAIW;Fw5|rrIfl?EV9<*unAk*kUrqP2Ipf3Y5NPsI7`|0O<)Yb%6WN-uyRpjVu<{L^@f)1+8!QSJ=j3_9 z3jI1*X`<0tn?`4uMrWBuXPaoGv9jinfE6CnJ{ppR6?;$?RwzYb#Y0hGg;U%lJ)@!+ zD>}2rN;83;)Z>1V$Nl8G1UjcPp5u(?)*;a3^T0|RSb5&Y%JW{V3|ku(iOfDG{k==k zruEQYF@)X)gq|l19I_zvJVB^c&69rYuskt?ZIyf#tKI8I&MveTrT;nExpL+3WM_S$ zH8tt4*Z%7;{x7t~^OfrLjh8Fc+p(2_oC2Zq$;BN>HTQizkA#c43kmd$dxSPGm;Or& zEeB-h;%su|cQKF2&bfDKwL*)9#jUfQi<$gN-)zk~x~}zOl2d~8+T=_1YEZuP{tNP@ zYXAFB%h#$q8<%Ekf2mBZ+Ml7ZXY8h4lAY+{47!|=eyq#BU!Qyh^LBxDe_oN_XQ89r zAN}1tgUe2AZ!MtcyXfG1lePNf4^Vt2wU|!GAIO?2ua1ivG{^r_J;(oq_I`A&*!$6+ zL}TB7V_qXxSJB+;>|3(4cDrLbysxYM8>&{9a#ujren(YHy?uT5hcg)X$alHmJ+&RV zl`HwPwiWbwT5n!m!Eu%yVJ?M;EP8i{$fCc!5(dsRNz{L4iQ>-bBIum{v`YKmBGLQ` z_8PDi_s*N((L0ueF8t36IEoBMVuwz~%X!Hv+my=10A>n=;XXz}o z%ioh98y!p+MYtdS66Cva*BE)|^n*Hi60H)x!*1?}hF&@-+hcU zt5k?M;qH7W-b6yc+&kV-Uy~e$`fv#BsUsG5vo{orcttxD!{|K)qD@4`S-6*Pp-6KC zq`@W_(=-&0MLaYOg(E>bi<_o6T8E<0G!2D79gC)+5HRgXTqqQ^5gjt%8>9(pcvKR+ zj=Vw>qT_GR0E0~;0rw{_6peoP(z%NmaY&-m6(bHu5pTNTZPe(4yObwK9}bE=5wYfo zD2A)0j)@3qi+hL&AFPO-#Z5#b3TG6Xhz69eCZZ7moLxO91UZ6fMBq-~3POE&I~j%x zgGFZ}j01gJ;llsR7Gom}nRB&44i=uFl6!zBf&k`;2sR#X!>(ds%y6EZdX~?_$3m%~kbpM{c~!6zIP`?8DkuTF2Y{W^ z1HzfpB00F|jv4?sPtUpq1LfRZAWs#Khah#HeP{~;#(+9c*8X4m#2C&1N*NXeD8>^M zy!E2gC$eqGRU{e$uN=>jsL>B;Bj;kMDRKhTE+tWRMQ{b7v|On{(xhB0h?$$eA~bob zuQ)nemW2|=5Q#$>WQS;?WZ#>dSvTDui4gg~IH^&XhQ)MqucL5M@N_MTd0~xg%Bpc{ zi(txDE=eL1hM=%_68v?b8now|h=2mcba||p7hyR4Sb0L=lRoqZo0WeLJc`r@Xv`l( zAZ7vCXv7{!rWO+N+l-Q=2Lfc{_Vcd+O+aA-6rx|!B=`j{gZ$e^eme-qFniE%6e^A! zzaxF!2*BUS4uqj?yU-leTnx_d7#})ir&4=%fMh#x2Wkrf$W9rE2=xXDFt^}JbQ^tO z_CdShII5-JK1|2Do^W3z*6xI&u)E!rks7zNMlfmFfiMJ%o56JMDPqK8DgiTsYCj09 zb?G5NQ8P8dL6~Cb4Q5*^uc#5~hs|mS`XEHE&V*vosFN6j$lEzdeNksZ5hxv}NISfC z;J3pm++R>56oS_mwM!VLUrbLJ(Hr2l)M|MrSE^+?o-Q?( zJ51%s0|$Cu-237G=}gk@2@5V`n0u);Su`#GU0NSg{YpnW?Q@vbljAm}e5$P-nwOjJ z0$j_jcJjJ!1j;zNtAJwTe}{|^qZy{o%@ zP4_n#_UwHL^Ddc`WBD?!&8$x+E)D7M%tJ8U}+12qPC@VQq<*+mdPFUFU`=W;O)$%8>LtjQdBo` zZA+h$J1jwbMQ1@N#aHY^UM5AQZCRaD&u}dBZ^8F(E0cj1tK{OAIyORm|5yfETUOe# z_bm9{c2aUkS+r6n7JM)2l;5f6k@B?kKbgIE!S{752R=_*Ii9P_%}bxL;wLxP=5)zV z*QI~y-u#oQ{B-)u%T?u6^}Z zIJ08o@WUMoEq`m%XK@dWvgO}Nv2q2**zz9Jll%c+Ay+_XnXblS4~ST8mBKm)s8qi| z`@ercu58`#7Cij-r*Q0{c1M4NthF~(C;r541>35>M8e8dpiawYK$@06bkTiMEcl+P zOx~y|{~Qzki}FTA_}T;3SpT@5TRLRLPShqf<*upcmrBzAME2g=h?RP8O)DbM+rJdG zqCr~gqTS-B@=MpLGS}!bf5aQAQm_cw)H;OmTvyRud#av$Is4WbHNGeE-^u=nsQSwV z-z63G939{Kp2ASuvXh(PD`}J9kEtV{QwjdsAFAxJ=J`u`)j zIg7o2xI9Wfe_$JVxq~S&!vEntx-GYSb#)*&#~fan&guAkW$`F~E71KOf9I`iTkj*G zYsvFZYs<{GnwjUWG#39lue?qtZ{`w>@5Alxj>e1l4{y9J`I*|aIVz9_UtL+;#rfi@($*G4g~iehT%v*^fW-9#iQ5|& zP;IrtVfatv=?Vt!u7zRO+5v2}xdZMLEK8hh zu)LfA?tnP~&%QYP$;re)O9rL{EHCVD$D%N>apB%j;VoRX&x(|$ZIK|%Q){~bdsK$2 zTtDsE={>Q2*sG4+NBiWSWpxY|qPnGmwb9y>D{M^nYCqDni5P*wV2ve=;g>RUESJK> zXskC`<5Gm8zBVDW^ggOU=O$>UYSb)^^o|YT`Uj5;_F@4G2D+-3qpMOVh$8`~ zy77G3+>3b_RJo~_-1V`SuqstuezB|=+^$e%f}qFhyg|A!u&Rb2mLaQR<5&mUW}u*T zo3^In=&`ef5T`AEn*95)ac9lvv>m&86-{eU&tkg|(yL3L7GC+r$gZ>3(6p7bx}qp{ zr92fy`|PG^0nZiTFi0=Iqn_=C2-ehkEsdqCwc-wAVWkHc#;%()z%c9}9$*OKv$``O zbxh>+neLZ5A-Ys*jnTknlUm)w#*>U$>;4W};0ruh?76KqzP>@5BYIthHJ4uKb_?1; z*9rZgJ*}qt(L`VXzmQD2uG0^Rq3b#^EaL*%YIXYlsVXjaOjj%PCVB59cc3zP29v#$Hs1Ysg_rmoQcoy2VIG0nTj$TF6es9>alRR>-eK7D)ptB% zRmQsqqrJ&df%WtRy&eD`HY`1{;F!RcEIk<1YYyQdq2Baf+!cqB&(GQ9@S+(#(}0sF zyf;M;B&cFIqiTBD0R*$}Qez1*0qT@x*~Hy*EZnev?kSGD>vpSy=^-UfPvk357TIq z$0ayTEXDb({cZ|Lk6T*6m<*0a@X`?EM%e`P8UYsA$_IfSBH-uMu&zz!22>=T#wcVV zK=i7MyJfJ8{K1&`FEZ-f(Hkc=9 z>4=oHvg1hG;<^<Ss3!86ewC<*oM zPZOe<2aC7xkHe+4zGm0d2w)kUyIdT@iNA+V^wf^SPn?af#W@_)dkWF}J55jafCBdO zA0N#M_+)5WDk_j$odTIf7VKmxZm4wZA-RLt6mth1YFoKA@j1xUw$zHVbp-s=8TBVY z^p?a^3D(Dq5x)=Yp#4v;qQG-FteKSF;5wV7-VD;7F*kuzNm0rU4D7@!M9B=^8zJAD z9(prqCr&0|GEf@7m(_zw4H^u&b_%?5gacPRH8g}nNXnAWLE!J|*<R+Cxw0C67?Bo4E0&{XeejyrpTz+$rD04#qSewM(l?+^_)j+jVr#Y z#1NGBN41S{|HZ~uUkgu?42=$>ErWX@zGWUdE4;mG3xvN9y^pl7W?XY%WAU>c{>zxV zcl)=^a!q%4ZtG~fLR}N+0ZMn{t@x{@MQjCeET$aD)e)#6d@CQr1S@rByrMig@ zPTJ|)p=A(l+&6S>sjf_q*2bIp%Hc)BM9c z`=d$=4(=0knNM!sg5%B)$jF7GoOL?^y@cs$7U6A>A~TkrbtO~58xd@p)M0d3N?oZL zNA2*-R6v8YKS`S%Bb--3(nvXzD0EgK4M3c(uRr0#ox7 zR2Ua6amwR(&zG#)vh%oadsnew-gTE9fk(^e(O=QEQ`{~B58%P%p6c|2(^WBh+fi{G zk5Z(TzfeAugL1fiyukH5BpRNZ~@v0OnN9(r$Ate%WT=T1o z_Vb0d32jfgdQpWQwS#c5O7Ie)=o+P0z3AmeFdeVumU{7k9=~VTOU~4HX%* zoN`aF^w0W>GeZADwa#+q?tm9OgF9@ zG`wB32M!)RF6L*Z#s29d(+6kg#nFQt#PictF@MxP3MEl!ZHB>!1Re9i8Z=f9m@Qe?0e9j&el$Ab( zE8vY$qK9HV=>@NIR8vqNNx9qrJ&t)z*QJQ3inn+Xo2Pm^q-$~?cnOcgl$8UW^AcPU zdDKi6;ro{~@uFWgi3gRP6E$Z9hAY-vw^=IT;Ko;>t85)gyS4C&< zYHvxGzQe_K|iWd$}*nWEj9gV3&-N^zgMJo5o{m}V@MGOPBYMJ-LXe9jy-Q6K#h$SCMJOkPXY@w6{J?`tXH-$ZM*LqPKXTWYS|s{?+$ zj-!QH8J+q~Rfq0=GhpxxKTgC0yYP2=K#y`2e%3-sJ4s_%g2GL5qMEwXvnpYSWTxPq z&XkDmV?_<)t)O1A$G%EoyqMjcDWg|=rjI-@Ep8Tjr;i_fNFWu&UmyL8;~$LBcKoN@Sl=6TDFbdIefY;;Ap;`@CENcORiZk+ diff --git a/sources/TESTUPF b/sources/TESTUPF new file mode 100644 index 00000000..691c3380 --- /dev/null +++ b/sources/TESTUPF @@ -0,0 +1,546 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "23-May-2022 12:30:29"  +{DSK}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} /)) + 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" "<" "<<" "<<>" "<<x" + "<>>zz" "<>>zzz/" "<>zz" "<zz" "" "aa" "" + "" "" "qrs" "" ";1" "xyz" "xyz>foo" ">zz" ">>zzz/" ">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx" + "A.B.C" "XXX" "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:xz" "abc<<qq" "abc;1" "abc>qr.x" "abc>xy" "abc>xyz" "abc>xyz;2" + "dev:aaa>xyz>qrs" "foo:" "foo:aaa" "foo:xz" "foo" "s;n;b" + "x.y.z;w" "x.y;z" "x;y" "xqrs" "xz" "xxx" + "xxxzzz" "xxx>yyy" "xxx>yyy>" "{ABC}" "{ABC}XXX:" "{DSK}" "{DSK}*.;*" "{DSK}...yyy" "{DSK}xxx>xxx" "{DSK}xxx>yyy" + "{HOST}foo:xz" "{HOST}xz" "{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}abcqq" "{x}abcabc" "qrs" + "")) + +(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 diff --git a/sources/TESTUPF.LCOM b/sources/TESTUPF.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..bbc3143632d475f680901d9be6edb54300986a2c GIT binary patch literal 13624 zcmdU0Yj7LabtXvLu^3k&C?<6{ioHf+nN%bQyNf4DqW}re00rXGAf!l)D+ClMks?IO zB5hN0tg&T9)_Bq+l^wsLQ4&u4NbPzEP|PT@61c9DHl4OfXY@n?M#ByZKi)3 z_dDnAE_Ok2>UR30)r_$Baqd0meCM2d?%uuZNhF8U+2qdQbSAkoogEg+9b@sK-SPX9 ziYJ}TCv%zf_?SnzBbSUP^6|k;Q}bYaJgKO@-uCt$nqdfJ`D8-zX!_34;)$J_Ptz1t z>(hOG{)k8E@f@5#dTgdVRZ`~X6pzyWXkvW#V*?K@OdVf{&K8fAi*wQP{J~;5dUUE( zo;sm>1JOt3kI&A`9o{Khq6_m69X~j=5X~pY^LxgIz5QzMI&QvjpD*N57KvH;o|4i& z17^c}G8x4#me=d`D5c^eglQHR6R5hU_rKIhgHHb|Iw-mp_UpavB9qv;Crbt(G_ zq<1`@OK0y>`V!&xo-rj7QHD|qo?#_T4^_z~KbJ`7sO(dQL?Ve&IHHW_hQ`D=l|xo* z(AMh5xP5tpL{}2yW?7>$TNPtfsu%*G>Qjc}`7ulyiYSnd3Sk8zOa7sdlFTNk5sdQj zT%L*nCBJ`+WKvaS&v-I1o*X5)Ri84R91__?LJ(O*8BXWM^Rg0F#`g?jN@Fr5B_JG# zf~Fz?Wp6x#2EQ_x+>be+2x_`fBhXOQlzeg&Pt}mrr;xH~C7=vthBNn}9Dk6*MNM;hU4*g-3UghJrms(nGnT>5~!9VxEbhztxy6awd{a*LaMq;Jq zO4r|)^jLj0Cka;3rgy9+|CFd-jKv2Nw^6A>_EztX{p8lQPsP`6J4~&y>F(|hF4Zr! zovw5}AM2QGc}kMjVzcc;Qz}1Nf3{YBY^AGI{(SwJTKV_Sm3!*Tm6nU;-dMTyqeQdT zc4YRw3A8;OUkfH)MDqx@f7L3jePo^pnb&A{_YX!&M?a`nf3G&mS{X9D5pS#hf=S|A ztAA^or=u|s#N1NnxjM?N*Dnvv)Gv;@cnnKBc}s1ku(`$ru@nn2Q5CTf?kxA!t3#>e zGb6L_Jw8(Ct`%;t#n*C)Z^XpyqMK<~wlvD?M4r8VndTmpfGtZPZzD-NhJ9K(?wJDP4y!@-Rjo#>m4MRiR6jFsh1`_s>^ao@@-e z#4254mF_fDnjn>aR*wEvi-8*{l_WfOagVrU_0&Wau-8}NYBYxCC0;Dj*&7g3XXS%0 zt^?>Zrrw`ny+5-dK-)~hZA`dr1AsdDpWF5M`07207sdBV7uny=iSHSqES{sKXUmo? zMx=`8;`Q%h&G{7yTdV(=xPURsm5==)59`1%gy+YeWab@4lrv@@H`kZh>uj1UGb?vd z3Kt&l(fCd4q$P#C1>TV=+DD2Lu)i5WAh=zHGq z@z$@1!4k*Q%S?S*#$92cCZdSD0Wmx2Kg5oN|AqcWyjfptos2%guVCL~9(M(BQ z;xa{?CC62E&#Pv{1%;m?4g)#jm<4n|#03Rb#LtR8GvcAeD@Wvy?I- zj(WsZiZ}2rK!q3*=%*2DF)P+$ z&1ti;=`~J2_0=u$w&lvEm$(++isDxhakPWE?M@@&Via+=xtTd4uEb{eznGj-mK&tl z4N~j|DRzVZ7s+YFH1G%;c!WLSM#(8-5@wh%!=A8laoPCZU`xM2Tcw4T?d5I&kPoCW+&+d|EcX=CDdYiJ(+a+;iefBAdN%0P{&m_nu zYfQx1huSee4K}h*GbMG2A5!+QV_&Iq*$d1Qpw0ZmQqIcp&s!Lg_HwPWFPLaLwZ&=Ifw~V3aMs*9x(NOfc1W0 zLx2vLga?@Lzy<&n%C-3FT?nSKm3_+QPVX{DQl)K&xGeX0|AxZW>aP$&WjOoIe{6(M znKI7J-(-dzA1YR!w#CX>j+Li3jFqSDQDDZ(nVL9@SUF?G%4s_l#meJ|l~WWeU#y8U z94luzR-QIv<(TCM$Jh^!u^$|3@`I8%yFOMP7pFK@PQgm2I9ASbtWZ1Vx5Y{`Wg}KB zIhtbSl=vdW3I=klFbn8_SUDxmQmmXdW97JM;p1%KbhM#Ztih zHNnsySPhu3Nk$0$oI~h3Lg*aDz!4*a&QS=p%HZz6dCW7@IE2ZTz4hu{yU$lzbE5N` zqHAr_NTI7%X-yP5Yb(DQ!EdECoGq2_s(-gs?#ICgC>7LR8mitgBy-;HPcy5W!FM8D{(o+N+c%Um5%h| z!k24hpZM~xUlw03M}GZ+_;GoAeR+E2r{Z1M;N6u!0kan^R=V$m-KCN5 zIRwI)MPqcwRdUUza1?=qyK7fqqicqTR{rBcOHV+L;CMNo8cM};d?FptgBl&`8YjsC zJ)lxGo)@D^K-X~moJ;Oa=I|vUp!;w#+@RFLd>Sk%wLnC9fX@7JvO7j6v13X=^9Ahm zDmYs+tA58^s>*YjLa4q_gVYz&Z555hGYNe@9H$%7`XeB0lEEL*f(~{4;b3qbQ3%41 z?q)^&AuZBS88x4Cco1jyCTTFp%ne!mLA{AKfU|x()c%0KNf@*^DRg{8a17CLu;0Mk zulw;)!Dc-_*~HPH`Sqp-VCkSBa2*Z4kgD8$cRZJi@88K^7yQ0JNQq}MV#w6Zr|T98 zoyG6W?in3S<`lorM;{b&$@}-<*k6wToh-T5ILi3G(2!h@XnqqoJ&Y~`L_G{vHnK1r z!7iL0!lw&ogYLvk5BfDHMS!HRfusk5cJI;yFtMZG4^MVB=uVh*JrZzIXzLo_Lk)u57zkLQO{^ua{;!NE)%eegc3Oh&N+ zRf`0jcxcT*fk<{bjTWMhS2hT>knVI{Eu`A*rUgSz2(_Tz#54d;c1#)YI}NG%*EK*7 z6EJp6O^2oIj;Yb=Ws=x2)pU5Q<(QhT!bhZIYFfl0xfZe<69&>v5H%GRwt=VyngCE$ zr%PzQkkb#& z>9%2%{~eUjhcm4Cfm%aOzb~1m&%k^?L33;-v;c1{SON{1)RKS<)j(a9IgZIF%p4rl zrVOkik{?KCGRgbm8E-sypF+X|srV?qLTifrKtC4Gr|ci-b*90mdiqi=p~MA(fQG#Q z?QPN`i`@#6Grm?Qvqlvz%%7_RDwZ}|hl(JzSD~Y=>Z65|zH-Aha7I}oKc$jCf;A&A z#>SzOKkUaffniFNfv}QGX5#tu-XwimAIgi|ero2g-BuOZggtHpD#yXR%2YG;9~d zvPClaaSezZ1NVLC;R}KjMzACHD%j4kSnR#M?T!W4xXgsb3zwPb%8k66gLE%1JEaxe zWx^J}S84IOT3XuN9WC)eJ~h}^`bMn&YOL+KR4KOg{9s24FQH!_oV_-A)8qVGTe;rS zyiTPx zU9VDU+cKPq6CTnSwc+&-lF z@an@YxS<-t^+4vOB5QLW7GNp4ish9e7b(ur3LA7ujF)IxfDp0}Fj|a72Wn#_ott{3 z50_neL7Xp_xC}NP<sAgVR$B9wo>PvbICPh15jej5WMC zB21hiBUeuZP0Jldi_Yop!Y59P z&TTl9MF9St_(bP{wim_bHD9*S0slZ-O>}g2?rVE4z1EqU*iS7NM>^#xHUI8UeRAcW zxm4Jk{p8ADxAdq$jE*0Gi&-E?$?eD5V4@1#aoZTzGL5}jFYU^Ec=OfR$~pFa>$Zoz zSiZ)v)64H45~F0hJgmz%icud&XKpNh|NZthrKg9wl%DNMzv2C9k3kKD4OJoA8z9rxxb!SyYOL zk55f0Jnzinf-?We9FWEB?Wx5nr3jphCl+QFyq zt#lkEkq0EEQSD=UJl-Xb;)!|>&n)7(h!sB@vqt5taqpma2)+CE?Hf38;si>-LH_P4$tS_lPR;!X`?-m5D;CM7_{G)? zMwex*-BSzX8AZkxzq=+Uc{W)h%TObv=wIqTDr*Bw0tUq*6%883N)klTN(z900P;@t zAMKxO)D1+X*7(I=DvOJV4@*eI#M6<5%p>|B~?7#>~ zKXrU&;W08Z4W6D~SfmQOJ^7Z^VwwEWB_gm~$kV99iQ46I!M&iu1Wg9Bs". 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.) From d3d2534eb156e6bac7fa643bf54f3c9c00df9e18 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Thu, 2 Jun 2022 17:18:29 -0700 Subject: [PATCH 2/2] Fixes to HCFILES from MEDLEY-UTILS to convert TEdit files to postscript --- internal/MEDLEY-UTILS | 85 ++++++++++++++++++++----------------- internal/MEDLEY-UTILS.LCOM | Bin 7412 -> 7339 bytes 2 files changed, 45 insertions(+), 40 deletions(-) diff --git a/internal/MEDLEY-UTILS b/internal/MEDLEY-UTILS index c1b212f1..851c3a98 100644 --- a/internal/MEDLEY-UTILS +++ b/internal/MEDLEY-UTILS @@ -1,12 +1,10 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "12-Mar-2022 12:46:25"  -|{DSK}kaplan>Local>medley3.5>my-medley>internal>MEDLEY-UTILS.;2| 12734 +(FILECREATED "31-May-2022 09:37:37" |{DSK}larry>medley>internal>MEDLEY-UTILS.;3| 12695 - :CHANGES-TO (FNS MAKE-WHEREIS-HASH) + :CHANGES-TO (FNS HCFILES) - :PREVIOUS-DATE "20-Feb-2022 12:59:27" -|{DSK}kaplan>Local>medley3.5>my-medley>internal>MEDLEY-UTILS.;1|) + :PREVIOUS-DATE "12-Mar-2022 12:46:25" |{DSK}larry>medley>internal>MEDLEY-UTILS.;1|) (PRETTYCOMPRINT MEDLEY-UTILSCOMS) @@ -161,58 +159,65 @@ (DEFINEQ (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") (DECLARE (SPECVARS TFILE)) + (|if| (NULL TFILE) + |then| (SETQ TFILE MEDLEYDIR)) (COND - ((NULL TFILE) - (HCFILES MEDLEYDIR)) ((DIRECTORYNAMEP TFILE) + + (* |;;| "canonicalize") + (SETQ TFILE (DIRECTORYNAME TFILE)) - (OR TOPDIRLEN (SETQ TOPDIRLEN (IPLUS 1 (CL:LENGTH (MKSTRING (FILENAMEFIELD TFILE 'DIRECTORY)) - )))) - (OR DEST (SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T))) + (OR TOPDIRLEN (SETQ TOPDIRLEN (CL:LENGTH (FILENAMEFIELD.STRING TFILE 'DIRECTORY)))) + (CL:UNLESS DEST + (|ShellCommand| (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR") + "/tmp/psfiles/")) + (SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T))) (* |;;| "first deal with files in this directory") - (|for| X |in| (|if| (EQ REDOFLG 'REV) - |then| (REVERSE (DIRECTORY (CONCAT TFILE "*.TED*;"))) - |else| (DIRECTORY (CONCAT TFILE "*.TED*;"))) - |do| (HCFILES X PREFIX DEST REDOFLG TOPDIRLEN)) + (|for| X |in| (DIRECTORY (CONCAT TFILE "*.TED*;")) |do| (HCFILES X DEST REDOFLG TOPDIRLEN)) (* |;;| " then deal with subdirs ") - (|for| X |in| (|if| (EQ REDOFLG 'REV) - |then| (REVERSE (DIRECTORY (CONCAT TFILE "*"))) - |else| (DIRECTORY (CONCAT TFILE "*"))) + (|for| X |in| (DIRECTORY (CONCAT TFILE "*")) |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)) - (PROG ((PSFILE (PACKFILENAME.STRING 'EXTENSION (|if| (EQ REDOFLG 'IP) - |then| 'IP - |else| "PS") - 'NAME - (CONCAT (OR PREFIX "") - (|if| PREFIX - |then| "-" - |else| "") - (PACK (SUBST '- '> (UNPACK (SUBSTRING (FILENAMEFIELD - TFILE - 'DIRECTORY) - (IPLUS 1 TOPDIRLEN) - -1)))) - "-" - (FILENAMEFIELD TFILE 'NAME)) - 'DIRECTORY DEST)) + (LET* ((TF (UNPACKFILENAME.STRING TFILE)) + (NAME (LISTGET TF 'NAME)) + (DIR (LISTGET TF 'DIRECTORY)) + (PSFILE (PACKFILENAME.STRING + 'EXTENSION + (|if| (EQ REDOFLG 'IP) + |then| "IP" + |else| "PS") + 'NAME + (|if| (EQ DEST T) + |then| (* \; "with the tedit file") + NAME + |else| (CONCAT (PACK (SUBST '- '> (UNPACK (SUBSTRING DIR (IPLUS 2 TOPDIRLEN + ) + -1)))) + "-" NAME)) + 'HOST + (LISTGET TF 'HOST) + 'DIRECTORY + (|if| (EQ DEST T) + |then| DIR + |else| DEST))) (TEXTSTREAM)) (|if| (AND (NOT REDOFLG) (INFILEP PSFILE)) |then| (* \; " do nothing") (PRINTOUT T PSFILE " already there" T) |elseif| (EQ REDOFLG 'TEST) - |then| (PRINTOUT T "TESTING " TFILE) + |then| (PRINTOUT T TFILE "-> " PSFILE T) (CLOSEF (OPENTEXTSTREAM TFILE)) - |else| (PRINTOUT T "Converting " TFILE "...") + |else| (PRINTOUT T "Converting " TFILE " to " PSFILE "...") (TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM TFILE)) PSFILE T NIL NIL NIL (|if| (EQ REDOFLG 'IP) |then| 'INTERPRESS @@ -224,7 +229,7 @@ (RPAQ? HCFILES ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (753 7201 (GATHER-INFO 763 . 6303) (MEDLEY-FIX-LINKS 6305 . 6828) (MEDLEY-FIX-DATES 6830 - . 7199)) (7300 9150 (MAKE-EXPORTS-ALL 7310 . 8326) (MAKE-WHEREIS-HASH 8328 . 9148)) (9185 12689 ( -HCFILES 9195 . 12687))))) + (FILEMAP (NIL (699 7147 (GATHER-INFO 709 . 6249) (MEDLEY-FIX-LINKS 6251 . 6774) (MEDLEY-FIX-DATES 6776 + . 7145)) (7246 9096 (MAKE-EXPORTS-ALL 7256 . 8272) (MAKE-WHEREIS-HASH 8274 . 9094)) (9131 12650 ( +HCFILES 9141 . 12648))))) STOP diff --git a/internal/MEDLEY-UTILS.LCOM b/internal/MEDLEY-UTILS.LCOM index 65e267a952b3b37b163576d6f51da9a4db4f2bc2..de41090c458538bdcdba8f13dcc5ac0bd18c78e3 100644 GIT binary patch delta 1946 zcmZuyOK%%h6t)et#6XotOF{{7bdgF@$;r&U^EAlB9*>hroSDHhsTzRTb z6k+5Idq^!7tSYf(6B=dhUr<;fvF8WS1wVi@cRY>>wXA#3eCPF@b6@}Hzvw@FqA@YE zTRqKCfl?6kEK~7MV1*oZTE~rMEr3oN2=u=xdOP2KRPVHExn{N7JA ziGc1b%QW;j=+@#Gedr(7tL>xONwyDLM#(Ch9`qaSK9JI0xeQdl;;^>1hR#8?R}1=( zCetcW&k8In31l_B62=gXikbJ#;x!7BB3?+EvOb7Z(PcsHJMmb2$&ikRTcSz1WHFxW*Q)tg_}!8afJo{wyH!37OmFQkW}3Pr1evjTR0Hw0wx zOT%Zkmj(=c$3g&^7`BK5(IQT{^ggx`GNmRx!*#IpQ*#DRJvcs;}pQlkwHTt)dl zNX{h_Tls>)Ef!KQUH(1%>(0Hwa%2AK!Zr``({`*LS*iW=Ka!tCIFItUe*Wi9>eKVz zW2%?8d5Q+tHh6$pKF%dy+2u8SFqgbBk#2IRz{lr5a@X&0d?%6MP`>f}v3<_C%m?RI zGi40V-drBoyiN{|qeUJ8x{RD#Z@e0oJU2H}xV+~?44y7Kvk|ZVQyepRDsDs;QRl{T z>^6$(;icY;mSJ}I-Xgp|F_;P*HRSVo)YXHaFf1=FMcp3Jl{;9&FR_oyva5)&&uZ=FlL-K$PT|wn+6WM^UeH0=xnq_jKgxj1zwb`vzgH!0$ zYuy^beH5y37EtMW1fL%{4a9O$3KO(DaPrk*9UkHH2WxBac+(bG1%7qgW>c7ANsRu5c;G6Li!=ZcF`JTV;G2hJmnEW&O z?Ry?kWBF1mrYfomL``W%O4VgpmbaVx2lc&b1)2?zA=>%E2{yibXR}>xwbQ$$gS}EC zoojBF_R{;+%3k$|#`X06QS9N@*Sl(G1!O`duqwjRl!CC)PPtVbA$Oot{rsTSPIVw} zZLrw;Syp6j5X)LY7CQAt2jt9VE(g<4@pxQ@PNj5Mt)O~ZGYCS6{OU?{IpgM-U1V0s zoZ}xN0MC~;)^Ab`Qg+tz)>#k>eOS(T0Yv|k-U_4&MRwQqH-ngiQ9xFeSf*MYw^2`~ zRP*`UhCO`v;M(c4$l=AV0U^5=1|g=OhXUwO2zWV2Y7lI=1te6shkphCE($}x;JC#c z^N^!ZWR9Q7ts||1!-5bA0+?*Z<<<&>9Bc*VK3R~YbE~IUK9=ySRVwB4<@tX3#eTOu z*Dp)G-&bGaipNi+zXnuUa!%jeUA@nxQT`Kp@q1c6-(UNw$%VCg{#4kGq9$CXPry4UL$PcGdNg75E4 z{QK_QR`1uyhXaks;JaGyw~e_EdcTaSdi*4ETVy(n^GGmXiJS##oh=B)dL))9jZpKB zbcZe3b)N43{W8y7q%xs|=Tz?o|3j*`~&u}~XXYE%c; zZDIhf;w=4Q<9bz?%hBPfm#`HZ~1ZOF#@Lj`qL=_Zp$7qVYvdCIByH z<^`_r0l`hdh5}AGUvzqGUA@{humy6X3GGj}Yp{dQCqA8eg5uxtJ%%*)Q5J8QPLQ&j zjnAsB!+PUBT4)LM1I4M9V{#NTMR(+>$$4DSScWZ1 zkS_!>sH%o