github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-13 23:47:27 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #651 from Interlisp/rmk17

Browse Source 
Rmk17:  Minor tweaks to sources
This commit is contained in:
Larry Masinter 2022-01-27 10:36:15 -08:00 committed by GitHub
commit f8e4bbd7cb
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
22 changed files with 1462 additions and 1051 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

434
sources/ADIR
View File

@ -1,10 +1,11 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "13-Jun-2021 11:25:58" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ADIR.;9 65815
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
changes to%: (FNS OPENSTREAM)
(FILECREATED "25-Jan-2022 17:19:00" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;11 65609
previous date%: "21-Mar-2021 21:59:07"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ADIR.;8)
:CHANGES-TO (FNS UNPACKFILENAME.STRING)
:PREVIOUS-DATE " 5-Jan-2022 11:06:37"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;10)
(* ; "
@ -14,14 +15,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(PRETTYCOMPRINT ADIRCOMS)
(RPAQQ ADIRCOMS
[[COMS (* ; "user-level i/o routines")
[[COMS (* ; "user-level i/o routines")
(FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP
RENAMEFILE SIMPLE.FINDFILE VMEMSIZE \COPYSYS \FLUSHVM \LOGOUT0)
(CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
(P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T))
(DECLARE%: DONTEVAL@LOAD DOCOPY (P
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
(MOVD? 'NILL 'CL:PATHNAMEP]
(COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP
@ -30,8 +31,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
PACKFILENAME.ASSEMBLE UNPACKFILE1))
(VARS \FILENAME.SYNTAX)
(GLOBALVARS \FILENAME.SYNTAX))
(COMS (* ;
 "saving and restoring system state")
(COMS (* ; "saving and restoring system state")
(FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT)
(ADDVARS (AROUNDEXITFNS))
(INITVARS (HERALDSTRING "")
@ -274,7 +274,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(DECLARE%: DONTEVAL@LOAD DOCOPY
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
(MOVD? 'NILL 'CL:PATHNAMEP)
@ -286,10 +286,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])
(UNPACKFILENAME.STRING
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm")
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 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)
@ -302,7 +306,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
((TYPEP FILE 'PATHNAME)
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
[(STREAMP FILE) (* ;
 "For streams, use full name. If anonymous, fake it")
 "For streams, use full name. If anonymous, fake it")
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
(RETURN (COND
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
@ -316,12 +320,12 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
FILE 2)
0))))
(%[ (* ;
 "some Xerox and Arpanet systems use '[' for host")
 "some Xerox and Arpanet systems use '[' for host")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
FILE 2)
0))))
(%( (* ;
 "this is the 'proposed standard' for Xerox servers")
 "this is the 'proposed standard' for Xerox servers")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
FILE 2)
0))))
@ -329,21 +333,26 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(UNPACKFILE1 'HOST 2 TEM)
[COND
((EQ TEM -1) (* ;
 "Started with the host field delimiter, but there was no corresponding terminating delimiter .")
 "Started with the host field delimiter, but there was no corresponding terminating delimiter .")
(* ;
 "I'm not sure why the name is dealt with the host name.")
 "I'm not sure why the name is dealt with the host name.")
(RETURN (DREVERSE VAL]
(SETQ POS (IPLUS TEM 2))
[if (EQ OSTYPE T)
then (* ;
 "Use actual host to determine os type")
(SETQ OSTYPE (GETHOSTINFO (CAR VAL)
'OSTYPE]
then (* ;
 "Use actual host to determine os type")
(SETQ OSTYPE (GETHOSTINFO (CAR VAL)
'OSTYPE]
(SETQ HOSTP T)))
(* ;; "rmk: if there is a colon before the next < or /, then we must be looking at a device. A device appears to end after the last colon, i.e., a device name can have a colon inside it.")
(COND
((SETQ TEM (LASTCHPOS (CHARCODE %:)
FILE POS)) (* ;
 "all device returned have DEVICE.END on it so that NIL: will work")
((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /))
FILE POS))
(EQ (CHARCODE %:)
(NTHCHARCODE FILE TEM))) (* ;
 "all device returned have DEVICE.END on it so that NIL: will work")
(UNPACKFILE1 'DEVICE POS (if CLFLG
then (SUB1 TEM)
else TEM))
@ -356,7 +365,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(NIL (* ; "just host, return")
(RETURN (DREVERSE VAL)))
((/ <) (* ;
 "Started with the initial directory delimiter.")
 "Started with the initial directory delimiter.")
(ADD1 POS))
POS))
END)
@ -364,7 +373,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
((/ >)
[COND
((EQ START POS) (* ;
 "Didn't start with a directory delimiter,")
 "Didn't start with a directory delimiter,")
(COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
(SETQ TYPE 'SUBDIRECTORY))
@ -372,13 +381,13 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(SETQ TYPE 'RELATIVEDIRECTORY]
(COND
((EQ LEN POS) (* ;
 "Only the initial directory is specified (i.e. %"{DSK}/%").")
 "Only the initial directory is specified (i.e. %"{DSK}/%").")
(SETQ START POS)
-1)
(T -2)))
(PROGN [COND
[(EQ START POS) (* ;
 "Both of the initial and trail delimiters are omitted.")
 "Both of the initial and trail delimiters are omitted.")
(COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
(SETQ TYPE 'SUBDIRECTORY))
@ -387,24 +396,24 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(T (COND
((EQ LEN POS)
(* ;
 "Only the initial directory is specified (i.e. %"{DSK}<%").")
 "Only the initial directory is specified (i.e. %"{DSK}<%").")
(SETQ START POS]
-1)))
(UNPACKFILE1.DIRECTORY TYPE START END))
(RETURN (DREVERSE VAL)))
((SELCHARQ (NTHCHARCODE FILE POS)
(/ (* ;
 "unix and the 'xerox standard' use / for delimiter")
 "unix and the 'xerox standard' use / for delimiter")
(* ;
 "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
 "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
(SETQ TEM (LASTCHPOS (CHARCODE (/ >))
FILE
(ADD1 POS)))
T)
((< >) (* ;
 "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
 "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
(* ;
 "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
 "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
FILE
(ADD1 POS)))
@ -415,20 +424,19 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(if TEM
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
(SUB1 TEM))
(SETQ POS (ADD1 TEM))
(SUB1 TEM))
(SETQ POS (ADD1 TEM))
else
(* ;; "{DSK}/foo: the directory is /, the name is foo")
(* ;; "{DSK}/foo: the directory is /, the name is foo")
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
(SETQ POS (ADD1 POS)))
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
(SETQ POS (ADD1 POS)))
(SETQ HOSTP T))
((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
FILE POS)) (* ; " {eris}abc> relative")
(* ;;
 " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
 " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
[COND
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
@ -448,9 +456,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (DREVERSE VAL)))
(if (EQ OSTYPE T)
then (* ;
 "There wasn't a host field in the name, so we have no clue")
(SETQ OSTYPE NIL))
then (* ;
 "There wasn't a host field in the name, so we have no clue")
(SETQ OSTYPE NIL))
NAMELP
@ -458,61 +466,61 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(SELCHARQ CODE
(%. (* ;
 "Note position for later--we only want to deal with the last set of dots")
 "Note position for later--we only want to deal with the last set of dots")
(if BEYONDNAME
then (* ;
 "no longer of interest (probably a bad name, too)")
then (* ;
 "no longer of interest (probably a bad name, too)")
elseif FIRSTDOT
then (* ; "We're recording the second dot")
(if SECONDDOT
then (* ;
 "Note only the two most recent dots")
(SETQ FIRSTDOT SECONDDOT))
(SETQ SECONDDOT TEM)
then (* ; "We're recording the second dot")
(if SECONDDOT
then (* ;
 "Note only the two most recent dots")
(SETQ FIRSTDOT SECONDDOT))
(SETQ SECONDDOT TEM)
else (SETQ FIRSTDOT TEM)))
((! ; NIL) (* ;
 "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
 "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
(if (SELCHARQ CODE
(! (* ;
 "! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
(AND OSTYPE (NEQ OSTYPE 'IFS)))
(; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S")
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
NIL)
(! (* ;
 "! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
(AND OSTYPE (NEQ OSTYPE 'IFS)))
(; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S")
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
NIL)
then (GO NEXTCHAR))
(if FIRSTDOT
then (* ;
 "Have a name and/or extension to parse now")
then (* ;
 "Have a name and/or extension to parse now")
(if
[AND SECONDDOT
(NOT (if OSTYPE
then (* ;
 "Known OS type must be Tops20 for second dot to mean version")
(EQ OSTYPE 'TOPS20)
else (* ;
 "Unknown OS type, so check that %"version%" is numeric or wildcard")
(AND [for I from (ADD1 SECONDDOT)
to (SUB1 TEM) bind CH
always (OR (DIGITCHARP (SETQ CH
(NTHCHARCODE FILE I)))
(EQ CH (CHARCODE *]
(SELCHARQ CODE
(NIL (* ; "end of file name, ok")
T)
(; (* ;
 "This semi-colon better not be introducing a version")
(\UPF.TEMPFILEP FILE (ADD1 TEM)))
NIL]
then (* ;
 "Second dot is not intoducing a version")
(SETQ FIRSTDOT SECONDDOT)
(SETQ SECONDDOT NIL))
then (* ;
 "Known OS type must be Tops20 for second dot to mean version")
(EQ OSTYPE 'TOPS20)
else (* ;
 "Unknown OS type, so check that %"version%" is numeric or wildcard")
(AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM)
bind CH
always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I
)))
(EQ CH (CHARCODE *]
(SELCHARQ CODE
(NIL (* ; "end of file name, ok")
T)
(; (* ;
 "This semi-colon better not be introducing a version")
(\UPF.TEMPFILEP FILE (ADD1 TEM)))
NIL]
then (* ;
 "Second dot is not intoducing a version")
(SETQ FIRSTDOT SECONDDOT)
(SETQ SECONDDOT NIL))
(UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
(SETQ POS (ADD1 (if SECONDDOT
then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
(SUB1 SECONDDOT))
(SETQ BEYONDEXT T)
SECONDDOT
(SUB1 SECONDDOT))
(SETQ BEYONDEXT T)
SECONDDOT
else FIRSTDOT)))
(SETQ BEYONDNAME T)
(SETQ FIRSTDOT NIL))
@ -524,15 +532,15 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
((AND (EQ BEYONDEXT (CHARCODE ";"))
(\UPF.TEMPFILEP FILE POS)))
(T (* ;
 "Everything after the semi was version")
 "Everything after the semi was version")
'VERSION))
POS
(SUB1 TEM))
(if (NULL CODE)
then (* ; "End of string")
(RETURN (DREVERSE VAL)))
then (* ; "End of string")
(RETURN (DREVERSE VAL)))
(SETQ BEYONDEXT CODE) (* ;
 "Note the character that terminated the name/ext")
 "Note the character that terminated the name/ext")
(SETQ POS (ADD1 TEM)))
(%' (* ; "Quoter")
(add TEM 1))
@ -623,80 +631,74 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(DSTPOS 0)
(NEXTPOS -1))
(if (NOT FATP)
then
[for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >)))
do (add SRCPOS 1))
(if (> SRCPOS LEN)
then (RETURN "<"))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
then [for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
(if (> SRCPOS LEN)
then (RETURN "<"))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
(SETQ NEXTPOS (add DSTPOS 1))))
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASETHIN DSTBASE DSTPOS
(NTHCHARCODE SRCSTRING (add SRCPOS
1)))
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASETHIN DSTBASE DSTPOS
(NTHCHARCODE SRCSTRING (add SRCPOS 1)))
(add DSTPOS 1)))
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS]
else
(for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS]
else (for SRCPOS from 1 to LEN bind CODE
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
(CHARCODE (< / >))) do (add SRCPOS 1))
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
((> /)
(if (> DSTPOS NEXTPOS)
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
(SETQ NEXTPOS (add DSTPOS 1))))
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASEFAT DSTBASE DSTPOS
(NTHCHARCODE SRCSTRING (add SRCPOS 1)
))
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)
(if (NEQ SRCPOS LEN)
then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE
SRCSTRING
(add SRCPOS 1)))
(add DSTPOS 1)))
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS])
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
(add DSTPOS 1)))
finally (RETURN (if (EQ DSTPOS LEN)
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 -2)
else DSTSTRING)
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
(CHARCODE (> /)))
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
else (SUBSTRING DSTSTRING 1 DSTPOS])
(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
(LET* ((OLDDIR (SUBSTRING FILE ST END))
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL
(CONS (COND
(PACKFLG (AND NEWDIR (MKATOM
NEWDIR)))
(T (OR NEWDIR "")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(LET* ((OLDDIR (SUBSTRING FILE ST END))
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND
(PACKFLG (AND NEWDIR
(MKATOM NEWDIR)))
(T (OR NEWDIR ""])
(T (OR NEWDIR "")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
(T (OR NEWDIR ""])
(PUTPROPS PACKFILENAME.ASSEMBLE MACRO
[NIL
@ -705,11 +707,11 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION
VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION
VERSION TEMPORARY PROTECTION ACCOUNT))
VERSION TEMPORARY PROTECTION ACCOUNT))
LP (COND
((<= I N)
(* ;; "Grab the next field-name / value pair and fold it into the filename:")
(* ;; "Grab the next field-name / value pair and fold it into the filename:")
(COND
((LISTP (SETQ VAR (ARG N I)))
@ -725,9 +727,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(\ILLEGAL.ARG VAL))
(SELECTQ VAR
(BODY (MAP (UNPACKFILENAME.STRING (COND
((LISTP VAL)
(PACKFILENAME.STRING VAL))
(T VAL))
((LISTP VAL)
(PACKFILENAME.STRING VAL))
(T VAL))
NIL
'OK)
[FUNCTION (LAMBDA (X)
@ -781,52 +783,49 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
((PATHNAME DIRECTORY)
[COND
(VAL
(for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL
'RETURN))
(for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL 'RETURN))
by (CDDR X)
do (SELECTQ (CAR X)
(HOST [COND
((NOT HOST)
(SETQ HOST (OR (CADR X)
(HOST [COND
((NOT HOST)
(SETQ HOST (OR (CADR X)
BLIP])
(DEVICE [COND
((NOT DEVICE)
(SETQ DEVICE (OR (CADR X)
BLIP])
(DEVICE [COND
((NOT DEVICE)
(SETQ DEVICE (OR (CADR X)
BLIP])
(SUBDIRECTORY [OR DIRECTORY
(COND
(RELATIVEDIRECTORY (SETQ
DIRECTORY
BLIP))
(T (SETQ DIRECTORY
(OR (CADR X)
BLIP])
(RELATIVEDIRECTORY
(SUBDIRECTORY [OR DIRECTORY
(COND
(RELATIVEDIRECTORY (SETQ DIRECTORY
BLIP))
(T (SETQ DIRECTORY
(OR (CADR X)
BLIP])
(RELATIVEDIRECTORY
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
(OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
(OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
(OR (CADR X)
BLIP))))
(DIRECTORY [OR DIRECTORY (COND
(RELATIVEDIRECTORY
(SETQ DIRECTORY BLIP))
(T (SETQ DIRECTORY
(OR (CADR X)
BLIP))))
(DIRECTORY [OR DIRECTORY
(COND
(RELATIVEDIRECTORY (SETQ DIRECTORY
BLIP))
(T (SETQ DIRECTORY
(OR (CADR X)
BLIP])
(ERROR "Illegal field in DIRECTORY slot" VAL)))
BLIP])
(ERROR "Illegal field in DIRECTORY slot" VAL)))
(for X on VAL by (CDDR X)
do (SELECTQ (CAR X)
(HOST (OR DEVICE (SETQ DEVICE BLIP))
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
NIL)))
(HOST (OR DEVICE (SETQ DEVICE BLIP))
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
NIL)))
(T (OR DIRECTORY (SETQ DIRECTORY BLIP])
(SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP))))
(RELATIVEDIRECTORY
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
(OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP))))
(DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP))))
@ -868,9 +867,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
[COND
(DIRECTORY (COND
[[OR (STREQUAL DIRECTORY "<")
(AND (SETQ TEMP (LASTCHPOS
(CHARCODE (> /))
DIRECTORY 1))
(AND (SETQ TEMP (LASTCHPOS (CHARCODE
(> /))
DIRECTORY 1))
(EQ TEMP (NCHARS DIRECTORY]
(COND
((EQMEMB (NTHCHARCODE DIRECTORY 1)
@ -913,20 +912,19 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(SUBSTRING VERSION 2 -1))
VERSION])
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END)
(* lmm "22-APR-81 22:21")
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND
(PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
"")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
(COND
[(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND
(PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
""])
"")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND
(PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
""])
)
)
@ -1158,14 +1156,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
(PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
1991 1992 1920 2017 2020 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2733 13858 (DELFILE 2743 . 2904) (FULLNAME 2906 . 3273) (INFILE 3275 . 3423) (INFILEP
3425 . 3560) (IOFILE 3562 . 3702) (OPENFILE 3704 . 4104) (OPENSTREAM 4106 . 8446) (OUTFILE 8448 . 8599
) (OUTFILEP 8601 . 8737) (RENAMEFILE 8739 . 9045) (SIMPLE.FINDFILE 9047 . 9457) (VMEMSIZE 9459 . 9626)
(\COPYSYS 9628 . 12577) (\FLUSHVM 12579 . 13651) (\LOGOUT0 13653 . 13856)) (14230 33821 (
UNPACKFILENAME 14240 . 14426) (UNPACKFILENAME.STRING 14428 . 30700) (LASTCHPOS 30702 . 31396) (
\UPF.NEXTPOS 31398 . 32043) (\UPF.TEMPFILEP 32045 . 32622) (FILENAMEFIELD 32624 . 33109) (PACKFILENAME
33111 . 33454) (PACKFILENAME.STRING 33456 . 33819)) (56262 63442 (LOGOUT 56272 . 57189) (MAKESYS
57191 . 58820) (SYSOUT 58822 . 60374) (SAVEVM 60376 . 61176) (HERALD 61178 . 61338) (INTERPRET.REM.CM
61340 . 63065) (\USEREVENT 63067 . 63440)) (63624 65351 (USERNAME 63634 . 64590) (SETUSERNAME 64592 .
65349)))))
(FILEMAP (NIL (2687 13812 (DELFILE 2697 . 2858) (FULLNAME 2860 . 3227) (INFILE 3229 . 3377) (INFILEP
3379 . 3514) (IOFILE 3516 . 3656) (OPENFILE 3658 . 4058) (OPENSTREAM 4060 . 8400) (OUTFILE 8402 . 8553
) (OUTFILEP 8555 . 8691) (RENAMEFILE 8693 . 8999) (SIMPLE.FINDFILE 9001 . 9411) (VMEMSIZE 9413 . 9580)
(\COPYSYS 9582 . 12531) (\FLUSHVM 12533 . 13605) (\LOGOUT0 13607 . 13810)) (14184 34416 (
UNPACKFILENAME 14194 . 14380) (UNPACKFILENAME.STRING 14382 . 31295) (LASTCHPOS 31297 . 31991) (
\UPF.NEXTPOS 31993 . 32638) (\UPF.TEMPFILEP 32640 . 33217) (FILENAMEFIELD 33219 . 33704) (PACKFILENAME
33706 . 34049) (PACKFILENAME.STRING 34051 . 34414)) (56056 63236 (LOGOUT 56066 . 56983) (MAKESYS
56985 . 58614) (SYSOUT 58616 . 60168) (SAVEVM 60170 . 60970) (HERALD 60972 . 61132) (INTERPRET.REM.CM
61134 . 62859) (\USEREVENT 62861 . 63234)) (63418 65145 (USERNAME 63428 . 64384) (SETUSERNAME 64386 .
65143)))))
STOP

BIN
sources/ADIR.LCOM
View File

Binary file not shown.

99
sources/CLSTREAMS
View File

@ -1,10 +1,10 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "27-Nov-2021 13:30:46" 
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3| 53235
(FILECREATED "20-Jan-2022 09:16:52" 
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;4| 53233
|previous| |date:| " 3-Apr-91 15:11:53"
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;2|)
:PREVIOUS-DATE "27-Nov-2021 13:30:46"
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3|)
; Copyright (c) 1985-1988, 1990-1991 by Venue & Xerox Corporation.
@ -955,48 +955,51 @@
(PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE)
(PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (5167 14142 (OPEN 5167 . 14142)) (14144 15070 (CL:CLOSE 14144 . 15070)) (15072 15150 (
CL:STREAM-EXTERNAL-FORMAT 15072 . 15150)) (15152 15219 (CL:STREAM-ELEMENT-TYPE 15152 . 15219)) (15221
15455 (CL:INPUT-STREAM-P 15221 . 15455)) (15457 15693 (CL:OUTPUT-STREAM-P 15457 . 15693)) (15695 15832
(XCL:OPEN-STREAM-P 15695 . 15832)) (15834 15901 (FILE-STREAM-POSITION 15834 . 15901)) (15953 17296 (
CL:MAKE-SYNONYM-STREAM 15953 . 17296)) (17298 17387 (XCL:SYNONYM-STREAM-P 17298 . 17387)) (17389 17527
(XCL:SYNONYM-STREAM-SYMBOL 17389 . 17527)) (17529 17807 (XCL:FOLLOW-SYNONYM-STREAMS 17529 . 17807)) (
17809 18568 (CL:MAKE-BROADCAST-STREAM 17809 . 18568)) (18570 18713 (XCL:BROADCAST-STREAM-P 18570 .
18713)) (18715 18930 (XCL:BROADCAST-STREAM-STREAMS 18715 . 18930)) (18932 19617 (
CL:MAKE-CONCATENATED-STREAM 18932 . 19617)) (19619 19718 (XCL:CONCATENATED-STREAM-P 19619 . 19718)) (
19720 19933 (XCL:CONCATENATED-STREAM-STREAMS 19720 . 19933)) (19935 21519 (CL:MAKE-TWO-WAY-STREAM
19935 . 21519)) (21521 21658 (XCL:TWO-WAY-STREAM-P 21521 . 21658)) (21660 21805 (
XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21660 . 21805)) (21807 21951 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21807
. 21951)) (21953 23503 (CL:MAKE-ECHO-STREAM 21953 . 23503)) (23505 23634 (XCL:ECHO-STREAM-P 23505 .
23634)) (23636 23774 (XCL:ECHO-STREAM-INPUT-STREAM 23636 . 23774)) (23776 23915 (
XCL:ECHO-STREAM-OUTPUT-STREAM 23776 . 23915)) (23917 24644 (CL:MAKE-STRING-INPUT-STREAM 23917 . 24644)
) (24646 25139 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24646 . 25139)) (25141 25301 (
%MAKE-INITIAL-STRING-STREAM-CONTENTS 25141 . 25301)) (28348 29874 (MAKE-FILL-POINTER-OUTPUT-STREAM
28348 . 29874)) (29876 30597 (CL:GET-OUTPUT-STREAM-STRING 29876 . 30597)) (30599 31078 (
\\STRING-STREAM-OUTCHARFN 30599 . 31078)) (31080 32935 (\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31080 .
32935)) (32964 33046 (%NEW-FILE 32964 . 33046)) (33048 33193 (PREDICT-NAME 33048 . 33193)) (33434
34622 (%BROADCAST-STREAM-DEVICE-BOUT 33444 . 33667) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33669 . 34120)
(%BROADCAST-STREAM-DEVICE-CLOSEFILE 34122 . 34361) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34363 .
34620)) (34624 34951 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34624 . 34951)) (34952 37011 (
%CONCATENATED-STREAM-DEVICE-BIN 34962 . 35367) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35369 . 35682) (
%CONCATENATED-STREAM-DEVICE-EOFP 35684 . 36048) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36050 . 36525) (
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36527 . 37009)) (37013 37344 (
%CONCATENATED-STREAM-DEVICE-CHARSETFN 37013 . 37344)) (37345 37564 (%ECHO-STREAM-DEVICE-BIN 37355 .
37562)) (37566 37791 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37566 . 37791)) (37792 41137 (
%SYNONYM-STREAM-DEVICE-BIN 37802 . 37990) (%SYNONYM-STREAM-DEVICE-BOUT 37992 . 38193) (
%SYNONYM-STREAM-DEVICE-OUTCHARFN 38195 . 38902) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38904 . 39488) (
%SYNONYM-STREAM-DEVICE-EOFP 39490 . 39681) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39683 . 39921) (
%SYNONYM-STREAM-DEVICE-GETFILEINFO 39923 . 40160) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40162 . 40385) (
%SYNONYM-STREAM-DEVICE-READP 40387 . 40498) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40500 . 40646) (
%SYNONYM-STREAM-DEVICE-SETFILEINFO 40648 . 40897) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40899 . 41135)) (
41138 45463 (%TWO-WAY-STREAM-DEVICE-BIN 41148 . 41321) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41323 .
41514) (%TWO-WAY-STREAM-DEVICE-BOUT 41516 . 41688) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41690 . 41880)
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41882 . 42744) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42746 . 44169) (
%TWO-WAY-STREAM-DEVICE-EOFP 44171 . 44347) (%TWO-WAY-STREAM-DEVICE-READP 44349 . 44542) (
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44544 . 44680) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44682 . 44911) (
%TWO-WAY-STREAM-DEVICE-PEEKBIN 44913 . 45126) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45128 . 45461)) (45465
45690 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45465 . 45690)) (45692 45811 (
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45692 . 45811)) (46051 46290 (%SYNONYM-STREAM-DEVICE-GET-STREAM
46061 . 46288)) (46521 46997 (%INITIALIZE-STANDARD-STREAMS 46521 . 46997)) (46998 52961 (
%INITIALIZE-CLSTREAM-TYPES 47008 . 52959)))))
(FILEMAP (NIL (5165 14140 (OPEN 5165 . 14140)) (14142 15068 (CL:CLOSE 14142 . 15068)) (15070 15148 (
CL:STREAM-EXTERNAL-FORMAT 15070 . 15148)) (15150 15217 (CL:STREAM-ELEMENT-TYPE 15150 . 15217)) (15219
15453 (CL:INPUT-STREAM-P 15219 . 15453)) (15455 15691 (CL:OUTPUT-STREAM-P 15455 . 15691)) (15693 15830
(XCL:OPEN-STREAM-P 15693 . 15830)) (15832 15899 (FILE-STREAM-POSITION 15832 . 15899)) (15951 17294 (
CL:MAKE-SYNONYM-STREAM 15951 . 17294)) (17296 17385 (XCL:SYNONYM-STREAM-P 17296 . 17385)) (17387 17525
(XCL:SYNONYM-STREAM-SYMBOL 17387 . 17525)) (17527 17805 (XCL:FOLLOW-SYNONYM-STREAMS 17527 . 17805)) (
17807 18566 (CL:MAKE-BROADCAST-STREAM 17807 . 18566)) (18568 18711 (XCL:BROADCAST-STREAM-P 18568 .
18711)) (18713 18928 (XCL:BROADCAST-STREAM-STREAMS 18713 . 18928)) (18930 19615 (
CL:MAKE-CONCATENATED-STREAM 18930 . 19615)) (19617 19716 (XCL:CONCATENATED-STREAM-P 19617 . 19716)) (
19718 19931 (XCL:CONCATENATED-STREAM-STREAMS 19718 . 19931)) (19933 21517 (CL:MAKE-TWO-WAY-STREAM
19933 . 21517)) (21519 21656 (XCL:TWO-WAY-STREAM-P 21519 . 21656)) (21658 21803 (
XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21658 . 21803)) (21805 21949 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21805
. 21949)) (21951 23501 (CL:MAKE-ECHO-STREAM 21951 . 23501)) (23503 23632 (XCL:ECHO-STREAM-P 23503 .
23632)) (23634 23772 (XCL:ECHO-STREAM-INPUT-STREAM 23634 . 23772)) (23774 23913 (
XCL:ECHO-STREAM-OUTPUT-STREAM 23774 . 23913)) (23915 24642 (CL:MAKE-STRING-INPUT-STREAM 23915 . 24642)
) (24644 25137 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24644 . 25137)) (25139 25299 (
%MAKE-INITIAL-STRING-STREAM-CONTENTS 25139 . 25299)) (25301 25731 (CL:WITH-OPEN-STREAM 25301 . 25731))
(25733 26962 (CL:WITH-INPUT-FROM-STRING 25733 . 26962)) (26964 27466 (CL:WITH-OUTPUT-TO-STRING 26964
. 27466)) (27468 28122 (CL:WITH-OPEN-FILE 27468 . 28122)) (28346 29872 (
MAKE-FILL-POINTER-OUTPUT-STREAM 28346 . 29872)) (29874 30595 (CL:GET-OUTPUT-STREAM-STRING 29874 .
30595)) (30597 31076 (\\STRING-STREAM-OUTCHARFN 30597 . 31076)) (31078 32933 (
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31078 . 32933)) (32962 33044 (%NEW-FILE 32962 . 33044)) (33046
33191 (PREDICT-NAME 33046 . 33191)) (33227 33378 (INTERLISP-ACCESS 33227 . 33378)) (33432 34620 (
%BROADCAST-STREAM-DEVICE-BOUT 33442 . 33665) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33667 . 34118) (
%BROADCAST-STREAM-DEVICE-CLOSEFILE 34120 . 34359) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34361 . 34618)
) (34622 34949 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34622 . 34949)) (34950 37009 (
%CONCATENATED-STREAM-DEVICE-BIN 34960 . 35365) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35367 . 35680) (
%CONCATENATED-STREAM-DEVICE-EOFP 35682 . 36046) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36048 . 36523) (
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36525 . 37007)) (37011 37342 (
%CONCATENATED-STREAM-DEVICE-CHARSETFN 37011 . 37342)) (37343 37562 (%ECHO-STREAM-DEVICE-BIN 37353 .
37560)) (37564 37789 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37564 . 37789)) (37790 41135 (
%SYNONYM-STREAM-DEVICE-BIN 37800 . 37988) (%SYNONYM-STREAM-DEVICE-BOUT 37990 . 38191) (
%SYNONYM-STREAM-DEVICE-OUTCHARFN 38193 . 38900) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38902 . 39486) (
%SYNONYM-STREAM-DEVICE-EOFP 39488 . 39679) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39681 . 39919) (
%SYNONYM-STREAM-DEVICE-GETFILEINFO 39921 . 40158) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40160 . 40383) (
%SYNONYM-STREAM-DEVICE-READP 40385 . 40496) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40498 . 40644) (
%SYNONYM-STREAM-DEVICE-SETFILEINFO 40646 . 40895) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40897 . 41133)) (
41136 45461 (%TWO-WAY-STREAM-DEVICE-BIN 41146 . 41319) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41321 .
41512) (%TWO-WAY-STREAM-DEVICE-BOUT 41514 . 41686) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41688 . 41878)
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41880 . 42742) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42744 . 44167) (
%TWO-WAY-STREAM-DEVICE-EOFP 44169 . 44345) (%TWO-WAY-STREAM-DEVICE-READP 44347 . 44540) (
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44542 . 44678) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44680 . 44909) (
%TWO-WAY-STREAM-DEVICE-PEEKBIN 44911 . 45124) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45126 . 45459)) (45463
45688 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45463 . 45688)) (45690 45809 (
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45690 . 45809)) (46049 46288 (%SYNONYM-STREAM-DEVICE-GET-STREAM
46059 . 46286)) (46519 46995 (%INITIALIZE-STANDARD-STREAMS 46519 . 46995)) (46996 52959 (
%INITIALIZE-CLSTREAM-TYPES 47006 . 52957)))))
STOP

