Skip to content

Commit 8e22a4d

Browse files
rmkaplanrmkaplan
authored
UNPACKFILENAME produces lt-gt for top-level directory (#1696)
* UNPACKFILENAME produces <> for top-level directory For virtually any combination of leading <, > or /. Addresses #1685. * Produce < instead of <> for top-level empty directory Does not yet deal with all combinations of directory-internal bracket sequences
1 parent b8de820 commit 8e22a4d

File tree

2 files changed

+53
-57
lines changed

2 files changed

+53
-57
lines changed

‎sources/ADIR‎

Lines changed: 53 additions & 57 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
11
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
22

3-
(FILECREATED " 9-Mar-2024 10:24:39" {WMEDLEY}<sources>ADIR.;38 67777
3+
(FILECREATED " 6-May-2024 15:54:01" {WMEDLEY}<sources>ADIR.;45 67756
44

55
:EDIT-BY rmk
66

7-
:CHANGES-TO (FNS UNPACKFILENAME.STRING FILENAMEFIELD FILENAMEFIELD.STRING \UPF.DIRECTORY)
7+
:CHANGES-TO (FNS \UPF.DIRECTORY)
88

9-
:PREVIOUS-DATE "13-Nov-2023 20:28:57" {WMEDLEY}<sources>ADIR.;31)
9+
:PREVIOUS-DATE " 4-May-2024 16:25:09" {WMEDLEY}<sources>ADIR.;44)
1010

1111

1212
(PRETTYCOMPRINT ADIRCOMS)
@@ -317,7 +317,8 @@
317317
(DEFINEQ
318318

319319
(UNPACKFILENAME.STRING
320-
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 9-Mar-2024 10:23 by rmk")
320+
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 4-May-2024 12:45 by rmk")
321+
(* ; "Edited 9-Mar-2024 10:23 by rmk")
321322
(* ; "Edited 13-Nov-2023 20:28 by rmk")
322323
(* ; "Edited 28-Apr-2022 11:40 by rmk")
323324
(* ; "Edited 24-Apr-2022 14:11 by rmk")
@@ -350,7 +351,6 @@
350351
(* ;; "")
351352

352353
(* ;; " 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")
353-
(* ; "")
354354

355355
(* ;; " (Rationale: Those are not sub-directory brackets)")
356356

@@ -662,52 +662,48 @@
662662
(PUSH $$VAL F FVAL])
663663

664664
(\UPF.DIRECTORY
665-
[LAMBDA (DIRSTART DIREND DIRDIRTY $$BASE $$FATP $$READONLY)(* ; "Edited 8-Mar-2024 23:03 by rmk")
665+
[LAMBDA (DIRSTART DIREND DIRDIRTY $$BASE $$FATP $$READONLY)(* ; "Edited 6-May-2024 15:53 by rmk")
666+
(* ; "Edited 4-May-2024 16:25 by rmk")
667+
(* ; "Edited 8-Mar-2024 23:03 by rmk")
666668
(* ; "Edited 28-Apr-2022 09:15 by rmk")
667669
(* ; "Edited 27-Apr-2022 08:50 by rmk")
668670
(* ; "Edited 23-Apr-2022 17:09 by rmk")
669671

670-
(* ;; "Relative directory {abc}<foo or {abc}< with no >, subdirectory >foo or > with no host or device (DIRSTART=1). ")
671-
672-
(* ;; "Advance DIRSTART through initial duplicates")
673-
674-
(LET ((BRACKET (SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
675-
((< /)
676-
"<")
677-
(> ">")
678-
NIL)))
679-
(IF (EQ DIREND DIRSTART)
680-
THEN
681-
(* ;; "If EQ, the directory is is empty.")
682-
683-
(MKSTRING "")
684-
ELSE (CL:WHEN BRACKET (* ; "Skip the < or /")
685-
(ADD DIRSTART 1))
686-
687-
(* ;;
688-
 "Convert / to >, remove all // /> >> duplicate sequences (keep the first, skip the others)")
689-
690-
(IF DIRDIRTY
691-
THEN (FOR DIROFF C DEST DESTBASE (DESTPOS _ -1) FROM DIRSTART TO DIREND
692-
FIRST (SETQ DEST (ALLOCSTRING (ADD1 (IDIFFERENCE DIREND DIRSTART))
693-
NIL NIL $$FATP))
694-
(SETQ DESTBASE (FETCH (STRINGP BASE) OF DEST))
695-
DO (ADD DESTPOS 1)
696-
(SETQ C (\GETBASECHAR $$FATP $$BASE DIROFF))
697-
(SELCHARQ C
698-
((> /)
699-
(\PUTBASECHAR $$FATP DESTBASE DESTPOS (CHARCODE >))
700-
701-
(* ;; "Advance past duplicates")
702-
703-
(FIND I FROM (ADD1 DIROFF) TO DIREND
704-
WHILE (FMEMB (\GETBASECHAR $$FATP $$BASE I)
705-
(CHARCODE (> /)))
706-
FINALLY (SETQ DIROFF (SUB1 I))))
707-
(\PUTBASECHAR $$FATP DESTBASE DESTPOS C))
708-
FINALLY (REPLACE (STRINGP LENGTH) OF DEST WITH DESTPOS)
709-
(RETURN DEST))
710-
ELSE (\UPF.EXTRACT DIRSTART (SUB1 DIREND])
672+
(* ;; "Extract the directory field, producing <> for the empty (top-level) directory, normalizing / to < or >.")
673+
674+
(if (ILEQ DIREND DIRSTART)
675+
then
676+
(* ;; "An empty directory field is interpreted as the top as per issue #1685: <xy >xy /xy all map to <>")
677+
678+
(MKSTRING "<")
679+
else (CL:WHEN (MEMB (\GETBASECHAR $$FATP $$BASE DIRSTART)
680+
(CHARCODE (< / >))) (* ; "Skip leading brackets")
681+
(ADD DIRSTART 1))
682+
683+
(* ;;
684+
 "If DIRDIRTY, the string contained at least one / that has to be converted to < or >")
685+
686+
(IF DIRDIRTY
687+
THEN (FOR DIROFF C DEST DESTBASE (DESTPOS _ -1) FROM DIRSTART TO DIREND
688+
FIRST (SETQ DEST (ALLOCSTRING (ADD1 (IDIFFERENCE DIREND DIRSTART))
689+
NIL NIL $$FATP))
690+
(SETQ DESTBASE (FETCH (STRINGP BASE) OF DEST))
691+
DO (ADD DESTPOS 1)
692+
(SETQ C (\GETBASECHAR $$FATP $$BASE DIROFF))
693+
(SELCHARQ C
694+
((> /)
695+
(\PUTBASECHAR $$FATP DESTBASE DESTPOS (CHARCODE >))
696+
697+
(* ;; "Advance past duplicates")
698+
699+
(FIND I FROM (ADD1 DIROFF) TO DIREND
700+
WHILE (FMEMB (\GETBASECHAR $$FATP $$BASE I)
701+
(CHARCODE (> /))) FINALLY (SETQ DIROFF
702+
(SUB1 I))))
703+
(\PUTBASECHAR $$FATP DESTBASE DESTPOS C))
704+
FINALLY (REPLACE (STRINGP LENGTH) OF DEST WITH DESTPOS)
705+
(RETURN DEST))
706+
ELSE (\UPF.EXTRACT DIRSTART (SUB1 DIREND])
711707
)
712708
(DECLARE%: DONTCOPY
713709
(DECLARE%: EVAL@COMPILE
@@ -1254,14 +1250,14 @@
12541250
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
12551251
)
12561252
(DECLARE%: DONTCOPY
1257-
(FILEMAP (NIL (3169 15826 (DELFILE 3179 . 3340) (FULLNAME 3342 . 3709) (INFILE 3711 . 3970) (INFILEP
1258-
3972 . 4107) (IOFILE 4109 . 4360) (OPENFILE 4362 . 4665) (OPENSTREAM 4667 . 9007) (OUTFILE 9009 . 9271
1259-
) (OUTFILEP 9273 . 9409) (RENAMEFILE 9411 . 9717) (SIMPLE.FINDFILE 9719 . 10129) (VMEMSIZE 10131 .
1260-
10298) (\COPYSYS 10300 . 14545) (\FLUSHVM 14547 . 15619) (\LOGOUT0 15621 . 15824)) (16284 38972 (
1261-
UNPACKFILENAME.STRING 16294 . 36274) (\UPF.DIRECTORY 36276 . 38970)) (40500 42806 (UNPACKFILENAME
1262-
40510 . 40696) (LASTCHPOS 40698 . 41392) (FILENAMEFIELD 41394 . 41688) (FILENAMEFIELD.STRING 41690 .
1263-
42094) (PACKFILENAME 42096 . 42439) (PACKFILENAME.STRING 42441 . 42804)) (57276 58189 (
1264-
FILEDIRCASEARRAY 57286 . 58187)) (58356 65536 (LOGOUT 58366 . 59283) (MAKESYS 59285 . 60914) (SYSOUT
1265-
60916 . 62468) (SAVEVM 62470 . 63270) (HERALD 63272 . 63432) (INTERPRET.REM.CM 63434 . 65159) (
1266-
\USEREVENT 65161 . 65534)) (65718 67445 (USERNAME 65728 . 66684) (SETUSERNAME 66686 . 67443)))))
1253+
(FILEMAP (NIL (3112 15769 (DELFILE 3122 . 3283) (FULLNAME 3285 . 3652) (INFILE 3654 . 3913) (INFILEP
1254+
3915 . 4050) (IOFILE 4052 . 4303) (OPENFILE 4305 . 4608) (OPENSTREAM 4610 . 8950) (OUTFILE 8952 . 9214
1255+
) (OUTFILEP 9216 . 9352) (RENAMEFILE 9354 . 9660) (SIMPLE.FINDFILE 9662 . 10072) (VMEMSIZE 10074 .
1256+
10241) (\COPYSYS 10243 . 14488) (\FLUSHVM 14490 . 15562) (\LOGOUT0 15564 . 15767)) (16227 38951 (
1257+
UNPACKFILENAME.STRING 16237 . 36252) (\UPF.DIRECTORY 36254 . 38949)) (40479 42785 (UNPACKFILENAME
1258+
40489 . 40675) (LASTCHPOS 40677 . 41371) (FILENAMEFIELD 41373 . 41667) (FILENAMEFIELD.STRING 41669 .
1259+
42073) (PACKFILENAME 42075 . 42418) (PACKFILENAME.STRING 42420 . 42783)) (57255 58168 (
1260+
FILEDIRCASEARRAY 57265 . 58166)) (58335 65515 (LOGOUT 58345 . 59262) (MAKESYS 59264 . 60893) (SYSOUT
1261+
60895 . 62447) (SAVEVM 62449 . 63249) (HERALD 63251 . 63411) (INTERPRET.REM.CM 63413 . 65138) (
1262+
\USEREVENT 65140 . 65513)) (65697 67424 (USERNAME 65707 . 66663) (SETUSERNAME 66665 . 67422)))))
12671263
STOP

‎sources/ADIR.LCOM‎

-123 Bytes
Binary file not shown.

0 commit comments

Comments
 (0)