github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-09 12:40:30 +00:00
Code Issues Projects Releases Wiki Activity

Files have been commited to test repo, remove from medley (#878)

Browse Source
This commit is contained in:
Larry Masinter
2022-08-14 12:14:54 -07:00
committed by GitHub
parent 39a7512458
commit d379bcc102
32 changed files with 0 additions and 10489 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2842
internal/COMPTEST
View File

File diff suppressed because it is too large Load Diff

BIN
internal/COMPTEST.LCOM
View File

Binary file not shown.

BIN
internal/DO-TEST
View File

Binary file not shown.

BIN
internal/DO-TEST.LCOM
View File

Binary file not shown.

165
internal/DO-TEST.TEDIT
View File

File diff suppressed because one or more lines are too long

BIN
internal/DO-TEST.pdf
View File

Binary file not shown.

1
internal/DTEST.TEDIT
View File

@@ -1 +0,0 @@
Running DSKTEST

1493
internal/MACROTEST
View File

File diff suppressed because it is too large Load Diff

BIN
internal/MACROTEST.LCOM
View File

Binary file not shown.

3359
internal/MACROTESTAUX
View File

File diff suppressed because it is too large Load Diff

BIN
internal/MACROTESTAUX.LCOM
View File

Binary file not shown.

1144
internal/envos/DSKTEST
View File

File diff suppressed because it is too large Load Diff

BIN
internal/envos/DSKTEST.TEDIT
View File

Binary file not shown.

105
internal/envos/FLOPPYTESTER
View File

@@ -1,105 +0,0 @@
(FILECREATED "24-Mar-86 15:18:14" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;9 4308
changes to: (FNS STARTTEST STOPTEST KILLTEST)
(VARS FLOPPYTESTERCOMS)
previous date: "20-Mar-86 21:06:46" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;5)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FLOPPYTESTERCOMS)
(RPAQQ FLOPPYTESTERCOMS ((* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
(P (LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM)))
(INITVARS (ALLOCATIONSW NIL))
(FNS STARTTEST STOPTEST KILLTEST BLTALLOCS BLTALLOC)))
(* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
(LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM))
(RPAQ? ALLOCATIONSW NIL)
(DEFINEQ
(STARTTEST
(LAMBDA (N) (* kbr: "24-Mar-86 15:15")
(SETQ STARTTIME (GDATE))
(CNDIR (QUOTE {FLOPPY}))
(FLOPPY.FORMAT (QUOTE TEST))
(DIRECTORY (QUOTE {FLOPPY}*))
(BLTALLOCS)
(for I from 1 to N do (DOFILEBANGER (PACK* (QUOTE {FLOPPY})
(QUOTE TESTFILE)
I)
(RAND 10 30)))))
(STOPTEST
(LAMBDA NIL (* kbr: "24-Mar-86 15:16")
(SETQ STOPTIME (GDATE))
(for P in FILEBANGERS when (NOT (EQ P (THIS.PROCESS))) do (SUSPEND.PROCESS P))))
(KILLTEST
(LAMBDA NIL (* kbr: "22-Mar-86 17:18")
(for P in FILEBANGERS do (DEL.PROCESS P))
(SETQ FILEBANGERS NIL)))
(BLTALLOCS
[LAMBDA NIL (* kbr: "18-Nov-85 12:32")
(* Debugging fn. Puts up a window representation of 
allocations on floppy. *)
(PROG (PIXELS XLENGTH YLENGTH)
(SETQ PIXELS 5)
(SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
(SETQ YLENGTH \FLOPPY.CYLINDERS)
[COND
((NULL ALLOCATIONSW)
(SETQ ALLOCATIONSW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (ITIMES PIXELS
XLENGTH))
(HEIGHTIFWINDOW (ITIMES PIXELS
YLENGTH)
T)
NIL NIL NIL
"Position FLOPPY ALLOCATIONS window")
"FLOPPY ALLOCATIONS"))
(UNADVISE (QUOTE \PFLOPPY.ALLOCATE))
(ADVISE (QUOTE \PFLOPPY.ALLOCATE)
(QUOTE AFTER)
(QUOTE (COND (!VALUE (BLTALLOC !VALUE]
(BITBLT NIL NIL NIL ALLOCATIONSW NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(for Y from 0 to (SUB1 YLENGTH) do (for X from 0 to (SUB1 XLENGTH)
do (BITMAPBIT ALLOCATIONSW
(ITIMES PIXELS X)
(ITIMES PIXELS Y)
1)))
(for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV)
when [NOT (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
(QUOTE (FREE]
do (BLTALLOC PFALLOC])
(BLTALLOC
[LAMBDA (PFALLOC) (* kbr: "18-Nov-85 12:21")
(PROG (SHADE OPSHADE LEFT BOTTOM PIXELS XLENGTH)
(SETQ PIXELS 5)
(SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
(SETQ SHADE (COND
((EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
(QUOTE (FREE)))
WHITESHADE)
(T BLACKSHADE)))
(SETQ OPSHADE (IDIFFERENCE BLACKSHADE SHADE))
(for I from (fetch (PFALLOC START) of PFALLOC) to (fetch (PFALLOC END)
of PFALLOC)
do (SETQ LEFT (ITIMES PIXELS (IREMAINDER (SUB1 I)
XLENGTH)))
(SETQ BOTTOM (ITIMES PIXELS (IQUOTIENT (SUB1 I)
XLENGTH)))
(BLTSHADE SHADE ALLOCATIONSW LEFT BOTTOM PIXELS PIXELS (QUOTE REPLACE))
(BLTSHADE OPSHADE ALLOCATIONSW LEFT BOTTOM 1 1 (QUOTE REPLACE])
)
(PUTPROPS FLOPPYTESTER COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (745 4220 (STARTTEST 755 . 1203) (STOPTEST 1205 . 1463) (KILLTEST 1465 . 1665) (
BLTALLOCS 1667 . 3253) (BLTALLOC 3255 . 4218)))))
STOP

242
internal/envos/RS232TEST
View File

@@ -1,242 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "26-Jun-90 19:15:35" |{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;2| 9419
|changes| |to:| (VARS RS232TESTCOMS)
|previous| |date:| "20-Feb-87 00:10:14"
|{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;1|)
; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT RS232TESTCOMS)
(RPAQQ RS232TESTCOMS
((FNS RSTEST TESTCLEANUP XMITTEST)
(* |;;|
 "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(FNS RS232.TEST RS232.MICROTEST RS232.QUICKTEST RS232.MENU RS232TMENU.SELFN)
(VARS RS232.TEST.MENU.ITEMS)
(* |;;|
 "Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(FNS TTY.TEST TTY.MICROTEST TTY.QUICKTEST TTY.MENU TTYTMENU.SELFN)))
(DEFINEQ
(rstest
(lambda nil (* \; "Edited 14-Jan-87 16:00 by jds")
(let (oo)
(resetlst (resetsave (setq oo (openstream '{rs232} 'output))
'closef?)
(|for| i |from| 1 |do| (printout oo "Line " i
": 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
\
")
(printout t "Line " i t))))))
(testcleanup
(lambda nil (* \; "Edited 16-Jan-87 09:51 by jds")
(* |;;| "Close the streams used by the rs232 test.")
(and (boundp 'out)
out
(closef? out))
(and (boundp in)
in
(closef? in))))
(XMITTEST
(LAMBDA (BAUDRATE XONXOFF?) (* \; "Edited 19-Feb-87 20:59 by jds")
(* |;;| "Set up the rs232 port at BAUDRATE with XOn-XOff flow control if XONXOFF? is T. Then print forever, lines of text. Show an indication on the screen for each line, so the user can tell if flow control has shut things off.")
(RS232C.INIT BAUDRATE 8 'NONE 1 (COND
(XONXOFF? 'XONXOFF)
(T 'NONE)))
(SETQ OUT (OPENSTREAM '{RS232} 'OUTPUT))
(SETQ IN (OPENSTREAM '{RS232} 'INPUT))
(ERSETQ (FOR I FROM 1 DO (PRINTOUT OUT "Line " I ": 0 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
\
")
(|printout| T "Line " I T)))
(CLOSEF? OUT)
(CLOSEF? IN)))
)
(* |;;| "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(DEFINEQ
(rs232.test
(lambda nil (* \; "Edited 19-Feb-87 22:43 by jds")
(* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")
(printout t t t "Starting RS-232 port test." t
"Make sure the line monitor is attached to the RS-232 port, "
"and its cable goes to the DCE socket on the monitor." t)
(mouseconfirm)
(printout t "Set the line monitor for: " t)
(|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
|do| (|for| stopbits |in| '(1 1.5 2)
|do| (rs232.microtest 9600 bits parity stopbits))))))
(rs232.microtest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:37 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(printout t bits "bits, " (cond
((eq parity 'none)
"NO")
(t parity))
" parity, " stopbits " stop bits..." t)
(mouseconfirm)
(rs232.quicktest speed bits parity stopbits)))
(rs232.quicktest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:38 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(rs232c.init speed bits parity stopbits 'none)
(let ((out (openstream '{rs232} 'output)))
(prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
out)
(closef out))))
(rs232.menu
(lambda nil (* \; "Edited 19-Feb-87 22:45 by jds")
(let ((ww (addmenu (|create| menu
menucolumns _ 4
items _ rs232.test.menu.items
whenselectedfn _ (function rs232tmenu.selfn)))))
(windowprop ww 'title "RS-232 Tests"))))
(rs232tmenu.selfn
(lambda (item menu key) (* \; "Edited 19-Feb-87 22:57 by jds")
(* |;;| "Called from the RS-232 test menu")
(let* ((info (cadr item))
(bits (car info))
(parity (cadr info))
(stopbits (caddr info)))
(rs232.quicktest 9600 bits parity stopbits))))
)
(RPAQQ RS232.TEST.MENU.ITEMS
((|5/N/1| (5 NONE 1))
(|6/N/1| (6 NONE 1))
(|7/N/1| (7 NONE 1))
(|8/N/1| (8 NONE 1))
(|5/N/1.5| (5 NONE 1.5))
(|6/N/1.5| (6 NONE 1.5))
(|7/N/1.5| (7 NONE 1.5))
(|8/N/1.5| (8 NONE 1.5))
(|5/N/2| (5 NONE 2))
(|6/N/2| (6 NONE 2))
(|7/N/2| (7 NONE 2))
(|8/N/2| (8 NONE 2))
(|5/O/1| (5 ODD 1))
(|6/O/1| (6 ODD 1))
(|7/O/1| (7 ODD 1))
(|8/O/1| (8 ODD 1))
(|5/O/1.5| (5 ODD 1.5))
(|6/O/1.5| (6 ODD 1.5))
(|7/O/1.5| (7 ODD 1.5))
(|8/O/1.5| (8 ODD 1.5))
(|5/O/2| (5 ODD 2))
(|6/O/2| (6 ODD 2))
(|7/O/2| (7 ODD 2))
(|8/O/2| (8 ODD 2))
(|5/E/1| (5 EVEN 1))
(|6/E/1| (6 EVEN 1))
(|7/E/1| (7 EVEN 1))
(|8/E/1| (8 EVEN 1))
(|5/E/1.5| (5 EVEN 1.5))
(|6/E/1.5| (6 EVEN 1.5))
(|7/E/1.5| (7 EVEN 1.5))
(|8/E/1.5| (8 EVEN 1.5))
(|5/E/2| (5 EVEN 2))
(|6/E/2| (6 EVEN 2))
(|7/E/2| (7 EVEN 2))
(|8/E/2| (8 EVEN 2))))
(* |;;|
"Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
(DEFINEQ
(tty.test
(lambda nil (* \; "Edited 19-Feb-87 22:42 by jds")
(* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")
(printout t t t "Starting TTY port test." t
"Make sure the line monitor is attached to the TTY port, "
"and its cable goes to the DTE socket on the monitor." t)
(mouseconfirm)
(printout t "Set the line monitor for: " t)
(|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
|do| (|for| stopbits |in| '(1 1.5 2)
|do| (tty.microtest 9600 bits parity stopbits))))))
(tty.microtest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:41 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(printout t bits "bits, " (cond
((eq parity 'none)
"NO")
(t parity))
" parity, " stopbits " stop bits..." t)
(mouseconfirm)
(tty.init speed bits parity stopbits)))
(tty.quicktest
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:40 by jds")
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
(tty.init speed bits parity stopbits 'none)
(let ((out (openstream '{tty} 'output)))
(prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
out)
(closef out))))
(tty.menu
(lambda nil (* \; "Edited 19-Feb-87 22:57 by jds")
(let ((ww (addmenu (|create| menu
menucolumns _ 4
items _ rs232.test.menu.items
whenselectedfn _ (function ttytmenu.selfn)))))
(windowprop ww 'title "TTY Tests"))))
(ttytmenu.selfn
(lambda (item menu key) (* \; "Edited 19-Feb-87 22:59 by jds")
(* |;;| "Called from the RS-232 test menu")
(let* ((info (cadr item))
(bits (car info))
(parity (cadr info))
(stopbits (caddr info)))
(tty.quicktest 9600 bits parity stopbits))))
)
(PUTPROPS RS232TEST COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (979 2623 (RSTEST 989 . 1466) (TESTCLEANUP 1468 . 1789) (XMITTEST 1791 . 2621)) (2732
5433 (RS232.TEST 2742 . 3570) (RS232.MICROTEST 3572 . 4151) (RS232.QUICKTEST 4153 . 4640) (RS232.MENU
4642 . 5042) (RS232TMENU.SELFN 5044 . 5431)) (6665 9325 (TTY.TEST 6675 . 7493) (TTY.MICROTEST 7495 .
8061) (TTY.QUICKTEST 8063 . 8543) (TTY.MENU 8545 . 8938) (TTYTMENU.SELFN 8940 . 9323)))))
STOP

1
internal/test/filepos/BIG.XCCS
View File

File diff suppressed because one or more lines are too long

1
internal/test/filepos/BIGGREEK.UTF8
View File

File diff suppressed because one or more lines are too long

1
internal/test/filepos/BIGGREEK.XCCS
View File

File diff suppressed because one or more lines are too long

1
internal/test/filepos/FIVE
View File

@@ -1 +0,0 @@
12345

BIN
internal/test/filepos/FPTESTS
View File

Binary file not shown.

1
internal/test/filepos/GREEK.UTF8
View File

@@ -1 +0,0 @@
aδσγδφβc

BIN
internal/test/filepos/GREEK.XCCS
View File

Binary file not shown.

BIN
internal/test/filepos/README
View File

Binary file not shown.

1
internal/test/filepos/SHORT.XCCS
View File

@@ -1 +0,0 @@
012345X1245

495
internal/test/filepos/TFP
View File

@@ -1,495 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Jul-2022 14:07:11" 
{DSK}<users>kaplan>local>medley3.5>working-medley>internal>test>filepos>TFP.;31 27425
:CHANGES-TO (FNS TFP TFP1)
:PREVIOUS-DATE " 3-Jul-2022 13:32:16"
{DSK}<users>kaplan>local>medley3.5>working-medley>internal>test>filepos>TFP.;27)
(PRETTYCOMPRINT TFPCOMS)
(RPAQQ TFPCOMS
((FNS TFP TFP1 FPC FPCS)
(FNS OLDFILEPOS OLDFFILEPOS)
(FILES FPTESTS)
(ADDVARS (DIRECTORIES {WMEDLEY}<internal>test>filepos>))
(* ;; "Compiling also requires EXPORTS.ALL")
(DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
IOCHAR))))
(DEFINEQ
(TFP
[LAMBDA (TESTNAMES TAGS FN) (* ; "Edited 3-Jul-2022 14:06 by rmk")
(CL:UNLESS TESTNAMES (SETQ TESTNAMES ALLTESTS))
(LET [(TESTS (FOR TN INSIDE TESTNAMES FIRST (PRINTOUT T "Testing")
JOIN (PRINTOUT T " " TN)
(CONS (MKSTRING TN)
(COPY (EVALV TN))) FINALLY (TERPRI T]
(CL:WHEN TAGS
(SETQ TESTS (FOR TEST IN TESTS WHEN (THEREIS TAG INSIDE TAGS
SUCHTHAT (MEMB TAG TEST)) COLLECT TEST)))
(PRINTOUT T (LENGTH TESTS)
" tests" T)
(FOR TEST VAL COMMENT PRINTED IN TESTS EACHTIME (CL:WHEN (STRINGP TEST)
(SETQ COMMENT TEST)
(SETQ PRINTED NIL))
WHEN [AND (LISTP TEST)
(NOT (AND FN (CADDR TEST] UNLESS (EQUAL (CAR TEST)
(SETQ VAL (TFP1 (CADR TEST)
FN)))
COLLECT (CL:WHEN COMMENT
(CL:UNLESS PRINTED (PRINTOUT T COMMENT T)))
(PRINTOUT T 5 VAL " <- " .P2 TEST T)
(CONS VAL TEST])
(TFP1
[LAMBDA (FPARGS FN) (* ; "Edited 3-Jul-2022 14:04 by rmk")
(* ;; "FN is the search function to apply: NIL = FILEPOS, OLDFILEPOS, FFILEPOS. OLDFFILEPOS")
(* ;; "For convenience: NIL -> FILEPOS, OF -> OLDFILEPOS, FF -> FFILEPOS, OFF -> OLDFFILEPOS.")
(* ;; "OLDFILEPOS and OLDFFILEPOS do only a byte searches.")
(* ;;
 "FPARGS is a list of FILEPOS args. CASEARRAY=T means Transparent case array, pushes to FFILEPOS. ")
(* ;; "The file extension gives the format, defaulting to *DEFAULT-EXTERNALFORMAT* = :XCCS")
(SETQ FN (SELECTQ FN
((NIL FILEPOS)
'FILEPOS)
((FF FFILEPOS)
'FFILEPOS)
((OF OLDFILEPOS)
'OLDFILEPOS)
((OFF OLDFFILEPOS)
'OLDFFILEPOS)
(HELP "BAD FN" FN)))
(CL:WHEN (OR (FIXP (CAR FPARGS))
(NULL (CAR FPARGS))
(AND (LISTP (CAR FPARGS))
(FIXP (CAAR FPARGS))
(FIXP (CDAR FPARGS)))
(LISTP (CADR FPARGS)))
(SETQ FPARGS (CADR FPARGS)))
(LET (STREAM VAL PATTERN FILE START END SKIP TAIL CASEARRAY EXT (FORMAT *DEFAULT-EXTERNALFORMAT*)
)
(SETQ PATTERN (EVAL (POP FPARGS))) (* ;
 "So we can do substrings, CHARACTER etc.")
(SETQ FILE (POP FPARGS))
(SETQ START (POP FPARGS))
(SETQ END (POP FPARGS))
(SETQ SKIP (POP FPARGS))
(SETQ TAIL (POP FPARGS))
(SETQ CASEARRAY (POP FPARGS))
(SETQ EXT (FILENAMEFIELD.STRING FILE 'EXTENSION))
(CL:WHEN EXT
(CL:WHEN (STRPOS "UTF8" EXT)
(SETQ EXT "UTF-8"))
[SETQ FORMAT (FIND-FORMAT (CL:INTERN EXT 'KEYWORD])
[SETQ STREAM (OPENSTREAM (OR (FINDFILE FILE T)
FILE)
'INPUT NIL `((FORMAT ,FORMAT]
(SETQ CASEARRAY (IF (EQ CASEARRAY T)
THEN (CASEARRAY)
ELSE (EVAL CASEARRAY)))
(SETQ VAL (APPLY* FN PATTERN STREAM START END SKIP TAIL CASEARRAY))
(CLOSEF? STREAM)
VAL])
(FPC
[LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 29-Jun-2022 21:22 by rmk")
(* ;; "Compare old and new filepos")
(LET (OLD NEW EXT FORMAT)
(CL:UNLESS (STREAMP FILE)
(SETQ EXT (FILENAMEFIELD.STRING FILE 'EXTENSION))
(SETQ FORMAT (CL:INTERN EXT 'KEYWORD))
(CL:UNLESS (FIND-FORMAT FORMAT T)
(SETQ FORMAT :XCCS))
(STREAMPROP FILE 'FORMAT FORMAT))
(SETQ OLD (OLDFILEPOS STR FILE START END SKIP TAIL CASEARRAY))
(SETQ NEW (FILEPOS STR FILE START END SKIP TAIL CASEARRAY))
(CLOSEF FILE)
(CL:UNLESS (EQUAL OLD (IF (EQ TAIL 'BOTH)
THEN (CDR NEW)
ELSE NEW))
(HELP (CONCAT "OLD=" (OR OLD "NIL")
" NEW="
(OR NEW "NIL"))))
(LIST OLD NEW])
(FPCS
[LAMBDA (STR FILE START END SKIP TAIL) (* ; "Edited 29-Jun-2022 23:56 by rmk")
(* ; "Edited 28-Jun-2022 22:21 by rmk")
(* ;; "Compare old and new slow filepos")
(LET (FAST SLOW EXT FORMAT)
(CL:UNLESS (STREAMP FILE)
(SETQ EXT (FILENAMEFIELD.STRING FILE 'EXTENSION))
(SETQ FORMAT (CL:INTERN EXT 'KEYWORD))
(CL:UNLESS (FIND-FORMAT FORMAT T)
(SETQ FORMAT :XCCS))
(STREAMPROP FILE 'FORMAT FORMAT))
(SETQ FAST (FILEPOS STR FILE START END SKIP TAIL))
(SETQ SLOW (FILEPOS STR FILE START END SKIP TAIL (CASEARRAY)))
(CLOSEF FILE)
(CL:UNLESS (EQUAL FAST SLOW)
(HELP (CONCAT "FAST=" (OR FAST "NIL")
" SLOW="
(OR SLOW "NIL"))))
(LIST FAST SLOW])
)
(DEFINEQ
(OLDFILEPOS
[LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 27-Jun-2022 23:35 by rmk")
(* ; "Edited 10-Aug-2020 21:44 by rmk:")
(* Pavel "12-Oct-86 15:13")
(* ;; "RMK: Added coercion from internal XCCS string to UTF8 if searching a UTF8 file")
(* ;; "NB: this function now works on non-PAGEMAPPED files. It must use only IO functions that respect that.")
(PROG ((SKIPCHAR (AND SKIP (CHCON1 SKIP)))
[CA (fetch (ARRAYP BASE) of (COND
[CASEARRAY (COND
((AND (ARRAYP CASEARRAY)
(EQ (fetch (ARRAYP TYP) of CASEARRAY)
\ST.BYTE))
CASEARRAY)
(T (CASEARRAY CASEARRAY]
(T \TRANSPARENT]
(STREAM (\GETSTREAM FILE 'INPUT))
CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE
BIGENDBYTE STARTSEG ENDSEG)
(CL:WHEN (EQ :UTF-8 (\EXTERNALFORMAT STREAM))
(SETQ STR (XTOUSTRING STR)))
[COND
((LITATOM STR)
(SETQ STRBASE (fetch (LITATOM PNAMEBASE) of STR))
(SETQ STRINDEX 1)
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of STR)))
(T (OR (STRINGP STR)
(SETQ STR (MKSTRING STR)))
(SETQ STRBASE (fetch (STRINGP BASE) of STR))
(SETQ STRINDEX (fetch (STRINGP OFFST) of STR))
(SETQ PATLEN (fetch (STRINGP LENGTH) of STR] (* ;
 "calculate start addr and set file ptr.")
[SETQ STARTBYTE (COND
(START (COND
((NOT (AND (FIXP START)
(IGEQ START 0)))
(LISPERROR "ILLEGAL ARG" START)))
(SETQ ORGFILEPTR (\GETFILEPTR STREAM))
(\SETFILEPTR STREAM START)
START)
(T (SETQ ORGFILEPTR (\GETFILEPTR STREAM]
(* ;
 "calculate the character address of the character after the last possible match.")
[SETQ ENDBYTE (ADD1 (COND
((NULL END) (* ; "Default is end of file")
(IDIFFERENCE (\GETEOFPTR STREAM)
PATLEN))
((IGEQ END 0) (* ; "Absolute byte pointer given")
(IMIN END (IDIFFERENCE (\GETEOFPTR STREAM)
PATLEN)))
((IGREATERP PATLEN (IMINUS END))
(* ;
 "END is too far, use eof less length")
(IDIFFERENCE (\GETEOFPTR STREAM)
PATLEN))
(T (IDIFFERENCE (IPLUS (\GETEOFPTR STREAM)
END 1)
PATLEN]
(* ;; "use STARTBYTE and ENDBYTE instead of START and END because vm functions shouldn't change their arguments.")
(COND
((IGEQ STARTBYTE ENDBYTE) (* ; "nothing to search")
(GO FAILED)))
(SETQ LASTINDEX PATLEN)
SKIPLP
(* ;
 "set the first character to FIRSTCHAR, handling leading skips.")
(COND
((EQ LASTINDEX 0) (* ; "null case")
(GO FOUNDIT))
((EQ (SETQ FIRSTCHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE STRINDEX)))
SKIPCHAR) (* ;
 "first character in pattern is skip.")
(SETQ LASTINDEX (SUB1 LASTINDEX))
(\BIN STREAM) (* ; "Move forward a character.")
(add STRINDEX 1)
(add STARTBYTE 1)
(GO SKIPLP)))
(SETQ LASTINDEX (IPLUS LASTINDEX STRINDEX)) (* ;
 "Used for end of pattern check, comparing against current INDEX")
[COND
((SMALLP ENDBYTE)
(SETQ STARTSEG (SETQ ENDSEG 0)))
(T
(* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts. The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary (can get around that here by decrementing everyone, but can't in FFILEPOS). Note that STARTBYTE and ENDBYTE are never actually used as file ptrs, just for counting.")
(SETQ ENDSEG (FOLDLO ENDBYTE FILEPOS.SEGMENT.SIZE))
(SETQ BIGENDBYTE (IMOD ENDBYTE FILEPOS.SEGMENT.SIZE))
(SETQ STARTSEG (FOLDLO STARTBYTE FILEPOS.SEGMENT.SIZE))
(SETQ STARTBYTE (IMOD STARTBYTE FILEPOS.SEGMENT.SIZE))
(SETQ ENDBYTE (COND
((EQ STARTSEG ENDSEG)
BIGENDBYTE)
(T
(* ;; "In different segments, so we'll have to search all the way to the end of this seg; hence, `end' is currently as big as it gets")
FILEPOS.SEGMENT.SIZE]
FIRSTCHARLP
(* ;; "STARTBYTE is the possible beginning of a match. the file ptr of the file is always at STARTBYTE position when the FIRSTCHAR loop is passed.")
(COND
((EQ STARTBYTE ENDBYTE) (* ; "end of this part of search")
(COND
((EQ STARTSEG ENDSEG) (* ; "failed")
(GO FAILED))) (* ;
 "Finished this segment, roll over into new one")
(SETQ STARTBYTE 0) (* ; "= STARTBYTE-FILEPOS.SEGMENT.SIZE")
[COND
((EQ (add STARTSEG 1)
ENDSEG) (* ;
 "Entering final segment, so set ENDBYTE to actual end instead of segment end")
(COND
((EQ (SETQ ENDBYTE BIGENDBYTE)
0)
(GO FAILED]
(GO FIRSTCHARLP))
((NEQ FIRSTCHAR (\GETBASEBYTE CA (\BIN STREAM)))
(add STARTBYTE 1)
(GO FIRSTCHARLP)))
(SETQ PATINDEX STRINDEX)
MATCHLP
(* ;
 "At this point, STR is matched thru offset PATINDEX")
(COND
((EQ (SETQ PATINDEX (ADD1 PATINDEX))
LASTINDEX) (* ; "matched for entire length")
(GO FOUNDIT))
((OR (EQ (SETQ CHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE PATINDEX)))
(\GETBASEBYTE CA (\BIN STREAM)))
(EQ CHAR SKIPCHAR)) (* ;
 "Char from file matches char from STR")
(GO MATCHLP))
(T (* ;
 "Match failed, so we have to start again with first char")
(\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM)
(IDIFFERENCE PATINDEX STRINDEX)))
(* ;; "Back up over the chars we have just read in trying to match, less one. I.e. go back to one past the previous starting point")
(add STARTBYTE 1)
(GO FIRSTCHARLP)))
FOUNDIT
(* ;
 "set fileptr, adjust for beginning skips and return proper value.")
[COND
((NOT TAIL) (* ;
 "Fileptr wants to be at start of string")
(\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM)
PATLEN]
(RETURN (\GETFILEPTR STREAM))
FAILED
(* ;
 "return the fileptr to its initial position.")
(\SETFILEPTR STREAM ORGFILEPTR)
(RETURN NIL])
(OLDFFILEPOS
[LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 10-Aug-2020 21:44 by rmk:")
(* ;; "RMK: Added coercion from internal XCCS string to UTF8 if searching a UTF8 file")
(* Pavel "12-Oct-86 15:20")
(PROG ([STREAM (\GETSTREAM (OR FILE (INPUT]
PATBASE PATOFFSET PATLEN ORGFILEPTR STARTOFFSET ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG EOF
)
(COND
(SKIP (* ; "Slow case--use FILEPOS")
(GO TRYFILEPOS))
((NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM)))
(* ;
 "This is a non-page-oriented file. Use FILEPOS instead.")
(GO TRYFILEPOS))) (* ;
 "calculate start addr and set file ptr.")
(CL:WHEN (EQ :UTF8 (\EXTERNALFORMAT STREAM))
(SETQ PATTERN (XTOUSTRING PATTERN)))
[COND
((LITATOM PATTERN)
(SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PATTERN))
(SETQ PATOFFSET 1)
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PATTERN)))
(T (OR (STRINGP PATTERN)
(SETQ PATTERN (MKSTRING PATTERN)))
(SETQ PATBASE (fetch (STRINGP BASE) of PATTERN))
(SETQ PATOFFSET (fetch (STRINGP OFFST) of PATTERN))
(SETQ PATLEN (fetch (STRINGP LENGTH) of PATTERN]
(COND
((OR (IGREATERP PATLEN \MAX.PATTERN.SIZE)
(ILESSP PATLEN \MIN.PATTERN.SIZE))
(GO TRYFILEPOS)))
(SETQ ORGFILEPTR (\GETFILEPTR STREAM))
(SETQ STARTOFFSET (IPLUS (COND
(START (COND
((NOT (AND (FIXP START)
(IGEQ START 0)))
(LISPERROR "ILLEGAL ARG" START)))
START)
(T ORGFILEPTR))
(SUB1 PATLEN))) (* ;
 "STARTOFFSET is the address of the character corresponding to the last character of PATTERN.")
(SETQ EOF (\GETEOFPTR STREAM)) (* ;
 "calculate the character address of the character after the last possible match.")
[SETQ ENDOFFSET (COND
((NULL END) (* ; "Default is end of file")
EOF)
(T (IMIN (IPLUS (COND
((ILESSP END 0)
(IPLUS EOF END 1))
(T END))
PATLEN)
EOF]
(* ;; "use STARTOFFSET and ENDOFFSET instead of START and END because vm functions shouldn't change their arguments.")
(COND
((IGEQ STARTOFFSET ENDOFFSET) (* ; "nothing to search")
(RETURN))
((ILESSP (IDIFFERENCE ENDOFFSET STARTOFFSET)
\MIN.SEARCH.LENGTH) (* ;
 "too small to make FFILEPOS worthwhile")
(GO TRYFILEPOS)))
(\SETFILEPTR STREAM STARTOFFSET)
[RETURN (GLOBALRESOURCE
(\FFDELTA1 \FFDELTA2 \FFPATCHAR)
(PROG ((CASE (fetch (ARRAYP BASE)
of (COND
[CASEARRAY (COND
((AND (ARRAYP CASEARRAY)
(EQ (fetch (ARRAYP TYP) of CASEARRAY)
\ST.BYTE))
CASEARRAY)
(T (CASEARRAY CASEARRAY]
(T \TRANSPARENT))))
(DELTA1 (fetch (ARRAYP BASE) of \FFDELTA1))
(DELTA2 (fetch (ARRAYP BASE) of \FFDELTA2))
(PATCHAR (fetch (ARRAYP BASE) of \FFPATCHAR))
(MAXPATINDEX (SUB1 PATLEN))
CHAR CURPATINDEX LASTCHAR INC)
(* ;; "Use Boyer-Moore string search algorithm. Use two auxiliary tables, DELTA1 and DELTA2, to tell how far ahead to move in the file when a partial match fails. DELTA1 contains, for each character code, the distance of that character from the right end of the pattern, or PATLEN if the character does not occur in the pattern. DELTA2 contains, for each character position in the pattern, how far ahead to move such that the partial substring discovered to the right of the position now matches some other substring (to the left) in the pattern. PATCHAR is just PATTERN translated thru CASEARRAY")
(\SETUP.FFILEPOS PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE)
[COND
((SMALLP ENDOFFSET)
(SETQ STARTSEG (SETQ ENDSEG 0)))
(T
(* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts. The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary. Note that STARTOFFSET and ENDOFFSET are never actually used as file ptrs, just for counting.")
(SETQ ENDSEG (FOLDLO ENDOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ BIGENDOFFSET (MOD ENDOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ STARTSEG (FOLDLO STARTOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ STARTOFFSET (MOD STARTOFFSET FILEPOS.SEGMENT.SIZE))
(SETQ ENDOFFSET (COND
((EQ STARTSEG ENDSEG)
BIGENDOFFSET)
(T
(* ;; "In different segments, so we'll have to search all the way to the end of this seg; hence, `end' is currently as big as it gets")
FILEPOS.SEGMENT.SIZE]
(SETQ LASTCHAR (GETBASEBYTE PATCHAR MAXPATINDEX))
FIRSTCHARLP
(COND
[(IGEQ STARTOFFSET ENDOFFSET) (* ; "End of this chunk")
(COND
((EQ STARTSEG ENDSEG) (* ; "failed")
(GO FAILED))
(T (* ;
 "Finished this segment, roll over into new one")
(add STARTSEG 1)
(SETQ STARTOFFSET (IDIFFERENCE STARTOFFSET FILEPOS.SEGMENT.SIZE))
(COND
((EQ STARTSEG ENDSEG)
(SETQ ENDOFFSET BIGENDOFFSET)))
(GO FIRSTCHARLP]
((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN STREAM)))
LASTCHAR)
(add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR)))
(OR (EQ INC 1)
(\INCFILEPTR STREAM (SUB1 INC)))
(* ;
 "advance file pointer accordingly (\BIN already advanced it one)")
(GO FIRSTCHARLP)))
(SETQ CURPATINDEX (SUB1 MAXPATINDEX))
MATCHLP
(COND
((ILESSP CURPATINDEX 0)
(GO FOUNDIT)))
(\DECFILEPTR STREAM 2) (* ; "back up to read previous char")
(COND
((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN STREAM)))
(GETBASEBYTE PATCHAR CURPATINDEX))
(* ;
 "Mismatch, advance by greater of delta1 and delta2")
(add STARTOFFSET (IDIFFERENCE (SETQ INC (IMAX (GETBASEBYTE DELTA1 CHAR)
(GETBASEBYTE DELTA2
CURPATINDEX)))
(IDIFFERENCE MAXPATINDEX CURPATINDEX)))
(OR (EQ INC 1)
(\INCFILEPTR STREAM (SUB1 INC)))
(GO FIRSTCHARLP)))
(SETQ CURPATINDEX (SUB1 CURPATINDEX))
(GO MATCHLP)
FOUNDIT
(* ;
 "set fileptr, adjust for beginning skips and return proper value.")
(\INCFILEPTR STREAM (COND
(TAIL (* ; "Put fileptr at end of string")
(SUB1 PATLEN))
(T (* ;
 "back up over the last char we looked at, i.e. the first char of string")
-1)))
(RETURN (\GETFILEPTR STREAM))
FAILED
(* ;
 "return the fileptr to its initial position.")
(\SETFILEPTR STREAM ORGFILEPTR)
(RETURN NIL]
TRYFILEPOS
(RETURN (FILEPOS PATTERN STREAM START END SKIP TAIL CASEARRAY])
)
(FILESLOAD FPTESTS)
(ADDTOVAR DIRECTORIES {WMEDLEY}<internal>test>filepos>)
(* ;; "Compiling also requires EXPORTS.ALL")
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
IOCHAR)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (759 6571 (TFP 769 . 2219) (TFP1 2221 . 4656) (FPC 4658 . 5619) (FPCS 5621 . 6569)) (
6572 27191 (OLDFILEPOS 6582 . 16284) (OLDFFILEPOS 16286 . 27189)))))
STOP

BIN
internal/test/filepos/TFP.LCOM
View File

Binary file not shown.

1
internal/test/filepos/ZEROONETWO.XCCS
View File

@@ -1 +0,0 @@
012

1
internal/test/printing/BADFILES.TEST
View File

@@ -1 +0,0 @@
(HCFILES "{DSK}<home>larry>ilisp>envos>" "{DSK}<home>larry>medley>tmp>psfiles>")

66
internal/test/printing/BADFILES.TXT
View File

@@ -1,66 +0,0 @@
{DSK}<home>larry>ilisp>envos>xd0e>DOC>PUBS>admin>doc-dirs>ERIS-DOC-WO-LOOPS.TEDIT;2
{DSK}<home>larry>ilisp>envos>xd0e>DOC>medley1.2>RS6000>keybaord-layout.tedit;3
{DSK}<home>larry>ilisp>envos>xd0e>DOC>medley2.0>final>ug>APP-D-DIFFERENCES.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>DOC>printers>recommendation.tedit;3
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>1982BUGS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>BRIEFINGBLURB-DRAFT.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>CHAT-GENERIC.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>HELLO.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>IDDESCRIPTION.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>LISPARFIELDS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>NSCHARACTERS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>SOURCEFILES.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>library>COLOROBJ.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>library>DSKTEST.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>notecards>library>BOONE-V-COE.TED;1
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>notecards>library>NCPLOTCARD.TED;1
{DSK}<home>larry>ilisp>envos>xd0e>MISC>test>GC>HAND-AUX>ADVDICT-N-Z.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>MISC>test>Library>TEdit>Hand-Aux>AR10063.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>MISC>test>i>o>Hardcopy>Hand>testfiles>04PARA.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>OTHER>lafite>Doc>LAFITEDELTA.TED;1
{DSK}<home>larry>ilisp>envos>xd0e>OTHER>lafite>Doc>LAFITEIMPL.TED;1
{DSK}<home>larry>ilisp>envos>xd0e>OTHER>lafite>Doc>Manual>LAFITEMANUAL-INDEXINTERNAL.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>lispusers>2.0>src>EQUATIONEXAMPLES.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>1.2>doc>03-SOFTWARE-INSTALLATION.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>1.2>doc>05-NOTECARDS-BASICS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>1.2>doc>11-SYSTEM-CARDS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>2.0>src>library>BOONE-V-COE.TED;1
{DSK}<home>larry>ilisp>envos>xd1d>users>nilsson>intercalc>inter-calc>INTERCALCDEMO.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>nilsson>intercalc>inter-calc>INTERCALCDOCUMENTATION.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>JELLINEK>graphics>DDLCOLORHAX.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>JELLINEK>graphics>LUCASFILMFORMAT.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>basics>INVOICE.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>genis>FLYER-COV-CHOICE.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>genis>FLYER-COV.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>inter-calc>INTERCALCDEMO.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>inter-calc>INTERCALCDOCUMENTATION.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>ADVERTS>Cherry-RidgeWFH.TEdit;5
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Adv-Committee>Defns>ADVDEFNS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Board>CALLERLAB-BYLAWCHANGE.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Challenge-Committee>C1-NEW-DEFNS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Challenge-Committee>C1DEFNS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Challenge-Committee>C2DEFNS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>NUMBERART.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>ADVDICT-A-M.TEDIT;13
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>ADVDICT-N-Z.TEDIT;9
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C1DEFNS-I-R.TEDIT;9
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C1DEFNS-S.TEDIT;7
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C1DEFNS-T-Z.TEDIT;9
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-A-E.TEDIT;11
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-F-O.TEDIT;5
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-P-S.TEDIT;6
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-T-Z.TEDIT;6
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>DICT-PREFACE.TEDIT;14
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>leftover-calls.tedit;3
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>FRA>ARRANGEMENTS.TEDIT;28
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>venue>ads>aaai>top-rapid-dev.TEdit;4
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>24-STREAMS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>25-IO.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>27-GRAPHICS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>28-WINDOWS.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>29-HARDCOPY.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>30-ETHERNET.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>30-TERMINAL.TEDIT;1
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>31-ETHERNET.TEDIT;1
{DSK}<home>larry>medley>lispusers>ACE>ACE-MAINTAINERS-NOTES.TEDIT;1
{DSK}<home>larry>medley>lispusers>EQUATIONEXAMPLES.TEDIT;1

546
internal/test/unpackfilename/TESTUPF
View File

@@ -1,546 +0,0 @@
(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
internal/test/unpackfilename/TESTUPF.LCOM
View File

Binary file not shown.

23
internal/test/unpackfilename/TESTUPF.TXT
View File

@@ -1,23 +0,0 @@
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.)