BIN
sources/CLSTREAMS.LCOM
View File

Binary file not shown.

142
sources/CMLFILESYS
View File

@ -1,37 +1,139 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated " 8-Jun-90 16:41:26" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;4| 4326
|changes| |to:| (functions cl:directory cl:user-homedir-pathname)
(FILECREATED "23-Jan-2022 12:32:16" 
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;4| 6055
|previous| |date:| " 4-Jun-90 14:56:58" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;3|)
:CHANGES-TO (FUNCTIONS CL:DIRECTORY)
:PREVIOUS-DATE "22-Jan-2022 09:26:49"
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;3|)
; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
; Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(prettycomprint cmlfilesyscoms)
(PRETTYCOMPRINT CMLFILESYSCOMS)
(rpaqq cmlfilesyscoms ((functions cl:directory cl:file-author cl:file-length cl:file-position cl:user-homedir-pathname cl:file-write-date) (functions cl:probe-file cl:rename-file cl:delete-file) (prop filetype cmlfilesys)))
(RPAQQ CMLFILESYSCOMS ((FUNCTIONS CL:DIRECTORY CL:FILE-AUTHOR CL:FILE-LENGTH CL:FILE-POSITION
CL:USER-HOMEDIR-PATHNAME CL:FILE-WRITE-DATE)
(FUNCTIONS CL:PROBE-FILE CL:RENAME-FILE CL:DELETE-FILE)
(PROP FILETYPE CMLFILESYS)))
(cl:defun cl:directory (pathname) (let (generator file) (declare (cl:special generator)) (resetlst (|if| (eql \\machinetype \\maiko) |then| (resetsave nil (quote (and resetstate (\\ufs.abort.cl-directory))))) (cl:setq generator (\\generatefiles (directory.fill.pattern (cl:namestring pathname)) nil (quote (sort resetlst)))) (|while| (setq file (\\generatenextfile generator)) |collect| (pathname file)))))
(CL:DEFUN CL:DIRECTORY (PATHNAME &KEY CL::DEFAULTEXT CL::DEFAULTVERS)
(* \; "Edited 23-Jan-2022 12:32 by rmk")
(* \; "Edited 22-Jan-2022 09:26 by rmk")
(LET (GENERATOR FILE)
(DECLARE (CL:SPECIAL GENERATOR))
(RESETLST
(CL:WHEN (EQL \\MACHINETYPE \\MAIKO)
(RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
(CL:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (CL:NAMESTRING PATHNAME)
CL::DEFAULTEXT CL::DEFAULTVERS)
NIL
'(SORT RESETLST)))
(|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE)))))
(cl:defun cl:file-author (cl::file) (* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.") (let ((cl::author (getfileinfo cl::file (quote author)))) (cl:if cl::author (coerce cl::author (quote cl:simple-string)) nil)))
(CL:DEFUN CL:FILE-AUTHOR (CL::FILE)
(cl:defun cl:file-length (file-stream) (|if| (and (streamp file-stream) (openp file-stream)) |then| (geteofptr file-stream)))
(* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.")
(cl:defun cl:file-position (cl::file-stream &optional (cl:position nil cl::positionp)) (cl:unless (streamp cl::file-stream) (\\illegal.arg cl::file-stream)) (cl:if cl::positionp (cl:if (randaccessp cl::file-stream) (progn (setfileptr cl::file-stream (case cl:position (:start 0) (:end (geteofptr cl::file-stream)) (t cl:position))) t) nil) (getfileptr cl::file-stream)))
(LET ((CL::AUTHOR (GETFILEINFO CL::FILE 'AUTHOR)))
(CL:IF CL::AUTHOR
(COERCE CL::AUTHOR 'CL:SIMPLE-STRING)
NIL)))
(cl:defun cl:user-homedir-pathname (&optional host) (declare (globalvars loginhost/dir *default-pathname-defaults*)) (cl:if (machinetype (quote maiko)) (cl:if (and host (cl:string-not-equal (string host) (unix-getparm "HOSTNAME"))) nil (cl:make-pathname :host :dsk :directory (unpackfilename.string (unix-getenv "HOME") (quote directory) (quote return)))) (pathname (or loginhost/dir *default-pathname-defaults*))))
(CL:DEFUN CL:FILE-LENGTH (FILE-STREAM)
(|if| (AND (STREAMP FILE-STREAM)
(OPENP FILE-STREAM))
|then| (GETEOFPTR FILE-STREAM)))
(cl:defun cl:file-write-date (file) (* |;;| "Return file's creation date, or NIL if it doesn't exist.") (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time") (let ((tn (cl:probe-file file))) (cl:when tn (%convert-internal-time-to-clut (getfileinfo tn (quote icreationdate))))))
(CL:DEFUN CL:FILE-POSITION (CL::FILE-STREAM &OPTIONAL (CL:POSITION NIL CL::POSITIONP))
(CL:UNLESS (STREAMP CL::FILE-STREAM)
(\\ILLEGAL.ARG CL::FILE-STREAM))
(CL:IF CL::POSITIONP
(CL:IF (RANDACCESSP CL::FILE-STREAM)
(PROGN (SETFILEPTR CL::FILE-STREAM (CASE CL:POSITION
(:START 0)
(:END (GETEOFPTR CL::FILE-STREAM))
(T CL:POSITION)))
T)
NIL)
(GETFILEPTR CL::FILE-STREAM)))
(cl:defun cl:probe-file (file) (* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.") (if (streamp file) then (if (openp file) then (pathname (fetch (stream fullname) of file)) else (let ((namestring-if-exists (infilep (fetch (stream fullname) of file)))) (and namestring-if-exists (pathname namestring-if-exists)))) else (let ((infilep (\\getfilename file (quote old)))) (if infilep then (pathname infilep) else nil))))
(CL:DEFUN CL:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
(DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
(CL:IF (MACHINETYPE 'MAIKO)
(CL:IF (AND HOST (CL:STRING-NOT-EQUAL (STRING HOST)
(UNIX-GETPARM "HOSTNAME")))
NIL
(CL:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME")
'DIRECTORY
'RETURN)))
(PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
(cl:defun cl:rename-file (file new-name) (* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.") (let ((old-pathname (pathname file)) (cl::new-fullname)) (if (streamp file) then (if (openp file) then (cl:error "Renaming open streams is not supported: ~S" file) else (setq cl::new-fullname (renamefile (setq file (fetch (stream fullname) of file)) new-name))) else (setq cl::new-fullname (renamefile file new-name))) (if cl::new-fullname then (cl:values (cl:merge-pathnames new-name file) old-pathname (pathname cl::new-fullname)) else (cl:error "Rename failed"))))
(CL:DEFUN CL:FILE-WRITE-DATE (FILE)
(cl:defun cl:delete-file (file) (* * "Delete the specified file.") (let ((tn (cl:probe-file file))) (cl:when (streamp file) (cl:close file :abort t)) (cl:if tn (let ((ns (interlisp-namestring tn))) (cl:unless (delfile ns) (cl:error "Could not delete the file ~S" file))) (cl:unless (streamp file) (cl:error "File to be deleted does not exist: ~S" file)))) t)
(* |;;| "Return file's creation date, or NIL if it doesn't exist.")
(putprops cmlfilesys filetype cl:compile-file)
(putprops cmlfilesys copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(declare\: dontcopy
(filemap (nil)))
stop
(* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time")
(LET ((TN (CL:PROBE-FILE FILE)))
(CL:WHEN TN
(%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE)))))
(CL:DEFUN CL:PROBE-FILE (FILE)
(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.")
(IF (STREAMP FILE)
THEN (IF (OPENP FILE)
THEN (PATHNAME (FETCH (STREAM FULLNAME) OF FILE))
ELSE (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH (STREAM FULLNAME) OF FILE))))
(AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS))))
ELSE (LET ((INFILEP (\\GETFILENAME FILE 'OLD)))
(IF INFILEP
THEN (PATHNAME INFILEP)
ELSE NIL))))
(CL:DEFUN CL:RENAME-FILE (FILE NEW-NAME)
(* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.")
(LET ((OLD-PATHNAME (PATHNAME FILE))
(CL::NEW-FULLNAME))
(IF (STREAMP FILE)
THEN (IF (OPENP FILE)
THEN (CL:ERROR "Renaming open streams is not supported: ~S" FILE)
ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE (SETQ FILE (FETCH (STREAM FULLNAME)
OF FILE))
NEW-NAME)))
ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE FILE NEW-NAME)))
(IF CL::NEW-FULLNAME
THEN (CL:VALUES (CL:MERGE-PATHNAMES NEW-NAME FILE)
OLD-PATHNAME
(PATHNAME CL::NEW-FULLNAME))
ELSE (CL:ERROR "Rename failed"))))
(CL:DEFUN CL:DELETE-FILE (FILE)
(* * "Delete the specified file.")
(LET ((TN (CL:PROBE-FILE FILE)))
(CL:WHEN (STREAMP FILE)
(CL:CLOSE FILE :ABORT T))
(CL:IF TN
(LET ((NS (INTERLISP-NAMESTRING TN)))
(CL:UNLESS (DELFILE NS)
(CL:ERROR "Could not delete the file ~S" FILE)))
(CL:UNLESS (STREAMP FILE)
(CL:ERROR "File to be deleted does not exist: ~S" FILE))))
T)
(PUTPROPS CMLFILESYS FILETYPE CL:COMPILE-FILE)
(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (751 1642 (CL:DIRECTORY 751 . 1642)) (1644 1950 (CL:FILE-AUTHOR 1644 . 1950)) (1952 2113
(CL:FILE-LENGTH 1952 . 2113)) (2115 2709 (CL:FILE-POSITION 2115 . 2709)) (2711 3302 (
CL:USER-HOMEDIR-PATHNAME 2711 . 3302)) (3304 3662 (CL:FILE-WRITE-DATE 3304 . 3662)) (3664 4329 (
CL:PROBE-FILE 3664 . 4329)) (4331 5387 (CL:RENAME-FILE 4331 . 5387)) (5389 5894 (CL:DELETE-FILE 5389
. 5894)))))
STOP

BIN
sources/CMLFILESYS.LCOM
View File

Binary file not shown.

256
sources/CMLPATHNAME
View File

@ -1,13 +1,14 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Sep-90 15:14:19" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPATHNAME.;9| 42057
changes to%: (FNS CL:MAKE-PATHNAME)
(FILECREATED "14-Jan-2022 11:40:58" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2 41496
previous date%: "22-Aug-90 19:16:14" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPATHNAME.;8|)
:PREVIOUS-DATE "28-Sep-90 15:14:19"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;1)
(* ; "
Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT CMLPATHNAMECOMS)
@ -38,11 +39,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING))
(FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES
PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
CL:ENOUGH-NAMESTRING
CL:MERGE-PATHNAMES
CL:MAKE-PATHNAME])
@ -68,20 +70,20 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL)
`[if (NOT ,ONEFIELDFLG)
then [SETQ ,VAL (CONS (COND
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
(T (OR (SUBSTRING ,FILE ,ST ,END)
"")))
(CONS ,NAM ,VAL]
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
(T (OR (SUBSTRING ,FILE ,ST ,END)
"")))
(CONS ,NAM ,VAL]
elseif (EQMEMB ,NAM ,ONEFIELDFLG)
then (RETURN (COND
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
(T (OR (SUBSTRING ,FILE ,ST ,END)
""])
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
(T (OR (SUBSTRING ,FILE ,ST ,END)
""])
(CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-)
(:PRINT-FUNCTION %%PRINT-PATHNAME)
(:CONSTRUCTOR %%%%MAKE-PATHNAME)
(:PREDICATE CL:PATHNAMEP))
(:PRINT-FUNCTION %%PRINT-PATHNAME)
(:CONSTRUCTOR %%%%MAKE-PATHNAME)
(:PREDICATE CL:PATHNAMEP))
HOST
DEVICE
DIRECTORY
@ -90,9 +92,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
VERSION)
(CL:DEFSTRUCT (DIRECTORY-COMPONENT (:CONC-NAME %%DIRECTORY-COMPONENT-)
(:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT)
(:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT)
(:PREDICATE %%DIRECTORY-COMPONENT-P))
(:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT)
(:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT)
(:PREDICATE %%DIRECTORY-COMPONENT-P))
TYPE
PATH)
(DEFINEQ
@ -252,9 +254,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(* ;;; "Returns the full form of PATHNAME as a string.")
(CL:WHEN (AND (STREAMP PATHNAME)
(NOT (fetch (STREAM NAMEDP) of PATHNAME)))
(* ;
 "unnamed streams have the empty string as name.")
(NOT (fetch (STREAM NAMEDP) of PATHNAME))) (* ;
 "unnamed streams have the empty string as name.")
(CL:RETURN-FROM CL:NAMESTRING ""))
[LET* ((PATHNAME (PATHNAME PATHNAME))
(CL::HOST (%%PATHNAME-HOST PATHNAME))
@ -306,8 +307,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(T CL::VERSION))])])
(CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0)
END
(JUNK-ALLOWED NIL))
END
(JUNK-ALLOWED NIL))
(* ;;; "Parses a string representation of a pathname into a pathname. For details on the other silly arguments see the manual. NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything) It also ignores Host and defaults since we don't support non-standard hosts")
@ -317,9 +318,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(PATHNAME (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:VALUES THING START)))
(STREAM (CL:IF (XCL:SYNONYM-STREAM-P THING)
[CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:PARSE-NAMESTRING (CL:SYMBOL-VALUE
(
(
XCL:SYNONYM-STREAM-SYMBOL
THING]
THING]
(SETQ THING (FILE-NAME THING))))
(CL:SYMBOL (SETQ THING (CL:SYMBOL-NAME THING)))
(T (CL:ERROR "This is of an inappropriate type for parse-namestring: ~S" THING)))
@ -339,8 +340,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(CL:DIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH
(%%WILD-NAME CL:DIRECTORY)))
(CL::SUBDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :SUBDIRECTORY
:PATH (%%WILD-NAME CL::SUBDIRECTORY))
)
:PATH (%%WILD-NAME CL::SUBDIRECTORY)))
(CL::RELATIVEDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE
:PATH (%%WILD-NAME
CL::RELATIVEDIRECTORY))
@ -374,8 +374,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
((OR (LITATOM FILE)
(CL:STRINGP FILE)
(NUMBERP FILE)))
[(type? STREAM FILE) (* ;
 "For streams, use full name. If anonymous, fake it")
[(type? STREAM FILE) (* ;
 "For streams, use full name. If anonymous, fake it")
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
(RETURN (CONS (SUB1 POS)
(LIST 'NAME FILE]
@ -387,12 +387,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
FILE 2)
0))))
(%[ (* ;
 "some Xerox and Arpanet systems use `[' for host")
 "some Xerox and Arpanet systems use `[' for host")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
FILE 2)
0))))
(%( (* ;
 "this is the standard for Xerox product file servers")
 "this is the standard for Xerox product file servers")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
FILE 2)
0))))
@ -426,7 +426,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
[COND
((AND (EQ START POS)
(NOT HOSTP)) (* ;
 "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory")
 "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory")
(SETQ TYPE 'SUBDIRECTORY]
-2)
(PROGN -1)))
@ -435,12 +435,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(DREVERSE VAL]
((SELCHARQ (NTHCHARCODE FILE POS)
(/ (* ;
 "unix and the `xerox standard' use / for delimiter")
 "unix and the `xerox standard' use / for delimiter")
(SETQ TEM (LASTCHPOS (CHARCODE /)
FILE
(ADD1 POS))))
((< >) (* ;
 "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
 "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
(SETQ TEM (LASTCHPOS (CHARCODE >)
FILE
(ADD1 POS))))
@ -456,7 +456,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
NAMELP
(SELCHARQ CODE
((%. ! ; NIL) (* ;
 "NAME and SUBDIRECTORY fields definitely terminated by now")
 "NAME and SUBDIRECTORY fields definitely terminated by now")
(COND
((AND (EQ CODE (CHARCODE %.))
(NOT BEYONDNAME)
@ -475,29 +475,29 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(COND
((AND (NULL CODE)
(EQ POS TEM)) (* ;
 "Nothing follows the subdirectory; null name is NOT implied")
 "Nothing follows the subdirectory; null name is NOT implied")
(RETURN (CONS (SUB1 POS)
(DREVERSE VAL]
(%%UNPACKFILE1 [COND
((NOT BEYONDNAME)
(COND
((NEQ CODE (CHARCODE %.))
(SETQQ BEYONDEXT ;)))
(SETQQ BEYONDNAME NAME))
((NOT BEYONDEXT)
(SETQ BEYONDEXT (COND
((NEQ CODE (CHARCODE %.))
';)
(T T)))
'TYPE)
(T (SELCHARQ (AND (EQ BEYONDEXT ';)
(NTHCHARCODE FILE POS))
(P 'PROTECTION)
(A (add POS 1)
'ACCOUNT)
((T S)
'TEMPORARY)
'VERSION]
((NOT BEYONDNAME)
(COND
((NEQ CODE (CHARCODE %.))
(SETQQ BEYONDEXT ;)))
(SETQQ BEYONDNAME NAME))
((NOT BEYONDEXT)
(SETQ BEYONDEXT (COND
((NEQ CODE (CHARCODE %.))
';)
(T T)))
'TYPE)
(T (SELCHARQ (AND (EQ BEYONDEXT ';)
(NTHCHARCODE FILE POS))
(P 'PROTECTION)
(A (add POS 1)
'ACCOUNT)
((T S)
'TEMPORARY)
'VERSION]
POS
(SUB1 TEM)
FILE PACKFLG ONEFIELDFLG VAL)
@ -509,12 +509,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(%' (* ; "Quoter")
(add TEM 1))
((/ >) (* ;
 "Subdirectory terminating character")
 "Subdirectory terminating character")
(COND
((AND (NOT HOSTP)
(NOT BEYONDNAME)
DIRFLG) (* ;
 "Ok to treat this as a subdirectory")
 "Ok to treat this as a subdirectory")
(SETQ SUBDIREND TEM))))
NIL)
NEXTCHAR
@ -527,14 +527,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
[if (STREAMP PATHNAME)
then (COND
[(XCL:SYNONYM-STREAM-P PATHNAME)
(CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (
XCL:SYNONYM-STREAM-SYMBOL
PATHNAME]
((NOT (fetch (STREAM NAMEDP) of PATHNAME))
(* ;
 "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.")
(CL:ERROR "The stream ~S has no corresponding named file." PATHNAME]
[(XCL:SYNONYM-STREAM-P PATHNAME)
(CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (XCL:SYNONYM-STREAM-SYMBOL
PATHNAME]
((NOT (fetch (STREAM NAMEDP) of PATHNAME)) (* ;
 "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.")
(CL:ERROR "The stream ~S has no corresponding named file." PATHNAME]
(LET ((RESULT (CL:PROBE-FILE PATHNAME)))
(CL:UNLESS RESULT
(CL:ERROR "The file ~S does not exist." (CL:NAMESTRING PATHNAME)))
@ -571,8 +569,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS* \CONNECTED.DIRECTORY))
(if (NOT (BOUNDP '\CONNECTED.DIRECTORY))
then (SETQ \CONNECTED.DIRECTORY '{DSK}))
[SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY
(FILENAMEFIELD \CONNECTED.DIRECTORY 'HOST]
[SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD
\CONNECTED.DIRECTORY
'HOST]
(CL:SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*)
:NEWEST)
*DEFAULT-PATHNAME-DEFAULTS*)
@ -599,53 +598,52 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(DECLARE (IGNORE DIRFLG))
[if ONEFIELDFLG
then [AND (CL:CONSP ONEFIELDFLG)
(SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG
'(HOST DEVICE DIRECTORY NAME EXTENSION VERSION]
(LET [(RESULT (CASE ONEFIELDFLG
(HOST (CL:PATHNAME-HOST FILE))
(DEVICE (CL:PATHNAME-DEVICE FILE))
(DIRECTORY (CL:PATHNAME-DIRECTORY FILE))
(NAME (CL:PATHNAME-NAME FILE))
(EXTENSION (CL:PATHNAME-TYPE FILE))
(VERSION (CL:PATHNAME-VERSION FILE))
(CL:OTHERWISE NIL))]
(if ATOMFLG
then (MKATOM RESULT)
else RESULT))
(SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG
'(HOST DEVICE DIRECTORY NAME EXTENSION VERSION]
(LET [(RESULT (CASE ONEFIELDFLG
(HOST (CL:PATHNAME-HOST FILE))
(DEVICE (CL:PATHNAME-DEVICE FILE))
(DIRECTORY (CL:PATHNAME-DIRECTORY FILE))
(NAME (CL:PATHNAME-NAME FILE))
(EXTENSION (CL:PATHNAME-TYPE FILE))
(VERSION (CL:PATHNAME-VERSION FILE))
(CL:OTHERWISE NIL))]
(if ATOMFLG
then (MKATOM RESULT)
else RESULT))
else (LET ((COMPONENT))
(APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE))
then (LIST 'HOST (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)
COMPONENT))
(if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE))
then (LIST 'DEVICE (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE))
then (LIST 'DIRECTORY (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-NAME FILE))
then (LIST 'NAME (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE))
then (LIST 'EXTENSION (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE))
then (LIST 'VERSION (if ATOMFLG
then (MKATOM COMPONENT)
else (MKSTRING COMPONENT])
(APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE))
then (LIST 'HOST (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)
COMPONENT))
(if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE))
then (LIST 'DEVICE (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE))
then (LIST 'DIRECTORY (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-NAME FILE))
then (LIST 'NAME (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE))
then (LIST 'EXTENSION (if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE))
then (LIST 'VERSION (if ATOMFLG
then (MKATOM COMPONENT)
else (MKSTRING COMPONENT])
(CL:DEFUN CL:FILE-NAMESTRING (PATHNAME)
(LET* ((*PRINT-BASE* 10)
(*PRINT-RADIX* NIL)
(PATH (PATHNAME PATHNAME))
[RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING (
%%PATHNAME-NAME
PATH)))
[RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING (%%PATHNAME-NAME
PATH)))
"."
(MKSTRING (%%COMPONENT-STRING (%%PATHNAME-TYPE PATH]
(VERSION (%%PATHNAME-VERSION PATH)))
@ -675,8 +673,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME
%%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME)
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME)
)
(PRETTYCOMPRINT CMLPATHNAMECOMS)
@ -706,24 +703,33 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
(FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING))
(FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
CL:ENOUGH-NAMESTRING
CL:MERGE-PATHNAMES
CL:MAKE-PATHNAME])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES
PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME)
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME
%%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME)
)
(PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3597 9368 (%%PRINT-PATHNAME 3607 . 3768) (CL:MAKE-PATHNAME 3770 . 8520) (
%%PRINT-DIRECTORY-COMPONENT 8522 . 9366)) (10569 15893 (PATHNAME 10579 . 10771) (CL:MERGE-PATHNAMES
10773 . 12859) (FILE-NAME 12861 . 13002) (CL:HOST-NAMESTRING 13004 . 13193) (CL:ENOUGH-NAMESTRING
13195 . 15660) (%%NUMERIC-STRING-P 15662 . 15891)))))
(FILEMAP (NIL (3743 9514 (%%PRINT-PATHNAME 3753 . 3914) (CL:MAKE-PATHNAME 3916 . 8666) (
%%PRINT-DIRECTORY-COMPONENT 8668 . 9512)) (9516 9709 (CL:PATHNAME-HOST 9516 . 9709)) (9711 9910 (
CL:PATHNAME-DEVICE 9711 . 9910)) (9912 10120 (CL:PATHNAME-DIRECTORY 9912 . 10120)) (10122 10315 (
CL:PATHNAME-NAME 10122 . 10315)) (10317 10510 (CL:PATHNAME-TYPE 10317 . 10510)) (10512 10714 (
CL:PATHNAME-VERSION 10512 . 10714)) (10715 16039 (PATHNAME 10725 . 10917) (CL:MERGE-PATHNAMES 10919 .
13005) (FILE-NAME 13007 . 13148) (CL:HOST-NAMESTRING 13150 . 13339) (CL:ENOUGH-NAMESTRING 13341 .
15806) (%%NUMERIC-STRING-P 15808 . 16037)) (16041 19794 (CL:NAMESTRING 16041 . 19794)) (19796 23267 (
CL:PARSE-NAMESTRING 19796 . 23267)) (23269 31722 (PARSE-NAMESTRING1 23269 . 31722)) (31724 32727 (
CL:TRUENAME 31724 . 32727)) (32729 32921 (%%MAKE-PATHNAME 32729 . 32921)) (32923 33560 (
%%PATHNAME-EQUAL 32923 . 33560)) (33562 34019 (%%DIRECTORY-COMPONENT-EQUAL 33562 . 34019)) (34021
34644 (%%INITIALIZE-DEFAULT-PATHNAME 34021 . 34644)) (34734 34901 (INTERLISP-NAMESTRING 34734 . 34901)
) (34903 37796 (UNPACKPATHNAME.STRING 34903 . 37796)) (37798 39055 (CL:FILE-NAMESTRING 37798 . 39055))
(39057 39255 (CL:DIRECTORY-NAMESTRING 39057 . 39255)))))
STOP

BIN
sources/CMLPATHNAME.LCOM
View File

Binary file not shown.

140
sources/COREIO
View File

@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Jan-2022 20:02:51" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;4 55136
(FILECREATED "18-Jan-2022 11:22:04" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;14 58002
:CHANGES-TO (FNS \CORE.SETFILEINFO)
:CHANGES-TO (FNS \CORE.DIRECTORYNAMEP)
:PREVIOUS-DATE "22-Nov-2021 09:25:42"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;3)
:PREVIOUS-DATE "11-Jan-2022 16:45:02"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;13)
(* ; "
@ -27,6 +27,8 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
\CORE.SETACCESSTIME \CORE.SETFILEINFO \CORE.GETNEXTBUFFER \CORE.UNPACKFILENAME)
(FNS COREDEVICE \CREATECOREDEVICE)
(FNS \NODIRCOREFDEV \NODIRCORE.OPENFILE)
(FNS FILEDIRCASEARRAY)
(VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY)))
(DECLARE%: DONTCOPY (RECORDS CORE.PAGEENTRY COREFILEINFOBLK CORESTREAM COREDEVICE
COREGENFILESTATE))
(INITRECORDS COREFILEINFOBLK)
@ -90,10 +92,34 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
(RETURN (fetch IOFILEFULLNAME of INFOBLOCK])
(\CORE.DIRECTORYNAMEP
[LAMBDA (DIRNAME DEV) (* ; "Edited 19-Feb-93 16:04 by jds")
(LET [(DIR (UNPACKFILENAME.STRING DIRNAME 'DIRECTORY]
(AND DIRNAME DIR (> (NCHARS DIR)
0])
[LAMBDA (DIRNAME DEV) (* ; "Edited 18-Jan-2022 11:17 by rmk")
(* ; "Edited 10-Jan-2022 22:33 by rmk")
(* ;;
 "Edited 9-Jan-2022 12:42 by rmk: Using the new FILEDIRCASEARRAY so that slashes and brackets match")
(* ;; "Edited 5-Jan-2022 15:03 by rmk: The previous definition didn't actually check to see if the directory existed. %"existed%" for COREIO means there is at least one file currently in that directory.")
(* ;; "Edited 19-Feb-93 16:04 by jds")
(CL:WHEN DIRNAME
(* ;; "The DIRNAME could be just {CORE}, which always is OK, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.")
(IF (EQ (CHARCODE })
(NTHCHARCODE DIRNAME -1))
ELSE (CL:UNLESS (MEMB (NTHCHARCODE DIRNAME -1)
(CHARCODE (> /)))
(SETQ DIRNAME (CONCAT DIRNAME ">")))
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
FIRST (CL:UNLESS (EQ DIRPOS 1)
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
IN (CDR (FETCH COREDIRECTORY OF DEV)) WHEN (STRPOS DIRNAME (CAR ENTRY)
1 NIL T NIL FILEDIRCASEARRAY)
DO (RETURN T))))])
(\CORE.FINDPAGE
[LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32")
@ -351,28 +377,30 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
(RETURN INFOBLOCK])
(\CORE.NAMESCAN
[LAMBDA (NAME NAMELST CREATEFLG) (* ; "Edited 23-Oct-87 17:11 by bvm:")
[LAMBDA (NAME NAMELST CREATEFLG)
(* ;; "Edited 11-Jan-2022 09:30 by rmk: Matching with FILEDIRCASEARRAY, for /")
(* ;; "Edited 23-Oct-87 17:11 by bvm:")
(COND
((LISTP NAMELST)
(bind NEWSEG NEXTNAME while [AND (CDR NAMELST)
(COND
((STRING-EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST)
))
NAME)
(COND
((STRING.EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST)))
NAME FILEDIRCASEARRAY)
(* ; "Found it")
(RETURN (CADR NAMELST)))
(T (UALPHORDER NEXTNAME NAME]
do (* ;
 "Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME")
(SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND
((AND CREATEFLG (SETQ NEWSEG
(
 \CORE.NAMESEGMENT
NAME)))
(RPLACD NAMELST
(CONS NEWSEG
(CDR NAMELST)))
NEWSEG])
(RETURN (CADR NAMELST)))
(T (ALPHORDER NEXTNAME NAME FILEDIRCASEARRAY]
do (* ;
 "Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME")
(SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND
((AND CREATEFLG (SETQ NEWSEG
(\CORE.NAMESEGMENT
NAME)))
(RPLACD NAMELST (CONS NEWSEG
(CDR NAMELST)))
NEWSEG])
(\CORE.NAMESEGMENT
[LAMBDA (NAME) (* rmk%: "24-FEB-84 21:14")
@ -710,7 +738,12 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
(RETURN T])
(\CORE.UNPACKFILENAME
[LAMBDA (NAME) (* ; "Edited 3-Nov-87 12:12 by bvm:")
[LAMBDA (NAME) (* ; "Edited 10-Jan-2022 22:42 by rmk")
(* ;; "rmk; Convert / in ROOT to < or >")
(* ; "Edited 10-Jan-2022 21:14 by rmk")
(* ;; "Edited 3-Nov-87 12:12 by bvm:")
(* ;; "Breaks up a file name atom into its fields which it sets freely in its caller")
@ -729,6 +762,17 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
(SETQ DOT SEMI)))
(SETQ ROOT (OR (SUBSTRING NAME START (SUB1 DOT))
""))
(CL:WHEN (STRPOS "/" ROOT)
(* ;; "If ROOT has slashes, convert to < ..> ..>")
(SETQ ROOT (DSUBST (CHARCODE >)
(CHARCODE /)
(CHCON ROOT)))
(CL:WHEN (EQ (CAR ROOT)
(CHARCODE >))
(RPLACA ROOT (CHARCODE <)))
(SETQ ROOT (CONCATCODES ROOT)))
(SETQ EXT (COND
((< DOT (- SEMI 1))
(SUBSTRING NAME (ADD1 DOT)
@ -858,6 +902,24 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
(\CORE.SETACCESSTIME NAME ACCESS)
NAME])
)
(DEFINEQ
(FILEDIRCASEARRAY
[LAMBDA NIL (* ; "Edited 8-Jan-2022 20:15 by rmk")
(* ;; "Returns a case array suitable for case insensitive directory matching: <, >, and / all map together in any position. Presumably there are other well-formedness conditions that put < and > only in their proper positions.")
(* ; "Edited 8-Jan-2022 20:12 by rmk")
(for I (CA _ (CASEARRAY)) from (CHARCODE a) to (CHARCODE z)
do [SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a)
(CHARCODE A]
finally (SETCASEARRAY CA (CHARCODE <)
(CHARCODE /))
(SETCASEARRAY CA (CHARCODE >)
(CHARCODE /))
(RETURN CA])
)
(RPAQ FILEDIRCASEARRAY (FILEDIRCASEARRAY))
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
@ -955,16 +1017,16 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
(PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
1993 1999 2018))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1707 44342 (\CORE.CLOSEFILE 1717 . 2490) (\CORE.DELETEFILE 2492 . 4478) (
\CORE.DIRECTORYNAMEP 4480 . 4741) (\CORE.FINDPAGE 4743 . 7972) (\CORE.GENERATEFILES 7974 . 10561) (
\CORE.NEXTFILEFN 10563 . 11062) (\CORE.FILEINFOFN 11064 . 11293) (\CORE.GETFILEHANDLE 11295 . 13449) (
\CORE.GETFILEINFO 13451 . 14414) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14416 . 15953) (\CORE.GETFILENAME
15955 . 18244) (\CORE.GETINFOBLOCK 18246 . 20869) (\CORE.NAMESCAN 20871 . 22638) (\CORE.NAMESEGMENT
22640 . 23077) (\CORE.OPENFILE 23079 . 26198) (\COREFILE.SETPARAMETERS 26200 . 28381) (
\CORE.PACKFILENAME 28383 . 28778) (\CORE.RELEASEPAGES 28780 . 29381) (\CORE.SETFILEPTR 29383 . 30482)
(\CORE.UPDATEOF 30484 . 32113) (\CORE.BACKFILEPTR 32115 . 34323) (\CORE.SETEOFPTR 34325 . 36194) (
\CORE.SETACCESSTIME 36196 . 36821) (\CORE.SETFILEINFO 36823 . 39125) (\CORE.GETNEXTBUFFER 39127 .
43083) (\CORE.UNPACKFILENAME 43085 . 44340)) (44343 47976 (COREDEVICE 44353 . 44524) (
\CREATECOREDEVICE 44526 . 47974)) (47977 50278 (\NODIRCOREFDEV 47987 . 48584) (\NODIRCORE.OPENFILE
48586 . 50276)))))
(FILEMAP (NIL (1796 46254 (\CORE.CLOSEFILE 1806 . 2579) (\CORE.DELETEFILE 2581 . 4567) (
\CORE.DIRECTORYNAMEP 4569 . 6250) (\CORE.FINDPAGE 6252 . 9481) (\CORE.GENERATEFILES 9483 . 12070) (
\CORE.NEXTFILEFN 12072 . 12571) (\CORE.FILEINFOFN 12573 . 12802) (\CORE.GETFILEHANDLE 12804 . 14958) (
\CORE.GETFILEINFO 14960 . 15923) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15925 . 17462) (\CORE.GETFILENAME
17464 . 19753) (\CORE.GETINFOBLOCK 19755 . 22378) (\CORE.NAMESCAN 22380 . 23927) (\CORE.NAMESEGMENT
23929 . 24366) (\CORE.OPENFILE 24368 . 27487) (\COREFILE.SETPARAMETERS 27489 . 29670) (
\CORE.PACKFILENAME 29672 . 30067) (\CORE.RELEASEPAGES 30069 . 30670) (\CORE.SETFILEPTR 30672 . 31771)
(\CORE.UPDATEOF 31773 . 33402) (\CORE.BACKFILEPTR 33404 . 35612) (\CORE.SETEOFPTR 35614 . 37483) (
\CORE.SETACCESSTIME 37485 . 38110) (\CORE.SETFILEINFO 38112 . 40414) (\CORE.GETNEXTBUFFER 40416 .
44372) (\CORE.UNPACKFILENAME 44374 . 46252)) (46255 49888 (COREDEVICE 46265 . 46436) (
\CREATECOREDEVICE 46438 . 49886)) (49889 52190 (\NODIRCOREFDEV 49899 . 50496) (\NODIRCORE.OPENFILE
50498 . 52188)) (52191 53096 (FILEDIRCASEARRAY 52201 . 53094)))))
STOP

BIN
sources/COREIO.LCOM
View File

Binary file not shown.

117
sources/DMISC
View File

@ -1,13 +1,15 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-May-90 15:53:57" {DSK}<usr>local>lde>lispcore>sources>DMISC.;3 45292
changes to%: (VARS DMISCCOMS)
(FILECREATED " 6-Jan-2022 19:08:15" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DMISC.;3 45512
previous date%: " 6-Apr-90 10:59:19" {DSK}<usr>local>lde>lispcore>sources>DMISC.;2)
:CHANGES-TO (FNS FLASHWINDOW)
:PREVIOUS-DATE "16-May-90 15:53:57"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DMISC.;1)
(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved.
Copyright (c) 1982-1990 by Venue & Xerox Corporation.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
@ -41,7 +43,7 @@ with the terms of said license.
(DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \PlayTimer))
(INITRESOURCES \PlayTimer)
(DECLARE%: DONTEVAL@LOAD DOCOPY (* ;
 "Overrides definition in the shared MISC")
 "Overrides definition in the shared MISC")
(P (MOVD 'RINGBELLS 'PRINTBELLS]
[COMS (* ; "Changing display")
(FNS DISPLAYDOWN SETDISPLAYHEIGHT VIDEORATE)
@ -68,7 +70,7 @@ with the terms of said license.
\MISC1.UFN \MISC2.UFN \MISC3.UFN \MISC4.UFN \MISC5.UFN \MISC6.UFN \MISC7.UFN
\MISC8.UFN \MISC10.UFN)
(* ;
 "sub-functions of floating-point ufns")
 "sub-functions of floating-point ufns")
(FNS \BLKFDIFF.UFN \BLKFPLUS.UFN \BLKFTIMES.UFN \BLKSEP.UFN \BLKPERM.UFN
\BLKEXPONENT.UFN \BLKFLOATP2COMP.UFN \BLKSMALLP2FLOAT.UFN \BLKMAG.UFN
\FLOATTOBYTE.UFN \BLKFMAX.UFN \BLKFMIN.UFN \BLKFABSMAX.UFN \BLKFABSMIN.UFN)
@ -79,7 +81,7 @@ with the terms of said license.
(LOCALVARS . T)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA \DIRTYBACKGROUND])
(LAMA])
(DEFINEQ
(BACKSPACEDEL
@ -226,28 +228,35 @@ with the terms of said license.
(FLASHWINDOW NIL N])
(FLASHWINDOW
[LAMBDA (WIN? N FLASHINTERVAL SHADE) (* bvm%: "16-Jul-85 12:20")
(* ; "This is an 'attention getting' action.")
(* ;
"rrb --- added shade argument so contrast of flash could be explored.")
[LAMBDA (WIN? N FLASHINTERVAL SHADE) (* ; "Edited 6-Jan-2022 19:08 by rmk")
(* bvm%: "16-Jul-85 12:20")
(* ;
 "This is an 'attention getting' action.")
(* ;
 "rrb --- added shade argument so contrast of flash could be explored.")
(OR (FIXP N)
(SETQ N 1))
(OR (FIXP FLASHINTERVAL)
(SETQ FLASHINTERVAL 200))
[COND
((WINDOWP WIN?)
(SETQ WIN? (GETSTREAM WIN? 'OUTPUT]
(WIN?
(* ;;
 "RMK: GETSTREAM even if not a window. Catches T, other streams. But NIL still means whole screen")
(SETQ WIN? (GETSTREAM WIN? 'OUTPUT]
(for I to N bind (WHOLEP _ (NOT (DISPLAYSTREAMP WIN?)))
COLORP first [COND
(WHOLEP (SETQ COLORP (NULL (VIDEOCOLOR]
do (UNINTERRUPTABLY
(* ;
"Open-coded 'during' loops so that no one else can sneak in and steal cycles")
(* ;
 "Open-coded 'during' loops so that no one else can sneak in and steal cycles")
(COND
[WHOLEP (* ; "Flash the whole screen")
[WHOLEP (* ; "Flash the whole screen")
(VIDEOCOLOR (PROG1 (VIDEOCOLOR COLORP)
(DISMISS FLASHINTERVAL NIL T]
(T (* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer")
(T
(* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer")
(INVERTW WIN? SHADE)
(DISMISS FLASHINTERVAL NIL T)
(INVERTW WIN? SHADE))))
@ -907,26 +916,26 @@ with the terms of said license.
)
(RPAQQ RINGBELLS.L1 ((1000 . 1000)
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000)))
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000)))
(RPAQQ RINGBELLS.L2 ((2000 . 1000)
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000)))
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
@ -937,27 +946,27 @@ with the terms of said license.
(ADDTOVAR NLAML )
(ADDTOVAR LAMA \DIRTYBACKGROUND)
(ADDTOVAR LAMA )
)
(PUTPROPS DMISC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4791 5494 (BACKSPACEDEL 4801 . 5492)) (5589 6022 (PERIODICALLYRECLAIM 5599 . 6020)) (
6252 7943 (\DIRTYBACKGROUND 6262 . 6684) (\SAVEVMBACKGROUND 6686 . 7470) (COPYVM 7472 . 7941)) (8364
9563 (SETTIME 8374 . 9561)) (9564 13243 (RINGBELLS 9574 . 10067) (FLASHWINDOW 10069 . 11645) (PLAYTUNE
11647 . 13241)) (13505 19037 (DISPLAYDOWN 13515 . 13903) (SETDISPLAYHEIGHT 13905 . 16705) (VIDEORATE
16707 . 19035)) (19461 20182 (DOAROUNDEXITFORMS 19471 . 20180)) (20385 22100 (REALMEMORYSIZE 20395 .
20553) (LISPVERSION 20555 . 20708) (MICROCODEVERSION 20710 . 20868) (BCPLVERSION 20870 . 21023) (
REQUIREVERSION 21025 . 22098)) (22137 26715 (APROPOS 22147 . 26163) (APROPRINT 26165 . 26713)) (26741
30649 (READPRINTERPORT 26751 . 26892) (WRITEPRINTERPORT 26894 . 27049) (\READPRINTERPORT.UFN 27051 .
27240) (\WRITEPRINTERPORT.UFN 27242 . 27440) (\MISC1.UFN 27442 . 27595) (\MISC2.UFN 27597 . 27835) (
\MISC3.UFN 27837 . 28570) (\MISC4.UFN 28572 . 29122) (\MISC5.UFN 29124 . 29277) (\MISC6.UFN 29279 .
29529) (\MISC7.UFN 29531 . 30016) (\MISC8.UFN 30018 . 30319) (\MISC10.UFN 30321 . 30647)) (30703 38152
(\BLKFDIFF.UFN 30713 . 31278) (\BLKFPLUS.UFN 31280 . 31852) (\BLKFTIMES.UFN 31854 . 32429) (
\BLKSEP.UFN 32431 . 33562) (\BLKPERM.UFN 33564 . 34033) (\BLKEXPONENT.UFN 34035 . 34445) (
\BLKFLOATP2COMP.UFN 34447 . 35031) (\BLKSMALLP2FLOAT.UFN 35033 . 35392) (\BLKMAG.UFN 35394 . 36045) (
\FLOATTOBYTE.UFN 36047 . 36626) (\BLKFMAX.UFN 36628 . 37020) (\BLKFMIN.UFN 37022 . 37411) (
\BLKFABSMAX.UFN 37413 . 37782) (\BLKFABSMIN.UFN 37784 . 38150)) (38192 40010 (\P-MISC2.UFN 38202 .
38443) (\LINES-EQUAL-P 38445 . 38829) (\GET-NEXT-RUN 38831 . 40008)) (40011 44190 (IBLT1 40021 . 42023
) (IBLT2 42025 . 44188)))))
(FILEMAP (NIL (4747 5450 (BACKSPACEDEL 4757 . 5448)) (5545 5978 (PERIODICALLYRECLAIM 5555 . 5976)) (
6208 7899 (\DIRTYBACKGROUND 6218 . 6640) (\SAVEVMBACKGROUND 6642 . 7426) (COPYVM 7428 . 7897)) (8320
9519 (SETTIME 8330 . 9517)) (9520 13551 (RINGBELLS 9530 . 10023) (FLASHWINDOW 10025 . 11953) (PLAYTUNE
11955 . 13549)) (13813 19345 (DISPLAYDOWN 13823 . 14211) (SETDISPLAYHEIGHT 14213 . 17013) (VIDEORATE
17015 . 19343)) (19769 20490 (DOAROUNDEXITFORMS 19779 . 20488)) (20693 22408 (REALMEMORYSIZE 20703 .
20861) (LISPVERSION 20863 . 21016) (MICROCODEVERSION 21018 . 21176) (BCPLVERSION 21178 . 21331) (
REQUIREVERSION 21333 . 22406)) (22445 27023 (APROPOS 22455 . 26471) (APROPRINT 26473 . 27021)) (27049
30957 (READPRINTERPORT 27059 . 27200) (WRITEPRINTERPORT 27202 . 27357) (\READPRINTERPORT.UFN 27359 .
27548) (\WRITEPRINTERPORT.UFN 27550 . 27748) (\MISC1.UFN 27750 . 27903) (\MISC2.UFN 27905 . 28143) (
\MISC3.UFN 28145 . 28878) (\MISC4.UFN 28880 . 29430) (\MISC5.UFN 29432 . 29585) (\MISC6.UFN 29587 .
29837) (\MISC7.UFN 29839 . 30324) (\MISC8.UFN 30326 . 30627) (\MISC10.UFN 30629 . 30955)) (31011 38460
(\BLKFDIFF.UFN 31021 . 31586) (\BLKFPLUS.UFN 31588 . 32160) (\BLKFTIMES.UFN 32162 . 32737) (
\BLKSEP.UFN 32739 . 33870) (\BLKPERM.UFN 33872 . 34341) (\BLKEXPONENT.UFN 34343 . 34753) (
\BLKFLOATP2COMP.UFN 34755 . 35339) (\BLKSMALLP2FLOAT.UFN 35341 . 35700) (\BLKMAG.UFN 35702 . 36353) (
\FLOATTOBYTE.UFN 36355 . 36934) (\BLKFMAX.UFN 36936 . 37328) (\BLKFMIN.UFN 37330 . 37719) (
\BLKFABSMAX.UFN 37721 . 38090) (\BLKFABSMIN.UFN 38092 . 38458)) (38500 40318 (\P-MISC2.UFN 38510 .
38751) (\LINES-EQUAL-P 38753 . 39137) (\GET-NEXT-RUN 39139 . 40316)) (40319 44498 (IBLT1 40329 . 42331
) (IBLT2 42333 . 44496)))))
STOP

BIN
sources/DMISC.LCOM
View File

Binary file not shown.

113
sources/EDITINTERFACE
View File

@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Dec-2021 18:25:33" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;29 47473
(FILECREATED "19-Jan-2022 23:09:02" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;34 47559
:CHANGES-TO (FNS EDITDATE? EDITDATE)
:CHANGES-TO (FNS FIXEDITDATE EDITDATE?)
:PREVIOUS-DATE " 8-Dec-2021 16:11:23"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;27)
:PREVIOUS-DATE "19-Jan-2022 10:22:03"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;31)
(* ; "
@ -109,7 +109,7 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
"used in ED to stash last call info so (ED NIL) will restart last edit")
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
(* ;;; "Standard Common Lisp editor entry. CLtL say's ED does something reasonable when passed a pathname. We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit that. Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.")
@ -627,13 +627,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
OLDATE INITLS])
(FIXEDITDATE
[LAMBDA (EXPR)
[LAMBDA (EXPR) (* ; "Edited 19-Jan-2022 23:08 by rmk")
(* ;; "Edited 8-Dec-2021 16:11 by rmk: Updated to add dates to the initial undated comments that begins with current-editor initials, to provide a kind of dated change-log capability.")
(* ; "Edited 3-Dec-2021 15:03 by rmk")
(* ; "Edited 22-Oct-2021 16:58 by rmk:")
(* ; "Edited 27-Sep-2018 22:04 by rmk:")
(* ; "Edited 31-Mar-2000 17:13 by rmk:")
 (* ; "Edited 27-Sep-2018 22:04 by rmk:")
(* ; "Edited 31-Mar-2000 17:13 by rmk:")
(* ; "Edited 17-Jul-89 11:13 by jtm:")
(* ; "18-JUL-78 21:11")
@ -722,56 +720,57 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
ELSEIF (SETQ PARSE (EDITDATE? (CAR E)
T))
THEN
(* ;; "Attach the new timestamp at the beginning of E, provided the new date is either more than a day later than the previous one or by a different editor.")
(* ;; "If edited by the same editor within a day, then update the previous timestamp rather than cluttering with a new one. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ")
(* ;; "If edited by the same editor within a day, then update the previous timestamp rather than just leaving the original time. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ")
(IF (STRING.EQUAL INITLS (CADR PARSE))
(IF [AND (STRING.EQUAL INITLS (CADR PARSE))
(ILEQ (IDIFFERENCE (IDATE)
(IDATE (CAR PARSE)))
(CONSTANT (TIMES 24 3600]
THEN
(* ;; "Another edit by the same author. If not dated but contains a rest, then upgrade the rest comment with a date Otherwise,If more than a day later, add a new date. If less than a day, assume we are in essentially the same session, and update (CAR E) to the current time.")
(* ;; "Same edit session with the same author: update the last previous timestamp. If the (CAR PARSE) is NIL, we are looking at an initialed comment that becomes a timestamp, and we convert it. If just after this we see another timestamp for the same session, we take that out.")
[IF (NULL (CAR PARSE))
THEN
(* ;; "If no date but %"INITIALS: xxx%", we definitely want to upgraded to the Edited... initials: xxx format")
(/RPLACA E (EDITDATE (CAR E)
INITLS
(CADDR PARSE)))
ELSEIF (IGREATERP (IDIFFERENCE (IDATE)
(/RPLACA E (EDITDATE (CAR E)
INITLS
(CADDR PARSE)))
(CL:WHEN [AND (SETQ PARSE (EDITDATE? (CADR E)
T))
(NULL (CADDR PARSE))
(STRING.EQUAL INITLS (CADR PARSE))
(ILEQ (IDIFFERENCE (IDATE)
(IDATE (CAR PARSE)))
(TIMES 24 3600))
THEN
(* ;;
 "If we aren't upgrading, then we don't want to propagate the previous REST.")
(/ATTACH (EDITDATE NIL INITLS)
E)
ELSE
(* ;;
 "Same author, within a day. Just change the date, keep the REST.")
(/RPLACA E (EDITDATE (CAR E)
INITLS
(CADDR PARSE]
(CONSTANT (TIMES 24 3600]
(/RPLACD E (CDDR E)))
ELSE
(* ;;
 "Different edit sequence, attach a new timestamp in front of any old ones.")
(* ;; "Not a previous date, or not one with this author. Add a new one. If rmk is editing and sees an lmm: rest, we don't want to attribute that rest to rmk in the new one.")
(/ATTACH (EDITDATE NIL INITLS (CADDR PARSE))
E))
(/ATTACH (EDITDATE NIL INITLS)
E))
(* ;; "If the new date has an upgraded comment-level, update all of the previous dates so that they align on the left instead of the right.")
(CL:UNLESS (EQ (CADR (CAR E))
';)
(FOR PREV (NEWTYPE _ (CADR (CAR E))) IN (CDR E)
WHILE (EDITDATE? PREV T) UNTIL (EQ (CADR PREV)
NEWTYPE)
DO (/RPLACA (CDR PREV)
NEWTYPE)))
ELSE
(* ;; "Need a new date, didn't even see %"<initials: xxx%"")
(* ;;
 "First edit: we didn't see an old date to compare with or smash, not even an initials: xxx form.")
(/ATTACH (EDITDATE NIL INITLS)
E)))
(RETURN EXPR)))])
(EDITDATE?
[LAMBDA (COMMENT RESTOK) (* ; "Edited 8-Dec-2021 18:24 by rmk")
[LAMBDA (COMMENT RESTOK) (* ; "Edited 19-Jan-2022 22:49 by rmk")
(* ; "Edited 8-Dec-2021 18:24 by rmk")
(* ;; "Edited 6-Dec-2021 16:04 by rmk: Return will have date/initial, initial/rest, or date/initial/rest. Always an initial and something, or NIL.")
(* ; "Edited 4-Dec-2021 10:39 by rmk")
 (* ; "Edited 4-Dec-2021 10:39 by rmk")
(* ;;; "This determines whether this is a dated or initialed comment that is potentially reusable in the current context. Unless RESTOK, this only recognizes modern-format configurations of the form %"Edited <date> by <initials>%", and returns a parsed pair (DATE INITIALS).")
@ -818,12 +817,14 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
(CL:WHEN (SETQ REST (SUBSTRING STRING (ADD1 IENDPOS)))
(SETQ REST (CL:STRING-TRIM `(#\Space)
REST)))
(IF (IGREATERP (NCHARS REST)
0)
THEN
(* ;; "Could be %"<initials>: abc%" to be upgraded with a date")
(IF (AND REST (IGREATERP (NCHARS REST)
0))
THEN (CL:WHEN RESTOK
(CL:WHEN RESTOK (LIST DATE I REST))
(* ;; "Could be %"<initials>: abc%" , we fill in the date")
(LIST (DATE (DATEFORMAT NO.SECONDS))
I REST))
ELSEIF DATE
THEN
(* ;; "If we saw just initials")
@ -928,11 +929,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
)
(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4086 10381 (ED 4086 . 10381)) (10383 14359 (INSTALL-PROTOTYPE-DEFN 10383 . 14359)) (
14360 31143 (EDITDEF.FNS 14370 . 15706) (EDITF 15708 . 16588) (EDITFB 16590 . 17438) (EDITFNS 17440 .
18760) (EDITLOADFNS? 18762 . 22562) (EDITMODE 22564 . 24574) (EDITP 24576 . 25087) (EDITV 25089 .
25728) (DC 25730 . 26411) (DF 26413 . 27455) (DP 27457 . 28541) (DV 28543 . 29115) (EDITPROP 29117 .
29336) (EF 29338 . 29667) (EP 29669 . 29852) (EV 29854 . 30033) (EDITE 30035 . 30913) (EDITL 30915 .
31141)) (31493 46618 (NEW/EDITDATE 31503 . 31725) (FIXEDITDATE 31727 . 39874) (EDITDATE? 39876 . 43363
) (EDITDATE 43365 . 44621) (SETINITIALS 44623 . 46616)))))
(FILEMAP (NIL (4089 10388 (ED 4089 . 10388)) (10390 14366 (INSTALL-PROTOTYPE-DEFN 10390 . 14366)) (
14367 31150 (EDITDEF.FNS 14377 . 15713) (EDITF 15715 . 16595) (EDITFB 16597 . 17445) (EDITFNS 17447 .
18767) (EDITLOADFNS? 18769 . 22569) (EDITMODE 22571 . 24581) (EDITP 24583 . 25094) (EDITV 25096 .
25735) (DC 25737 . 26418) (DF 26420 . 27462) (DP 27464 . 28548) (DV 28550 . 29122) (EDITPROP 29124 .
29343) (EF 29345 . 29674) (EP 29676 . 29859) (EV 29861 . 30040) (EDITE 30042 . 30920) (EDITL 30922 .
31148)) (31500 46704 (NEW/EDITDATE 31510 . 31732) (FIXEDITDATE 31734 . 39753) (EDITDATE? 39755 . 43449
) (EDITDATE 43451 . 44707) (SETINITIALS 44709 . 46702)))))
STOP

BIN
sources/EDITINTERFACE.LCOM
View File

Binary file not shown.

98
sources/FILEIO
View File

@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Dec-2021 09:31:06" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;103 160528
(FILECREATED "13-Jan-2022 19:45:36" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;105 160514
:CHANGES-TO (FNS \DO.PARAMS.AT.OPEN SETFILEINFO)
:CHANGES-TO (RECORDS FDEV)
:PREVIOUS-DATE "14-Dec-2021 16:10:18"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;102)
:PREVIOUS-DATE "19-Dec-2021 09:31:06"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;103)
(* ; "
@ -859,12 +859,12 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
 "(stream byte) output byte to stream")
(PEEKBIN POINTER) (* ;
 "(stream) => next byte without advancing position in stream")
(NIL POINTER) (* ;
 "Was READCHAR, replaced by READCHARCODE")
(NIL POINTER) (* ;
(FDEV1 POINTER) (* ;
 "Was READCHAR, replaced by READCHARCODE. Now available for device-specific use")
(FDEV2 POINTER) (* ;
 "Was WRITECHAR (stream char) => writes char to stream")
(NIL POINTER) (* ; "Was PEEKCHAR")
(NIL POINTER) (* ; "Was UNREADCHAR")
(FDEV3 POINTER) (* ; "Was PEEKCHAR")
(FDEV4 POINTER) (* ; "Was UNREADCHAR")
(READP POINTER) (* ;
 "(stream flag) => T if there is input available from stream right now")
(EOFP POINTER) (* ;
@ -1125,10 +1125,10 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
(BIN POINTER)
(BOUT POINTER)
(PEEKBIN POINTER)
(NIL POINTER)
(NIL POINTER)
(NIL POINTER)
(NIL POINTER)
(FDEV1 POINTER)
(FDEV2 POINTER)
(FDEV3 POINTER)
(FDEV4 POINTER)
(READP POINTER)
(EOFP POINTER)
(BLOCKIN POINTER)
@ -3089,40 +3089,40 @@ update the map")
(PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989
1990 1991 1992 1993 1999 2020 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (26876 30354 (STREAMPROP 26886 . 27320) (GETSTREAMPROP 27322 . 27791) (PUTSTREAMPROP
27793 . 30202) (STREAMP 30204 . 30352)) (30397 32916 (\DEFPRINT.BY.NAME 30407 . 31559) (
\STREAM.DEFPRINT 31561 . 32609) (\FDEV.DEFPRINT 32611 . 32914)) (33174 38215 (\GETACCESS 33184 . 33638
) (\SETACCESS 33640 . 38213)) (58368 64337 (\DEFINEDEVICE 58378 . 60694) (\GETDEVICEFROMNAME 60696 .
61169) (\GETDEVICEFROMHOSTNAME 61171 . 62215) (\REMOVEDEVICE 62217 . 63340) (\REMOVEDEVICE.NAMES 63342
. 64335)) (64377 88654 (\CLOSEFILE 64387 . 65212) (\DELETEFILE 65214 . 65508) (\DEVICEEVENT 65510 .
67280) (\GENERATEFILES 67282 . 67760) (\GENERATENEXTFILE 67762 . 68413) (\GENERATEFILEINFO 68415 .
68876) (\GETFILENAME 68878 . 69267) (\GENERIC.OUTFILEP 69269 . 69739) (\OPENFILE 69741 . 72319) (
\DO.PARAMS.AT.OPEN 72321 . 74491) (\RENAMEFILE 74493 . 74917) (\REVALIDATEFILE 74919 . 77521) (
\PAGED.REVALIDATEFILELST 77523 . 79081) (\PAGED.REVALIDATEFILES 79083 . 80802) (\PAGED.REVALIDATEFILE
80804 . 83087) (\BUFFERED.REVALIDATEFILE 83089 . 85375) (\BUFFERED.REVALIDATEFILELST 85377 . 86561) (
\PRINT-REVALIDATION-RESULT 86563 . 86978) (\TRUNCATEFILE 86980 . 87371) (\FILE-CONFLICT 87373 . 88652)
) (88690 93353 (\GENERATENOFILES 88700 . 90796) (\NULLFILEGENERATOR 90798 . 91042) (\NOFILESNEXTFILEFN
91044 . 93035) (\NOFILESINFOFN 93037 . 93351)) (93472 95380 (\FILE.NOT.OPEN 93482 . 93995) (
\FILE.WONT.OPEN 93997 . 94325) (\ILLEGAL.DEVICEOP 94327 . 94609) (\IS.NOT.RANDACCESSP 94611 . 95057) (
\STREAM.NOT.OPEN 95059 . 95378)) (95515 97813 (\FDEVINSTANCE 95525 . 97811)) (99015 106389 (CNDIR
99025 . 100330) (DIRECTORYNAME 100332 . 104515) (DIRECTORYNAMEP 104517 . 105133) (HOSTNAMEP 105135 .
105942) (\ADD.CONNECTED.DIR 105944 . 106387)) (106434 134314 (\BACKFILEPTR 106444 . 106632) (
\BACKPEEKBIN 106634 . 106995) (\BACKBIN 106997 . 107348) (BIN 107350 . 107567) (\BIN 107569 . 107846)
(\BINS 107848 . 108134) (BOUT 108136 . 108498) (\BOUT 108500 . 108815) (\BOUTS 108817 . 109128) (
COPYBYTES 109130 . 112462) (COPYCHARS 112464 . 116130) (COPYFILE 116132 . 116929) (\COPYOPENFILE
116931 . 120004) (\INFER.FILE.TYPE 120006 . 120960) (EOFP 120962 . 121259) (FORCEOUTPUT 121261 .
121508) (\FLUSH.OPEN.STREAMS 121510 . 121866) (CHARSET 121868 . 123532) (ACCESS-CHARSET 123534 .
123751) (GETEOFPTR 123753 . 124003) (GETFILEINFO 124005 . 127198) (\TYPE.FROM.FILETYPE 127200 . 127670
) (\FILETYPE.FROM.TYPE 127672 . 127851) (GETFILEPTR 127853 . 128105) (SETFILEINFO 128107 . 132213) (
SETFILEPTR 132215 . 133934) (BOUT16 133936 . 134121) (BIN16 134123 . 134312)) (134417 139622 (
\GENERIC.BINS 134427 . 134707) (\GENERIC.BOUTS 134709 . 134974) (\GENERIC.RENAMEFILE 134976 . 136807)
(\GENERIC.OPENP 136809 . 138124) (\GENERIC.READP 138126 . 139167) (\GENERIC.CHARSET 139169 . 139620))
(139623 139962 (\MAP-OPEN-STREAMS 139633 . 139960)) (141746 143826 (\EOF.ACTION 141756 . 142007) (
\EOSERROR 142009 . 142202) (\GETEOFPTR 142204 . 142386) (\INCFILEPTR 142388 . 142738) (\PEEKBIN 142740
. 142931) (\SETCLOSEDFILELENGTH 142933 . 143267) (\SETEOFPTR 143269 . 143457) (\SETFILEPTR 143459 .
143824)) (143827 144369 (\FIXPOUT 143837 . 144137) (\FIXPIN 144139 . 144367)) (144370 144936 (\BOUTEOL
144380 . 144934)) (147832 157696 (\BUFFERED.BIN 147842 . 148694) (\BUFFERED.PEEKBIN 148696 . 149478)
(\BUFFERED.BOUT 149480 . 150340) (\BUFFERED.BINS 150342 . 154027) (\BUFFERED.BOUTS 154029 . 155830) (
\BUFFERED.COPYBYTES 155832 . 157694)) (157725 160077 (\NULLDEVICE 157735 . 159753) (\NULL.OPENFILE
159755 . 160075)))))
(FILEMAP (NIL (26854 30332 (STREAMPROP 26864 . 27298) (GETSTREAMPROP 27300 . 27769) (PUTSTREAMPROP
27771 . 30180) (STREAMP 30182 . 30330)) (30375 32894 (\DEFPRINT.BY.NAME 30385 . 31537) (
\STREAM.DEFPRINT 31539 . 32587) (\FDEV.DEFPRINT 32589 . 32892)) (33152 38193 (\GETACCESS 33162 . 33616
) (\SETACCESS 33618 . 38191)) (58354 64323 (\DEFINEDEVICE 58364 . 60680) (\GETDEVICEFROMNAME 60682 .
61155) (\GETDEVICEFROMHOSTNAME 61157 . 62201) (\REMOVEDEVICE 62203 . 63326) (\REMOVEDEVICE.NAMES 63328
. 64321)) (64363 88640 (\CLOSEFILE 64373 . 65198) (\DELETEFILE 65200 . 65494) (\DEVICEEVENT 65496 .
67266) (\GENERATEFILES 67268 . 67746) (\GENERATENEXTFILE 67748 . 68399) (\GENERATEFILEINFO 68401 .
68862) (\GETFILENAME 68864 . 69253) (\GENERIC.OUTFILEP 69255 . 69725) (\OPENFILE 69727 . 72305) (
\DO.PARAMS.AT.OPEN 72307 . 74477) (\RENAMEFILE 74479 . 74903) (\REVALIDATEFILE 74905 . 77507) (
\PAGED.REVALIDATEFILELST 77509 . 79067) (\PAGED.REVALIDATEFILES 79069 . 80788) (\PAGED.REVALIDATEFILE
80790 . 83073) (\BUFFERED.REVALIDATEFILE 83075 . 85361) (\BUFFERED.REVALIDATEFILELST 85363 . 86547) (
\PRINT-REVALIDATION-RESULT 86549 . 86964) (\TRUNCATEFILE 86966 . 87357) (\FILE-CONFLICT 87359 . 88638)
) (88676 93339 (\GENERATENOFILES 88686 . 90782) (\NULLFILEGENERATOR 90784 . 91028) (\NOFILESNEXTFILEFN
91030 . 93021) (\NOFILESINFOFN 93023 . 93337)) (93458 95366 (\FILE.NOT.OPEN 93468 . 93981) (
\FILE.WONT.OPEN 93983 . 94311) (\ILLEGAL.DEVICEOP 94313 . 94595) (\IS.NOT.RANDACCESSP 94597 . 95043) (
\STREAM.NOT.OPEN 95045 . 95364)) (95501 97799 (\FDEVINSTANCE 95511 . 97797)) (99001 106375 (CNDIR
99011 . 100316) (DIRECTORYNAME 100318 . 104501) (DIRECTORYNAMEP 104503 . 105119) (HOSTNAMEP 105121 .
105928) (\ADD.CONNECTED.DIR 105930 . 106373)) (106420 134300 (\BACKFILEPTR 106430 . 106618) (
\BACKPEEKBIN 106620 . 106981) (\BACKBIN 106983 . 107334) (BIN 107336 . 107553) (\BIN 107555 . 107832)
(\BINS 107834 . 108120) (BOUT 108122 . 108484) (\BOUT 108486 . 108801) (\BOUTS 108803 . 109114) (
COPYBYTES 109116 . 112448) (COPYCHARS 112450 . 116116) (COPYFILE 116118 . 116915) (\COPYOPENFILE
116917 . 119990) (\INFER.FILE.TYPE 119992 . 120946) (EOFP 120948 . 121245) (FORCEOUTPUT 121247 .
121494) (\FLUSH.OPEN.STREAMS 121496 . 121852) (CHARSET 121854 . 123518) (ACCESS-CHARSET 123520 .
123737) (GETEOFPTR 123739 . 123989) (GETFILEINFO 123991 . 127184) (\TYPE.FROM.FILETYPE 127186 . 127656
) (\FILETYPE.FROM.TYPE 127658 . 127837) (GETFILEPTR 127839 . 128091) (SETFILEINFO 128093 . 132199) (
SETFILEPTR 132201 . 133920) (BOUT16 133922 . 134107) (BIN16 134109 . 134298)) (134403 139608 (
\GENERIC.BINS 134413 . 134693) (\GENERIC.BOUTS 134695 . 134960) (\GENERIC.RENAMEFILE 134962 . 136793)
(\GENERIC.OPENP 136795 . 138110) (\GENERIC.READP 138112 . 139153) (\GENERIC.CHARSET 139155 . 139606))
(139609 139948 (\MAP-OPEN-STREAMS 139619 . 139946)) (141732 143812 (\EOF.ACTION 141742 . 141993) (
\EOSERROR 141995 . 142188) (\GETEOFPTR 142190 . 142372) (\INCFILEPTR 142374 . 142724) (\PEEKBIN 142726
. 142917) (\SETCLOSEDFILELENGTH 142919 . 143253) (\SETEOFPTR 143255 . 143443) (\SETFILEPTR 143445 .
143810)) (143813 144355 (\FIXPOUT 143823 . 144123) (\FIXPIN 144125 . 144353)) (144356 144922 (\BOUTEOL
144366 . 144920)) (147818 157682 (\BUFFERED.BIN 147828 . 148680) (\BUFFERED.PEEKBIN 148682 . 149464)
(\BUFFERED.BOUT 149466 . 150326) (\BUFFERED.BINS 150328 . 154013) (\BUFFERED.BOUTS 154015 . 155816) (
\BUFFERED.COPYBYTES 155818 . 157680)) (157711 160063 (\NULLDEVICE 157721 . 159739) (\NULL.OPENFILE
159741 . 160061)))))
STOP

BIN
sources/FILEIO.LCOM
View File

Binary file not shown.

526
sources/LLCHAR
View File

@ -1,9 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Jun-2021 18:08:19" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;6 108072
previous date%: "19-Jun-2021 10:00:42"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;5)
(FILECREATED " 8-Jan-2022 19:08:41" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;8 106473
:CHANGES-TO (FNS STRING.EQUAL)
:PREVIOUS-DATE "21-Jun-2021 18:08:19"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;6)
(* ; "
@ -18,8 +20,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE GLC GLCCODE STREQUAL
STRING.EQUAL STRINGP CHCON1 U-CASE L-CASE U-CASEP \SMASHABLESTRING \MAKEWRITABLESTRING
\SMASHSTRING \FATTENSTRING)
(COMS (* ;
 "Temporary until low level system is changed to call STRING.EQUAL again")
(COMS (* ;
 "Temporary until low level system is changed to call STRING.EQUAL again")
(P (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T)
(MOVD? 'STRING.EQUAL 'CL::SIMPLE-STRING-EQUAL NIL T)))
(FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString)
@ -30,11 +32,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(MACROS \PNAMESTRINGPUTCHAR)
(OPTIMIZERS FCHARACTER)
(I.S.OPRS inpname inatom instring)
(* ;
 "For use when the inner-loop test in the generic operators is too expensive")
(* ;
 "For use when the inner-loop test in the generic operators is too expensive")
(I.S.OPRS infatatom inthinatom infatstring inthinstring)
(MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP)
(* ; "For benefit of Masterscope")
(* ; "For benefit of Masterscope")
(MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN)
(MACROS \PUTBASECHAR \GETBASECHAR)
(MACROS \CHARSET \CHAR8CODE)
@ -48,7 +50,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
(P (MOVD? 'CHARACTER 'FCHARACTER NIL T))
[COMS (FNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
(* ; "For MAKEINIT")
(* ; "For MAKEINIT")
(DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY
%%COPY-STRING-TO-ARRAY))
(* "So %%COPY-ONED-ARRAY will compile properly")
@ -59,7 +61,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY]
(DECLARE%: DONTCOPY EVAL@COMPILE (LOCALVARS . T))
(* ;; "Arrange for the proper compiler")
(* ;; "Arrange for the proper compiler")
(PROP FILETYPE LLCHAR)))
(DEFINEQ
@ -966,10 +968,14 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(GO SLOWLP])
(STRING.EQUAL
[LAMBDA (X Y) (* ;
 "Edited 12-Jan-94 10:01 by sybalsky:mv:envos")
[LAMBDA (X Y CASEARRAY) (* ; "Edited 8-Jan-2022 19:08 by rmk")
(* ;
 "Edited 12-Jan-94 10:01 by sybalsky:mv:envos")
(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case")
(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case.")
(* ;;
 "RMK: Added CASEARRAY argument, silly not to extend this to other than the default UPPERCASEARRAY.")
(PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2)
(COND
@ -1012,28 +1018,32 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(SETQ OFFSETY (ffetch (STRINGP OFFST) of Y))
(SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
(T (RETURN NIL)))
(CL:UNLESS CASEARRAY (SETQ CASEARRAY UPPERCASEARRAY))
[COND
((NEQ (ffetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY 'ARRAYP))
\ST.BYTE) (* ;
 "Someone smashed UPPERCASEARRAY ?")
(SETQ UPPERCASEARRAY (UPPERCASEARRAY]
(SETQ CABASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY))
((NEQ (ffetch (ARRAYP TYP) of (\DTEST CASEARRAY 'ARRAYP))
\ST.BYTE)
(IF (EQ CASEARRAY UPPERCASEARRAY)
THEN
(* ;; "Did someone smashed the UPPERCASEARRAY? We can repair it")
(SETQ CASEARRAY (SETQ UPPERCASEARRAY (UPPERCASEARRAY)))
ELSE (\ILLEGAL.ARG CASEARRAY]
(SETQ CABASE (ffetch (ARRAYP BASE) of CASEARRAY))
(RETURN (COND
[(OR FATPX FATPY) (* ; "Slow case")
(for BNX from OFFSETX as BNY from OFFSETY as I to
LEN
[(OR FATPX FATPY) (* ; "Slow case")
(for BNX from OFFSETX as BNY from OFFSETY as I to LEN
always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX))
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
(COND
((OR (IGREATERP C1 \MAXTHINCHAR)
(IGREATERP C2 \MAXTHINCHAR))
(* ; "Fat chars not alphabetic")
(EQ C1 C2))
(T (EQ (\GETBASEBYTE CABASE C1)
(\GETBASEBYTE CABASE C2]
(T (for BNX from OFFSETX as BNY from OFFSETY as I
to LEN always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
(COND
((OR (IGREATERP C1 \MAXTHINCHAR)
(IGREATERP C2 \MAXTHINCHAR))
(* ; "Fat chars not alphabetic")
(EQ C1 C2))
(T (EQ (\GETBASEBYTE CABASE C1)
(\GETBASEBYTE CABASE C2]
(T (for BNX from OFFSETX as BNY from OFFSETY as I to LEN
always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
(STRINGP
[LAMBDA (OBJECT) (* jop%: "24-Sep-86 22:58")
@ -1374,141 +1384,136 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(ACCESSFNS STRINGP ((XREADONLY (fetch (ARRAY-HEADER READ-ONLY-P) of DATUM)
(replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE
))
(XBASE ([OPENLAMBDA (STRING)
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%ARRAY-BASE STRING))
(T (fetch (ARRAY-HEADER BASE) of STRING]
DATUM)
((OPENLAMBDA (STRING NV)
(replace (ARRAY-HEADER INDIRECT-P) of STRING with
NIL)
(replace (ARRAY-HEADER BASE) of STRING with NV)
NV)
DATUM NEWVALUE))
(TYP ((OPENLAMBDA (STRING)
(SELECTC (COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%ARRAY-TYPE-NUMBER STRING))
(T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING)))
(%%THIN-CHAR-TYPENUMBER
\ST.BYTE)
(%%FAT-CHAR-TYPENUMBER
\ST.POS16)
(SHOULDNT "Unknown type-number")))
DATUM)
([OPENLAMBDA (STRING NV)
(LET [(%%NEW-TYPE-NUMBER (SELECTC NV
(\ST.BYTE %%THIN-CHAR-TYPENUMBER)
(\ST.POS16 %%FAT-CHAR-TYPENUMBER)
(SHOULDNT "Unknown typ value"]
(COND
(replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE))
(XBASE ([OPENLAMBDA (STRING)
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%ARRAY-BASE STRING))
(T (fetch (ARRAY-HEADER BASE) of STRING]
DATUM)
((OPENLAMBDA (STRING NV)
(replace (ARRAY-HEADER INDIRECT-P) of STRING with NIL)
(replace (ARRAY-HEADER BASE) of STRING with NV)
NV)
DATUM NEWVALUE))
(TYP ((OPENLAMBDA (STRING)
(SELECTC (COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
(T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING
with %%NEW-TYPE-NUMBER]
DATUM NEWVALUE))
(LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
((OPENLAMBDA (STRING NV)
(replace (ARRAY-HEADER FILL-POINTER) of STRING with
NV)
(replace (ARRAY-HEADER TOTAL-SIZE) of STRING with
NV)
[COND
((%%GENERAL-ARRAY-P STRING)
(freplace (GENERAL-ARRAY DIMS) of STRING
with (LIST NV]
NV)
DATUM NEWVALUE))
(OFFST ([OPENLAMBDA (STRING)
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%ARRAY-OFFSET STRING))
(T (fetch (ARRAY-HEADER OFFSET) of STRING]
DATUM)
([OPENLAMBDA (STRING NV)
(COND
((NOT (EQ 0 NV))
(replace (ARRAY-HEADER DISPLACED-P) of STRING
with T)))
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%SET-ARRAY-OFFSET STRING NV))
(T (replace (ARRAY-HEADER OFFSET) of STRING with
NV]
DATUM NEWVALUE))
(%%ARRAY-TYPE-NUMBER STRING))
(T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING)))
(%%THIN-CHAR-TYPENUMBER
\ST.BYTE)
(%%FAT-CHAR-TYPENUMBER
\ST.POS16)
(SHOULDNT "Unknown type-number")))
DATUM)
([OPENLAMBDA (STRING NV)
(LET [(%%NEW-TYPE-NUMBER (SELECTC NV
(\ST.BYTE %%THIN-CHAR-TYPENUMBER)
(\ST.POS16 %%FAT-CHAR-TYPENUMBER)
(SHOULDNT "Unknown typ value"]
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
(T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING with
%%NEW-TYPE-NUMBER
]
DATUM NEWVALUE))
(LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
((OPENLAMBDA (STRING NV)
(replace (ARRAY-HEADER FILL-POINTER) of STRING with NV)
(replace (ARRAY-HEADER TOTAL-SIZE) of STRING with NV)
[COND
((%%GENERAL-ARRAY-P STRING)
(freplace (GENERAL-ARRAY DIMS) of STRING with (LIST NV]
NV)
DATUM NEWVALUE))
(OFFST ([OPENLAMBDA (STRING)
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%ARRAY-OFFSET STRING))
(T (fetch (ARRAY-HEADER OFFSET) of STRING]
DATUM)
([OPENLAMBDA (STRING NV)
(COND
((NOT (EQ 0 NV))
(replace (ARRAY-HEADER DISPLACED-P) of STRING with T)))
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%SET-ARRAY-OFFSET STRING NV))
(T (replace (ARRAY-HEADER OFFSET) of STRING with NV]
DATUM NEWVALUE))
(* ;; "The rest of these fields only appear when smashing")
(* ;; "The rest of these fields only appear when smashing")
(XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
15)
((OPENLAMBDA (STRING)
(replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with
NIL)
(replace (ARRAY-HEADER DISPLACED-P) of STRING with
NIL)
(replace (ARRAY-HEADER FILL-POINTER-P) of STRING
with NIL)
(replace (ARRAY-HEADER EXTENDABLE-P) of STRING with
NIL))
DATUM)))
[ACCESSFNS STRINGP
((ORIG ((OPENLAMBDA (STRING)
1)
DATUM)
((OPENLAMBDA (STRING NV)
(COND
((NOT (EQ NV 1))
(ERROR "Il:stringp's are always origin 1")))
NV)
DATUM NEWVALUE)) (* ; "An inoperative field")
(SUBSTRINGED ((OPENLAMBDA (STRING)
NIL)
DATUM)
((OPENLAMBDA (STRING NV)
(OR (NULL NV)
(ERROR "Substringed field not supported")))
DATUM NEWVALUE))
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
(freplace (STRINGP XREADONLY) of DATUM with
NEWVALUE))
(FATSTRINGP ((OPENLAMBDA (STRING)
(EQ (COND
((fetch (ARRAY-HEADER INDIRECT-P)
of STRING)
(%%ARRAY-TYPE-NUMBER STRING))
(T (fetch (ARRAY-HEADER TYPE-NUMBER)
of STRING)))
%%FAT-CHAR-TYPENUMBER))
DATUM)
([OPENLAMBDA (STRING NV)
(LET [(%%NEW-TYPE-NUMBER (COND
(NV %%FAT-CHAR-TYPENUMBER)
(T %%THIN-CHAR-TYPENUMBER]
(COND
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
(T (replace (ARRAY-HEADER TYPE-NUMBER)
of STRING with %%NEW-TYPE-NUMBER]
DATUM NEWVALUE))
(BASE (ffetch (STRINGP XBASE) of DATUM)
(freplace (STRINGP XBASE) of DATUM with NEWVALUE]
(CREATE (create ONED-ARRAY
BASE _ XBASE
READ-ONLY-P _ XREADONLY
STRING-P _ T
DISPLACED-P _ (NOT (EQ OFFST 0))
TYPE-NUMBER _ (COND
((EQ TYP \ST.POS16)
%%FAT-CHAR-TYPENUMBER)
(T %%THIN-CHAR-TYPENUMBER))
OFFSET _ OFFST
FILL-POINTER _ LENGTH
TOTAL-SIZE _ LENGTH))
(TYPE? (CL:STRINGP DATUM))
OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
(XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
15)
((OPENLAMBDA (STRING)
(replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with NIL)
(replace (ARRAY-HEADER DISPLACED-P) of STRING with NIL)
(replace (ARRAY-HEADER FILL-POINTER-P) of STRING with NIL)
(replace (ARRAY-HEADER EXTENDABLE-P) of STRING with NIL))
DATUM)))
[ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING)
1)
DATUM)
((OPENLAMBDA (STRING NV)
(COND
((NOT (EQ NV 1))
(ERROR "Il:stringp's are always origin 1")))
NV)
DATUM NEWVALUE))
(* ; "An inoperative field")
(SUBSTRINGED ((OPENLAMBDA (STRING)
NIL)
DATUM)
((OPENLAMBDA (STRING NV)
(OR (NULL NV)
(ERROR "Substringed field not supported")))
DATUM NEWVALUE))
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
(freplace (STRINGP XREADONLY) of DATUM with NEWVALUE))
(FATSTRINGP ((OPENLAMBDA (STRING)
(EQ (COND
((fetch (ARRAY-HEADER INDIRECT-P)
of STRING)
(%%ARRAY-TYPE-NUMBER STRING))
(T (fetch (ARRAY-HEADER TYPE-NUMBER)
of STRING)))
%%FAT-CHAR-TYPENUMBER))
DATUM)
([OPENLAMBDA (STRING NV)
(LET [(%%NEW-TYPE-NUMBER (COND
(NV
%%FAT-CHAR-TYPENUMBER
)
(T
%%THIN-CHAR-TYPENUMBER
]
(COND
((fetch (ARRAY-HEADER INDIRECT-P)
of STRING)
(%%SET-ARRAY-TYPE-NUMBER STRING
%%NEW-TYPE-NUMBER))
(T (replace (ARRAY-HEADER TYPE-NUMBER)
of STRING with %%NEW-TYPE-NUMBER]
DATUM NEWVALUE))
(BASE (ffetch (STRINGP XBASE) of DATUM)
(freplace (STRINGP XBASE) of DATUM with NEWVALUE]
(CREATE (create ONED-ARRAY
BASE _ XBASE
READ-ONLY-P _ XREADONLY
STRING-P _ T
DISPLACED-P _ (NOT (EQ OFFST 0))
TYPE-NUMBER _ (COND
((EQ TYP \ST.POS16)
%%FAT-CHAR-TYPENUMBER)
(T %%THIN-CHAR-TYPENUMBER))
OFFSET _ OFFST
FILL-POINTER _ LENGTH
TOTAL-SIZE _ LENGTH))
(TYPE? (CL:STRINGP DATUM))
OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
@ -1531,27 +1536,25 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE)
(* ;
 "For stuffing chars into resource \PNAMESTRING")
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* ;
 "For stuffing chars into resource \PNAMESTRING")
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
)
(DEFOPTIMIZER FCHARACTER (NUM)
`([OPENLAMBDA (N)
(COND
((IGREATERP N \MAXTHINCHAR)
(* ;
 "The character we're getting is NOT a thin character -- do it the hard way")
(CHARACTER N))
((IGREATERP N (CHARCODE 9))
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
((IGEQ N (CHARCODE 0))
(IDIFFERENCE N (CHARCODE 0)))
(T (* ;
 "The common case -- just add on the one-atom base.")
(\ADDBASE \OneCharAtomBase N]
,NUM))
`([OPENLAMBDA (N)
(COND
((IGREATERP N \MAXTHINCHAR) (* ;
 "The character we're getting is NOT a thin character -- do it the hard way")
(CHARACTER N))
((IGREATERP N (CHARCODE 9))
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
((IGEQ N (CHARCODE 0))
(IDIFFERENCE N (CHARCODE 0)))
(T (* ;
 "The common case -- just add on the one-atom base.")
(\ADDBASE \OneCharAtomBase N]
,NUM))
(DECLARE%: EVAL@COMPILE
(I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET)
@ -1563,30 +1566,26 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
`(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET)
first [PROG NIL
$$RETRY
(COND
((STRINGP $$BODY)
(SETQ $$BASE (ffetch (STRINGP BASE)
of $$BODY))
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP
OFFST)
of $$BODY)))
(SETQ $$END (IPLUS $$OFFSET (ffetch
(STRINGP
LENGTH)
of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP
FATSTRINGP)
of $$BODY)))
((LITATOM $$BODY)
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
of $$BODY)))
(T (SETQ $$BODY (MKSTRING $$BODY))
(GO $$RETRY]
$$RETRY
(COND
((STRINGP $$BODY)
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH
)
of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
of $$BODY)))
((LITATOM $$BODY)
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
of $$BODY)))
(T (SETQ $$BODY (MKSTRING $$BODY))
(GO $$RETRY]
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
@ -1603,10 +1602,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(GETDUMMYVAR))
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY
))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)
)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
@ -1624,13 +1621,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(GETDUMMYVAR))
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP)
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
of $$BODY)))
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
of $$BODY))
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
@ -1648,10 +1643,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(GETDUMMYVAR))
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
@ -1665,10 +1658,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(GETDUMMYVAR))
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
of $$BASE))
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
(GO $$OUT))
@ -1682,12 +1673,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(GETDUMMYVAR))
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY
))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
LENGTH)
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
of $$BODY)))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
@ -1703,11 +1691,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE) of
$$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
LENGTH)
of $$BODY)))
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
of $$BODY)))
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
(AND (IGREATERP $$OFFSET $$END)
@ -1717,20 +1703,20 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ;
 "used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
(AND (SMALLP X)
(IGEQ X 0))))
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ;
 "used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
(AND (SMALLP X)
(IGEQ X 0))))
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ;
 "Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
(AND (SMALLP X)
(IGREATERP X \MAXTHINCHAR))))
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ;
 "Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
(AND (SMALLP X)
(IGREATERP X \MAXTHINCHAR))))
(PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0)
(ILEQ X \MAXTHINCHAR))))
(AND (SMALLP X)
(IGEQ X 0)
(ILEQ X \MAXTHINCHAR))))
)
(DECLARE%: EVAL@COMPILE
@ -1745,22 +1731,22 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE
(PUTPROPS \PUTBASECHAR MACRO [OPENLAMBDA (FATP BASE OFFSET CODE)
(COND
(FATP (\PUTBASEFAT BASE OFFSET CODE))
(T (\PUTBASETHIN BASE OFFSET CODE])
(COND
(FATP (\PUTBASEFAT BASE OFFSET CODE))
(T (\PUTBASETHIN BASE OFFSET CODE])
(PUTPROPS \GETBASECHAR MACRO [(FATP BASE N)
(COND
(FATP (\GETBASEFAT BASE N))
(T (\GETBASETHIN BASE N])
(COND
(FATP (\GETBASEFAT BASE N))
(T (\GETBASETHIN BASE N])
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS \CHARSET MACRO ((CHARCODE)
(LRSH CHARCODE 8)))
(LRSH CHARCODE 8)))
(PUTPROPS \CHAR8CODE MACRO ((CHARCODE)
(LOGAND CHARCODE 255)))
(LOGAND CHARCODE 255)))
)
(DECLARE%: EVAL@COMPILE
@ -1787,10 +1773,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE
(PUTPROPS \NATOMCHARS DMACRO ((AT)
(fetch (LITATOM PNAMELENGTH) of AT)))
(fetch (LITATOM PNAMELENGTH) of AT)))
(PUTPROPS \NSTRINGCHARS DMACRO ((S)
(fetch (STRINGP LENGTH) of S)))
(fetch (STRINGP LENGTH) of S)))
)
(* "END EXPORTED DEFINITIONS")
@ -1866,10 +1852,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(ADDTOVAR INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY))
(ADDTOVAR INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
CMLARRAY-SUPPORT))
CMLARRAY-SUPPORT))
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN
\GETBASEFAT \PUTBASECHAR)
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT
\PUTBASECHAR)
(ADDTOVAR DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
)
@ -1889,16 +1875,16 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
(PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994
2018 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3970 73876 (ALLOCSTRING 3980 . 6003) (MKATOM 6005 . 6640) (SUBATOM 6642 . 8512) (
CHARACTER 8514 . 9518) (\PARSE.NUMBER 9520 . 25240) (\INVALID.DOTTED.SYMBOL 25242 . 25737) (
\INVALID.INTEGER 25739 . 27191) (\MKINTEGER 27193 . 29900) (MKSTRING 29902 . 32045) (
\PRINDATUM.TO.STRING 32047 . 38225) (BKSYSBUF 38227 . 39761) (NCHARS 39763 . 41463) (NTHCHARCODE 41465
. 43511) (RPLCHARCODE 43513 . 44574) (\RPLCHARCODE 44576 . 46111) (NTHCHAR 46113 . 46306) (RPLSTRING
46308 . 49519) (SUBSTRING 49521 . 52444) (GNC 52446 . 52619) (GNCCODE 52621 . 53389) (GLC 53391 .
53564) (GLCCODE 53566 . 54331) (STREQUAL 54333 . 56447) (STRING.EQUAL 56449 . 60507) (STRINGP 60509 .
60660) (CHCON1 60662 . 61449) (U-CASE 61451 . 64678) (L-CASE 64680 . 68540) (U-CASEP 68542 . 69116) (
\SMASHABLESTRING 69118 . 69580) (\MAKEWRITABLESTRING 69582 . 70018) (\SMASHSTRING 70020 . 73726) (
\FATTENSTRING 73728 . 73874)) (74061 79223 (\GETBASESTRING 74071 . 74725) (\PUTBASESTRING 74727 .
77466) (\PUTBASESTRINGFAT 77468 . 78214) (GetBcplString 78216 . 78881) (SetBcplString 78883 . 79221))
(104450 107264 (%%COPY-ONED-ARRAY 104460 . 106310) (%%COPY-STRING-TO-ARRAY 106312 . 107262)))))
(FILEMAP (NIL (4009 74195 (ALLOCSTRING 4019 . 6042) (MKATOM 6044 . 6679) (SUBATOM 6681 . 8551) (
CHARACTER 8553 . 9557) (\PARSE.NUMBER 9559 . 25279) (\INVALID.DOTTED.SYMBOL 25281 . 25776) (
\INVALID.INTEGER 25778 . 27230) (\MKINTEGER 27232 . 29939) (MKSTRING 29941 . 32084) (
\PRINDATUM.TO.STRING 32086 . 38264) (BKSYSBUF 38266 . 39800) (NCHARS 39802 . 41502) (NTHCHARCODE 41504
. 43550) (RPLCHARCODE 43552 . 44613) (\RPLCHARCODE 44615 . 46150) (NTHCHAR 46152 . 46345) (RPLSTRING
46347 . 49558) (SUBSTRING 49560 . 52483) (GNC 52485 . 52658) (GNCCODE 52660 . 53428) (GLC 53430 .
53603) (GLCCODE 53605 . 54370) (STREQUAL 54372 . 56486) (STRING.EQUAL 56488 . 60826) (STRINGP 60828 .
60979) (CHCON1 60981 . 61768) (U-CASE 61770 . 64997) (L-CASE 64999 . 68859) (U-CASEP 68861 . 69435) (
\SMASHABLESTRING 69437 . 69899) (\MAKEWRITABLESTRING 69901 . 70337) (\SMASHSTRING 70339 . 74045) (
\FATTENSTRING 74047 . 74193)) (74380 79542 (\GETBASESTRING 74390 . 75044) (\PUTBASESTRING 75046 .
77785) (\PUTBASESTRINGFAT 77787 . 78533) (GetBcplString 78535 . 79200) (SetBcplString 79202 . 79540))
(102859 105673 (%%COPY-ONED-ARRAY 102869 . 104719) (%%COPY-STRING-TO-ARRAY 104721 . 105671)))))
STOP

BIN
sources/LLCHAR.LCOM
View File

Binary file not shown.

65
sources/PRETTY
View File

@ -1,10 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-Nov-2021 22:18:04" {DSK}<home>larry>medley>sources>PRETTY.;2 65400
(FILECREATED "19-Jan-2022 20:35:18" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>PRETTY.;23 65357
:CHANGES-TO (FNS PRINTDATE1)
:CHANGES-TO (FNS PRINTDEF1)
:PREVIOUS-DATE "11-Sep-2021 09:14:19" {DSK}<home>larry>medley>sources>PRETTY.;1)
:PREVIOUS-DATE "30-Nov-2021 22:18:04"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>PRETTY.;21)
(* ; "
@ -89,7 +90,7 @@ with the terms of said license.
PRETTYCOMFONT COMMENTFONT
**COMMENT**FLG PRETTYPRINTMACROS]
(DECLARE%: DOEVAL@COMPILE DONTCOPY (* ;
 "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES")
 "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES")
(FILES (IMPORT)
FILEPKG))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP)
@ -418,24 +419,30 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
)
(PRINTDEF1
[LAMBDA (EXPR FORMFLG) (* ; "Edited 16-Apr-2018 21:35 by rmk:")
(* ; "Edited 16-Apr-2018 10:14 by rmk:")
(* ; "Edited 14-Apr-88 18:21 by bvm")
[LAMBDA (EXPR FORMFLG)
(* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS")
(* ;; "Edited 19-Jan-2022 20:35 by rmk: Added DEFMACRO")
(* ;; "Used by MAKEFILE to print P, etc expressions. ")
(* ;; "Edited 16-Apr-2018 21:35 by rmk:")
(* ;; "Edited 16-Apr-2018 10:14 by rmk:")
(* ;; "Edited 14-Apr-88 18:21 by bvm")
(* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS")
(* ;; "Used by MAKEFILE to print P, etc expressions. ")
(TERPRI)
(LET (STARTPOS ENDPOS)
(IF (AND FORMFLG NEWFILEMAP (EQ (CAR EXPR)
'CL:DEFUN))
(IF [AND FORMFLG NEWFILEMAP (MEMB (CAR EXPR)
'(CL:DEFUN DEFMACRO)]
THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE)))
(PRINTDEF EXPR NIL FORMFLG NIL FNSLST)
[IF STARTPOS
THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE))
(NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR)
(CONS STARTPOS ENDPOS]
(NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR)
(CONS STARTPOS ENDPOS]
(TERPRI])
(SUPERPRINTEQ
@ -629,8 +636,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
(RPAQ? COPYRIGHTSRESERVED T)
(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
:XCCS))
(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
:XCCS))
(RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* )
(DECLARE%: DOEVAL@COMPILE DONTCOPY
@ -658,8 +665,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
(RPAQ? PRETTYTABFLG T)
(RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY
DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN
EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST))
DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD
EVAL@LOADWHEN FIRST NOTFIRST))
(RPAQ? AVERAGEVARLENGTH 4)
@ -679,8 +686,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
(RPAQ? PRETTYPRINTYPEMACROS )
(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS
ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *))
(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS
APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *))
(RPAQ? SYSPROPS
'(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE
@ -722,14 +729,14 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
(PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018
))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (5881 48457 (PRETTYDEF 5891 . 21564) (PRETTYDEFCOMS 21566 . 22248) (PRETTYDEF0 22250 .
22441) (PRETTYDEF1 22443 . 24206) (PRINTDATE 24208 . 25444) (PRINTDATE1 25446 . 27076) (PRINTFNS 27078
. 27647) (PRETTYCOM 27649 . 33990) (PRETTYVAR 33992 . 35030) (PRETTYVAR1 35032 . 37250) (PRETTYCOM1
37252 . 37956) (ENDFILE 37958 . 38054) (MAKEDEFLIST 38056 . 38460) (PP 38462 . 38738) (PP* 38740 .
39053) (PPT 39055 . 39374) (PRETTYPRINT 39376 . 42528) (PRETTYPRINT1 42530 . 44416) (PRETTYPRINT2
44418 . 45734) (PRETTYPRINT3 45736 . 46691) (PRINTDEF1 46693 . 47701) (SUPERPRINTEQ 47703 . 47797) (
SUPERPRINTGETPROP 47799 . 47943) (CHANGEFONT 47945 . 48455)) (48458 53804 (READARRAY 48468 . 49394) (
PRINTARRAY 49396 . 51136) (READARRAY-FROM-LIST 51138 . 52243) (PRINTARRAY-TO-LIST 52245 . 53802)) (
53931 61449 (PRINTCOPYRIGHT 53941 . 58018) (PRINTCOPYRIGHT1 58020 . 61144) (SAVECOPYRIGHT 61146 .
61447)))))
(FILEMAP (NIL (5927 48431 (PRETTYDEF 5937 . 21610) (PRETTYDEFCOMS 21612 . 22294) (PRETTYDEF0 22296 .
22487) (PRETTYDEF1 22489 . 24252) (PRINTDATE 24254 . 25490) (PRINTDATE1 25492 . 27122) (PRINTFNS 27124
. 27693) (PRETTYCOM 27695 . 34036) (PRETTYVAR 34038 . 35076) (PRETTYVAR1 35078 . 37296) (PRETTYCOM1
37298 . 38002) (ENDFILE 38004 . 38100) (MAKEDEFLIST 38102 . 38506) (PP 38508 . 38784) (PP* 38786 .
39099) (PPT 39101 . 39420) (PRETTYPRINT 39422 . 42574) (PRETTYPRINT1 42576 . 44462) (PRETTYPRINT2
44464 . 45780) (PRETTYPRINT3 45782 . 46737) (PRINTDEF1 46739 . 47675) (SUPERPRINTEQ 47677 . 47771) (
SUPERPRINTGETPROP 47773 . 47917) (CHANGEFONT 47919 . 48429)) (48432 53778 (READARRAY 48442 . 49368) (
PRINTARRAY 49370 . 51110) (READARRAY-FROM-LIST 51112 . 52217) (PRINTARRAY-TO-LIST 52219 . 53776)) (
53905 61423 (PRINTCOPYRIGHT 53915 . 57992) (PRINTCOPYRIGHT1 57994 . 61118) (SAVECOPYRIGHT 61120 .
61421)))))
STOP

BIN
sources/PRETTY.LCOM
View File

Binary file not shown.

523
sources/UFS
View File

@ -1,10 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Apr-2021 11:36:54" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>UFS.;5 69271
changes to%: (FNS \UFSeol)
(FILECREATED "22-Jan-2022 09:06:35" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>UFS.;4 79559
previous date%: "20-Apr-2021 12:11:36"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>UFS.;4)
:CHANGES-TO (FNS \UFSGenerateFiles \UFS.NEXTFILEFN)
:PREVIOUS-DATE "22-Jan-2022 08:36:27"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>UFS.;3)
(* ; "
@ -19,7 +20,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
DIRECTORY FILEIO))
(INITVARS (\UFS.DEFAULT.EOLC NIL))
(COMS (* ; "Create FDEV function.")
(COMS (* ; "Create FDEV function.")
(FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice)
(INITVARS (\UFSdevice)
(\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor")))
@ -27,15 +28,14 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE)))
(INITRECORDS UFSGENFILESTATE)
(SYSRECORDS UFSGENFILESTATE))
(COMS (* ;
 "UNIX File System's FDEV methods.")
(COMS (* ; "UNIX File System's FDEV methods.")
(FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile
\UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages
\UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS
\UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP
\UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY
\UFS.CLEANUP.GFS.TABLE))
(COMS (* ; "File Name parsing")
(COMS (* ; "File Name parsing")
(FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY
\UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD
\UFS.HANDLE.RELATIVEDIRECTORY)
@ -56,22 +56,22 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
\UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE
*DSK-HOST-NAME* *UFS-HOST-NAME*))
(COMS
(* ;; "Change UNIX Curent Directory")
(* ;; "Change UNIX Curent Directory")
(FNS CHDIR)
(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.")
(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.")
(FNS \DEVICEFILE.EOSERROR)
(* ;; "flush/revalidate unvisible stream, like dribble files.")
(* ;; "flush/revalidate unvisible stream, like dribble files.")
(FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS)
(* ;; " Error handler")
(* ;; " Error handler")
(FNS \UFSError))
(COMS (* ; "File Type and EOL handling")
(COMS (* ; "File Type and EOL handling")
(FNS \UFSGetFileType \UFSSetFileType \UFSeol)
[DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY)
(DEFAULTFILETYPELIST '((NIL . BINARY)
@ -110,11 +110,11 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(VM . BINARY]
(GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST))
(DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS))
(COMS (* ; "Filetypepatch functions. ")
(COMS (* ; "Filetypepatch functions. ")
(FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu)
(* ; "for hardcopy")
(* ; "for hardcopy")
(FNS \UFStoOtherCopyMess \UFStoOtherRenameMess)
(* ; "for copyfile,renamefile")
(* ; "for copyfile,renamefile")
(INITVARS (FileTypeConfirmFlg T))
(GLOBALVARS FileTypeMenu FileTypeConfirmFlg))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
@ -166,35 +166,38 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
(DATATYPE UFSGENFILESTATE (
(* ;;
 "Holds the file-directory-generator state for %"Unix%" file system enumeration.")
(* ;;
 "Holds the file-directory-generator state for %"Unix%" file system enumeration.")
(FINFOID FIXP)
(FILEID FIXP) (* ;
 "Current file in list of 1 to TOTALNUM files.")
(TOTALNUM FIXP)
DIRECTORY DEV (PROPP FLAG)
THISFILE
(ERRONO FIXP)
NAME
(LENGTH FIXP)
(WDATE FIXP)
(RDATE FIXP)
(PROTECTION FIXP)
AUTHOR
(AULEN FIXP)
SUBGENERATORS (* ;
"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.")
CURRENT-DEPTH (* ;
 "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH")
MAX-DEPTH (* ;
 "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.")
))
(FINFOID FIXP)
(FILEID FIXP) (* ;
 "Current file in list of 1 to TOTALNUM files.")
(TOTALNUM FIXP)
DIRECTORY DEV (PROPP FLAG)
THISFILE
(ERRONO FIXP)
NAME
(LENGTH FIXP)
(WDATE FIXP)
(RDATE FIXP)
(PROTECTION FIXP)
AUTHOR
(AULEN FIXP)
SUBGENERATORS (* ;
 "A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.")
CURRENT-DEPTH (* ;
 "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH")
MAX-DEPTH (* ;
 "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.")
DEFAULTEXT (* ;
 "Value of DEFAULTEXT, so we can propagate it through subdirectories")
DEFAULTVERS (* ; "Value of DEFAULTVERS")
))
)
(/DECLAREDATATYPE 'UFSGENFILESTATE
'(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP
POINTER POINTER POINTER)
POINTER POINTER POINTER POINTER POINTER)
'((UFSGENFILESTATE 0 FIXP)
(UFSGENFILESTATE 2 FIXP)
(UFSGENFILESTATE 4 FIXP)
@ -212,8 +215,10 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(UFSGENFILESTATE 26 FIXP)
(UFSGENFILESTATE 28 POINTER)
(UFSGENFILESTATE 30 POINTER)
(UFSGENFILESTATE 32 POINTER))
'34)
(UFSGENFILESTATE 32 POINTER)
(UFSGENFILESTATE 34 POINTER)
(UFSGENFILESTATE 36 POINTER))
'38)
(* "END EXPORTED DEFINITIONS")
@ -221,7 +226,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(/DECLAREDATATYPE 'UFSGENFILESTATE
'(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP
POINTER POINTER POINTER)
POINTER POINTER POINTER POINTER POINTER)
'((UFSGENFILESTATE 0 FIXP)
(UFSGENFILESTATE 2 FIXP)
(UFSGENFILESTATE 4 FIXP)
@ -239,24 +244,26 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
(UFSGENFILESTATE 26 FIXP)
(UFSGENFILESTATE 28 POINTER)
(UFSGENFILESTATE 30 POINTER)
(UFSGENFILESTATE 32 POINTER))
'34)
(UFSGENFILESTATE 32 POINTER)
(UFSGENFILESTATE 34 POINTER)
(UFSGENFILESTATE 36 POINTER))
'38)
(ADDTOVAR SYSTEMRECLST
(DATATYPE UFSGENFILESTATE ((FINFOID FIXP)
(FILEID FIXP)
(TOTALNUM FIXP)
DIRECTORY DEV (PROPP FLAG)
THISFILE
(ERRONO FIXP)
NAME
(LENGTH FIXP)
(WDATE FIXP)
(RDATE FIXP)
(PROTECTION FIXP)
AUTHOR
(AULEN FIXP)
SUBGENERATORS CURRENT-DEPTH MAX-DEPTH))
(FILEID FIXP)
(TOTALNUM FIXP)
DIRECTORY DEV (PROPP FLAG)
THISFILE
(ERRONO FIXP)
NAME
(LENGTH FIXP)
(WDATE FIXP)
(RDATE FIXP)
(PROTECTION FIXP)
AUTHOR
(AULEN FIXP)
SUBGENERATORS CURRENT-DEPTH MAX-DEPTH DEFAULTEXT DEFAULTVERS))
)
@ -330,12 +337,244 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
)
(\UFSGenerateFiles
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 27-Sep-93 16:17 by jds") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (DEVICE (LISTGET PARSED (QUOTE DEVICE))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) (SETQ FILTER (COND ((STREQUAL DIRECTORY "<") (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" (OR DEVICE "") "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (T (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE DEVICE) DEVICE (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))))) (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) (COND ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR)))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND ((< TOTALNUM 0) (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR)))) (T (COND ((ZEROP TOTALNUM) (RETURN (\NULLFILEGENERATOR))) (T (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN)) CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH))))))))))))
)
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
(* ;;
 "Edited 22-Jan-2022 09:06 by rmk: Capture current free values of DEFAULTEXT and DEFAULTVERS")
(* ;; "Edited 27-Sep-93 16:17 by jds")
(DECLARE (SPECVARS DEFAULTEXT DEFAULTVERS))
(* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.")
(WITH.MONITOR (\UFSGetMonitor FDEV)
[PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN))
(DIRECTORY (OR (LISTGET PARSED 'DIRECTORY)
(\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY)
FDEV)
(\UFS.DEFAULT.DIR FDEV)))
(DEVICE (LISTGET PARSED 'DEVICE))
(NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
FILTER LEN)
(COND
((STREQUAL DIRECTORY "/")
(SETQ DIRECTORY "<")))
[SETQ FILTER (COND
[(STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME (OR (LISTGET PARSED 'NAME)
"*")
'EXTENSION
(OR (LISTGET PARSED 'EXTENSION)
"*")
'VERSION
(OR (LISTGET PARSED 'VERSION)
"*"]
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
PARSED
'HOST)
'DEVICE DEVICE 'NAME (OR (LISTGET PARSED 'NAME)
"*")
'EXTENSION
(OR (LISTGET PARSED 'EXTENSION)
"*")
'VERSION
(OR (LISTGET PARSED 'VERSION)
"*"]
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
DIRECTORY)
NAMEAREA FDEV))
[COND
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
(RETURN (\NULLFILEGENERATOR]
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
(LET ((ID (CREATECELL \FIXP))
(ERRNO (CREATECELL \FIXP))
(PROPP (\UFS.VALID.PROPP DESIREDPROPS))
TOTALNUM)
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
(COND
[(< TOTALNUM 0)
(OR (\UFSError DIRECTORY ERRNO FDEV)
(RETURN (\NULLFILEGENERATOR]
(T (COND
((ZEROP TOTALNUM)
(RETURN (\NULLFILEGENERATOR)))
(T [AND (OR (AND (NOT (LISTP OPTIONS))
(EQ OPTIONS 'RESETLST))
(FMEMB 'RESETLST OPTIONS))
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
(RETURN (create FILEGENOBJ
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN)
GENFILESTATE _
(\UFS.REGISTER.GFS (create UFSGENFILESTATE
FINFOID _ ID
FILEID _ 0
TOTALNUM _ TOTALNUM
DIRECTORY _ DIRECTORY
DEV _ FDEV
PROPP _ PROPP
NAME _ (ALLOCSTRING
MAX-PATHNAME-LEN
)
AUTHOR _ (AND PROPP
(ALLOCSTRING
MAX-UNAME-LEN
))
CURRENT-DEPTH _ 1
MAX-DEPTH _
FILING.ENUMERATION.DEPTH
DEFAULTEXT _ DEFAULTEXT
DEFAULTVERS _ DEFAULTVERS])])
(\UFS.NEXTFILEFN
(LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE))) (DECLARE (SPECVARS FILEGROUP)) (COND (SUBGEN (* ;; "We're in a sub-directory.") (LET (FILENAME NAMELEN NEWWNAME FILEGROUP) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))))) (T (* ;; "Not in a sub-directory, so act directly on the top-level generator.") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (QUOTE *)) (DEFAULTVERS (QUOTE *)) (DESIREDPROPS (COND ((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (QUOTE (SIZE CREATIONDATE AUTHOR))) (T NIL)))) (DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS)) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (COND ((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))) (COND ((= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T)) (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))) (COND ((AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) T) (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE) (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))) (IEQP (CHARCODE >) (NTHCHARCODE FILENAME (NCHARS FILENAME))) (DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP))) (* ;; "It's a directory, so let's recurse into it.") (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))) (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE))) (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)))) (T (COND (NAMEONLY NEWNAME) (T FILENAME)))))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))))))))
)
[LAMBDA (GENFILESTATE NAMEONLY)
(* ;;
 "Edited 22-Jan-2022 09:05 by rmk: Bind DEFAULTEXT and DEFAULTVERS to values in GENFILESTATE")
(* ;; "Edited 7-Oct-93 14:31 by jds")
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE)))
(DECLARE (SPECVARS FILEGROUP))
(COND
[SUBGEN
(* ;; "We're in a sub-directory.")
(LET (FILENAME NAMELEN NEWWNAME FILEGROUP)
(SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY))
(COND
(FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE)
(replace (UFSGENFILESTATE LENGTH) of GENFILESTATE
with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN))
(replace (UFSGENFILESTATE RDATE) of GENFILESTATE
with (fetch (UFSGENFILESTATE RDATE) of SUBGEN))
(replace (UFSGENFILESTATE WDATE) of GENFILESTATE
with (fetch (UFSGENFILESTATE WDATE) of SUBGEN))
(replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE
with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN))
(replace (UFSGENFILESTATE AULEN) of GENFILESTATE
with (fetch (UFSGENFILESTATE AULEN) of SUBGEN))
(replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE
with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN)))
FILENAME)
(T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL)
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY]
(T
(* ;; "Not in a sub-directory, so act directly on the top-level generator.")
(LET* [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))
(FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE))
(ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE)))
FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (FETCH (UFSGENFILESTATE
DEFAULTEXT)
OF GENFILESTATE))
(DEFAULTVERS (FETCH (UFSGENFILESTATE DEFAULTVERS) OF GENFILESTATE))
(DESIREDPROPS (COND
((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE)
'(SIZE CREATIONDATE AUTHOR))
(T NIL]
(DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS))
(AND (> FINFOID -1)
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(CL:UNWIND-PROTECT
[COND
((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
0)
[replace (UFSGENFILESTATE THISFILE) of GENFILESTATE
with (SETQ FILENAME (\UFS.FULLNAME.M
(fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
(SETQ NEWNAME (CL:SUBSEQ
(fetch (UFSGENFILESTATE
NAME) of
GENFILESTATE
)
0 NAMELEN))
(fetch (UFSGENFILESTATE DEV) of
GENFILESTATE
]
(COND
((= (add FILEID 1)
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
(* ; "Generator exhausted. ")
(\UFS.UNREGISTER.GFS GENFILESTATE T))
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE
with FILEID)))
(COND
[(AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH)
of GENFILESTATE)
T)
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH
) of GENFILESTATE)
(fetch (UFSGENFILESTATE MAX-DEPTH)
of GENFILESTATE)))
(IEQP (CHARCODE >)
(NTHCHARCODE FILENAME (NCHARS FILENAME)))
(DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE)
of GENFILESTATE))
(fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))
(* ;; "It's a directory, so let's recurse into it.")
[replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE
with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE)
of (CAR FILEGROUP]
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH)
of GENFILESTATE)))
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
(SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY))
(COND
(FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP)
of GENFILESTATE)
(replace (UFSGENFILESTATE LENGTH) of
GENFILESTATE
with (fetch (UFSGENFILESTATE LENGTH)
of SUBGEN))
(replace (UFSGENFILESTATE RDATE) of
GENFILESTATE
with (fetch (UFSGENFILESTATE RDATE)
of SUBGEN))
(replace (UFSGENFILESTATE WDATE) of
GENFILESTATE
with (fetch (UFSGENFILESTATE WDATE)
of SUBGEN))
(replace (UFSGENFILESTATE PROTECTION)
of GENFILESTATE with (fetch (
UFSGENFILESTATE
PROTECTION)
of SUBGEN))
(replace (UFSGENFILESTATE AULEN) of
GENFILESTATE
with (fetch (UFSGENFILESTATE AULEN)
of SUBGEN))
(replace (UFSGENFILESTATE AUTHOR) of
GENFILESTATE
with (fetch (UFSGENFILESTATE AUTHOR)
of SUBGEN)))
FILENAME)
(NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of
GENFILESTATE
with NIL)
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY]
(T (COND
(NAMEONLY NEWNAME)
(T FILENAME]
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
(\UFS.FILEINFOFN
(LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T)))))
@ -574,7 +813,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
\UFS.DIRECTORY.RECOGNIZER DSKP)
(RECORDS UFSSTREAM NAME&ALLPROPS)
(* ;; "File attribute code. For interface between Cfunc and LISPfunc.")
(* ;; "File attribute code. For interface between Cfunc and LISPfunc.")
(CONSTANTS (ATTR-LENGTH 1)
(ATTR-WDATE 2)
@ -585,7 +824,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(ATTR-EOL 7)
(ATTR-ALL 8))
(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.")
(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.")
(CONSTANTS (RECOG-OLD 0)
(RECOG-OLDEST 1)
@ -594,7 +833,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(RECOG-OTHER 4)
(RECOG-NON 5))
(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.")
(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.")
(CONSTANTS (ACCESS-INPUT 0)
(ACCESS-OUTPUT 1)
@ -602,95 +841,93 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(ACCESS-APPEND 3)
(ACCESS-OTHER 4))
(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.")
(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.")
(CONSTANTS (MAX-UNAME-LEN 512))
(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.")
(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.")
(CONSTANTS (MAX-PATHNAME-LEN 256))
(FILES (LOADCOMP)
PMAP)
(* ; "For \devicefile.eoserror")))
(* ; "For \devicefile.eoserror")))
(DECLARE%: EVAL@COMPILE
(PUTPROPS \UFS.FULLNAME.M MACRO [LAMBDA (DIR NAME DEV ATOMP)
(DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*))
(DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*))
(* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.")
(* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.")
(COND
(NAME (* ; "Pass NIL thru transparently")
(COND
[(DSKP DEV)
(SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME))
(COND
[*DSK-UPPER-CASE-FILE-NAMES*
(* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.")
(COND
(NAME (* ; "Pass NIL thru transparently")
(COND
[(DSKP DEV)
(SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME))
(COND
[*DSK-UPPER-CASE-FILE-NAMES*
(* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.")
(COND
(ATOMP (MKATOM (U-CASE NAME)))
(T (U-CASE NAME]
(T (COND
(ATOMP (MKATOM NAME))
(T NAME]
(T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME)
)
(COND
(ATOMP (MKATOM NAME))
(T NAME])
(ATOMP (MKATOM (U-CASE NAME)))
(T (U-CASE NAME]
(T (COND
(ATOMP (MKATOM NAME))
(T NAME]
(T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME))
(COND
(ATOMP (MKATOM NAME))
(T NAME])
(PUTPROPS \UFSGetMonitor MACRO ((DEV)
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK \DSKtopMonitor)
(UNIX \UFStopMonitor)
NIL)))
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK \DSKtopMonitor)
(UNIX \UFStopMonitor)
NIL)))
(PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV)
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK \DSK.DEFAULT.DIRECTORY)
(UNIX \UFS.DEFAULT.DIRECTORY)
NIL)))
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK \DSK.DEFAULT.DIRECTORY)
(UNIX \UFS.DEFAULT.DIRECTORY)
NIL)))
(PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV)
(* ;;
 "Return a function that will do name recognition for this device")
(* ;;
 "Return a function that will do name recognition for this device")
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK (FUNCTION \DSKGetFileName-C))
(UNIX (FUNCTION \UFSGetFileName-C))
(FUNCTION SHOULDNT))))
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK (FUNCTION \DSKGetFileName-C))
(UNIX (FUNCTION \UFSGetFileName-C))
(FUNCTION SHOULDNT))))
(PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV)
(SELECTQ (fetch (FDEV DEVICENAME) of
DEV)
(DSK (FUNCTION \DSKDirectoryNameP-C))
(UNIX (FUNCTION \UFSDirectoryNameP-C))
(FUNCTION SHOULDNT))))
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
(DSK (FUNCTION \DSKDirectoryNameP-C))
(UNIX (FUNCTION \UFSDirectoryNameP-C))
(FUNCTION SHOULDNT))))
(PUTPROPS DSKP MACRO ((DEV)
(EQ (fetch (FDEV DEVICENAME) of DEV)
'DSK)))
(EQ (fetch (FDEV DEVICENAME) of DEV)
'DSK)))
)
(DECLARE%: EVAL@COMPILE
(ACCESSFNS UFSSTREAM (
(* ;;
 "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.")
(* ;;
 "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.")
(FILEID (fetch F1 of DATUM)
(REPLACE F1 OF DATUM WITH NEWVALUE))
(* ; "Unix file handle")
(CDATE (fetch F2 of DATUM)
(REPLACE F2 OF DATUM WITH NEWVALUE))
(* ; "IDate given to openstream")
(UNIXNAME (fetch F5 of DATUM)
(REPLACE F5 OF DATUM WITH NEWVALUE))
(* ;
 "The name by which Unix knows this file")
))
(FILEID (fetch F1 of DATUM)
(REPLACE F1 OF DATUM WITH NEWVALUE))
(* ; "Unix file handle")
(CDATE (fetch F2 of DATUM)
(REPLACE F2 OF DATUM WITH NEWVALUE))
(* ; "IDate given to openstream")
(UNIXNAME (fetch F5 of DATUM)
(REPLACE F5 OF DATUM WITH NEWVALUE))
(* ;
 "The name by which Unix knows this file")
))
(RECORD NAME&ALLPROPS (NAME . ALLPROPS))
)
@ -876,23 +1113,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000 2021
))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (8248 9801 (\UFSCreateDevice 8258 . 8623) (\UFS.CREATE.DEVICE 8625 . 9481) (
\UFSOpenDevice 9483 . 9660) (\UFSCloseDevice 9662 . 9799)) (13962 41872 (\UFSOpenFile 13972 . 17266) (
\UFS.OPENP 17268 . 17765) (\UFS.RECOGNIZE.FILE 17767 . 18520) (\UFS.DIRECTORY.NAME 18522 . 19265) (
\UFSCloseFile 19267 . 20243) (\UFSGetFileName 20245 . 20444) (\UFSDeleteFile 20446 . 20986) (
\UFSRenameFile 20988 . 22153) (\UFSReadPages 22155 . 23290) (\UFSWritePages 23292 . 24512) (
\UFSTruncateFile 24514 . 26011) (\UFSDirectoryNameP 26013 . 27067) (\UFSEventFn 27069 . 27731) (
\UFSGetFileInfo 27733 . 30015) (\UFS.CREATE.PROPS 30017 . 30370) (\UFSSetFileInfo 30372 . 31601) (
\UFSGenerateFiles 31603 . 34315) (\UFS.NEXTFILEFN 34317 . 38460) (\UFS.FILEINFOFN 38462 . 39911) (
\UFS.VALID.PROPP 39913 . 40205) (\UFS.REGISTER.GFS 40207 . 40462) (\UFS.UNREGISTER.GFS 40464 . 41047)
(\UFS.ABORT.DIRECTORY 41049 . 41397) (\UFS.ABORT.CL-DIRECTORY 41399 . 41686) (\UFS.CLEANUP.GFS.TABLE
41688 . 41870)) (41907 48591 (\UFSMakeUnixFormatName 41917 . 42938) (\UFSParseNameString 42940 . 43314
) (\UFSParse-Directory 43316 . 43857) (\UFS.PARSE.BODY 43859 . 44404) (\UFS.ADJUST.HOST 44406 . 44565)
(\UFS.FULLNAME 44567 . 45775) (\UFS.ADD.HOST.FIELD 45777 . 46137) (\UFS.REMOVE.HOST.FIELD 46139 .
47809) (\UFS.HANDLE.RELATIVEDIRECTORY 47811 . 48589)) (49407 50020 (CHDIR 49417 . 50018)) (50092 51078
(\DEVICEFILE.EOSERROR 50102 . 51076)) (51151 52388 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51161 . 52006)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 52008 . 52386)) (52421 54047 (\UFSError 52431 . 54045)) (54091 56338 (
\UFSGetFileType 54101 . 54702) (\UFSSetFileType 54704 . 55133) (\UFSeol 55135 . 56336)) (65950 67074 (
\UFSGetPrintFileType 65960 . 66372) (\UFSGetFileTypeConfirm 66374 . 66822) (\UFSPrintTypeMenu 66824 .
67072)) (67104 68852 (\UFStoOtherCopyMess 67114 . 68105) (\UFStoOtherRenameMess 68107 . 68850)))))
(FILEMAP (NIL (8206 9759 (\UFSCreateDevice 8216 . 8581) (\UFS.CREATE.DEVICE 8583 . 9439) (
\UFSOpenDevice 9441 . 9618) (\UFSCloseDevice 9620 . 9757)) (14300 52622 (\UFSOpenFile 14310 . 17604) (
\UFS.OPENP 17606 . 18103) (\UFS.RECOGNIZE.FILE 18105 . 18858) (\UFS.DIRECTORY.NAME 18860 . 19603) (
\UFSCloseFile 19605 . 20581) (\UFSGetFileName 20583 . 20782) (\UFSDeleteFile 20784 . 21324) (
\UFSRenameFile 21326 . 22491) (\UFSReadPages 22493 . 23628) (\UFSWritePages 23630 . 24850) (
\UFSTruncateFile 24852 . 26349) (\UFSDirectoryNameP 26351 . 27405) (\UFSEventFn 27407 . 28069) (
\UFSGetFileInfo 28071 . 30353) (\UFS.CREATE.PROPS 30355 . 30708) (\UFSSetFileInfo 30710 . 31939) (
\UFSGenerateFiles 31941 . 38373) (\UFS.NEXTFILEFN 38375 . 49210) (\UFS.FILEINFOFN 49212 . 50661) (
\UFS.VALID.PROPP 50663 . 50955) (\UFS.REGISTER.GFS 50957 . 51212) (\UFS.UNREGISTER.GFS 51214 . 51797)
(\UFS.ABORT.DIRECTORY 51799 . 52147) (\UFS.ABORT.CL-DIRECTORY 52149 . 52436) (\UFS.CLEANUP.GFS.TABLE
52438 . 52620)) (52657 59341 (\UFSMakeUnixFormatName 52667 . 53688) (\UFSParseNameString 53690 . 54064
) (\UFSParse-Directory 54066 . 54607) (\UFS.PARSE.BODY 54609 . 55154) (\UFS.ADJUST.HOST 55156 . 55315)
(\UFS.FULLNAME 55317 . 56525) (\UFS.ADD.HOST.FIELD 56527 . 56887) (\UFS.REMOVE.HOST.FIELD 56889 .
58559) (\UFS.HANDLE.RELATIVEDIRECTORY 58561 . 59339)) (60157 60770 (CHDIR 60167 . 60768)) (60842 61828
(\DEVICEFILE.EOSERROR 60852 . 61826)) (61901 63138 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61911 . 62756)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 62758 . 63136)) (63171 64797 (\UFSError 63181 . 64795)) (64841 67088 (
\UFSGetFileType 64851 . 65452) (\UFSSetFileType 65454 . 65883) (\UFSeol 65885 . 67086)) (76238 77362 (
\UFSGetPrintFileType 76248 . 76660) (\UFSGetFileTypeConfirm 76662 . 77110) (\UFSPrintTypeMenu 77112 .
77360)) (77392 79140 (\UFStoOtherCopyMess 77402 . 78393) (\UFStoOtherRenameMess 78395 . 79138)))))
STOP

BIN
sources/UFS.LCOM
View File

Binary file not shown.