github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-24 19:40:36 +00:00
Code Issues Projects Releases Wiki Activity

Rmk37 prc menu shows superset relations (#764)

Browse Source 
* PSEUDOHOSTS: GETHOSTINFO of pseudohost goes to true host

* CMLPATHNAME:  Remove unused PARSE-NAMESTRING1

Avoid stumbling on it in future maintenance.  Also, remake filemap for functions and defmacros

* SAMEDIR, COMPAREDIRECTORIES: FILENAMEFIELD → FILENAMEFIELD.STRING

in a few places.  No need to hash atoms

* LLCHAR:  expose $$READONLY in inpname I.s.opr

* GITFNS: prc menu shows superset relations

* GITFNS:  Sort the prc menu

* EDITINTERFACE:  Better edit-date management

* PRETTYFILEINDEX: Destination can be any imagestream, not just display

* TEDIT-PF-SEE:  Use SEE instead of COPYTO IMAGESTREAM

to get better formatting of PRETTYFILEINDEX
This commit is contained in:
rmkaplan
2022-05-11 18:40:13 -07:00
committed by GitHub
parent dcba1a2d60
commit b796727165
18 changed files with 883 additions and 911 deletions
Download Patch File Download Diff File Expand all files Collapse all files

247
sources/CMLPATHNAME
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "14-Jan-2022 11:40:58" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2 41496
(FILECREATED "25-Apr-2022 20:29:09" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;3 32421
:PREVIOUS-DATE "28-Sep-90 15:14:19"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;1)
:CHANGES-TO (VARS CMLPATHNAMECOMS)
:PREVIOUS-DATE "14-Jan-2022 11:40:58"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2)
(* ; "
@@ -21,14 +23,14 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(COMS
(* ;; "useful macros")
(FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1))
(FUNCTIONS %%WILD-NAME %%COMPONENT-STRING))
(STRUCTURES PATHNAME DIRECTORY-COMPONENT)
(FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT)
(FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME
CL:PATHNAME-TYPE CL:PATHNAME-VERSION)
(FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING
%%NUMERIC-STRING-P)
(FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME)
(FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING CL:TRUENAME)
(FUNCTIONS %%MAKE-PATHNAME)
(FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL)
(FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME)
@@ -39,12 +41,11 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(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])
@@ -67,19 +68,6 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(DEFMACRO %%COMPONENT-STRING (COMPONENT)
`(MKSTRING (OR ,COMPONENT "")))
(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]
elseif (EQMEMB ,NAM ,ONEFIELDFLG)
then (RETURN (COND
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
(T (OR (SUBSTRING ,FILE ,ST ,END)
""])
(CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-)
(:PRINT-FUNCTION %%PRINT-PATHNAME)
(:CONSTRUCTOR %%%%MAKE-PATHNAME)
@@ -359,168 +347,6 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(MKATOM VERSION)))]
END)))
(CL:DEFUN PARSE-NAMESTRING1 (FILE)
(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts")
(* ;;; "crudely hacked from UNPACKFILENAME.STRING")
(PROG ((POS 1)
TEM TEM2 BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND PACKFLG DIRFLG ONEFIELDFLG)
(COND
((NULL FILE)
(RETURN (CONS (SUB1 POS)
NIL)))
((OR (LITATOM FILE)
(CL:STRINGP FILE)
(NUMBERP FILE)))
[(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]
(T (\ILLEGAL.ARG FILE)))
(COND
((SELCHARQ (NTHCHARCODE FILE 1)
({ (* ; "normal use in Interlisp-D")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
FILE 2)
0))))
(%[ (* ;
 "some Xerox and Arpanet systems use `[' for host")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
FILE 2)
0))))
(%( (* ;
 "this is the standard for Xerox product file servers")
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
FILE 2)
0))))
NIL)
(%%UNPACKFILE1 'HOST 2 TEM FILE PACKFLG ONEFIELDFLG VAL)
[COND
((EQ TEM -1)
(RETURN (CONS (SUB1 POS)
(DREVERSE VAL]
(SETQ POS (IPLUS TEM 2))
(SETQ HOSTP T)))
(COND
((SETQ TEM (LASTCHPOS (CHARCODE %:)
FILE POS))
(SETQ TEM (SUB1 TEM))
(%%UNPACKFILE1 'DEVICE POS TEM FILE PACKFLG ONEFIELDFLG VAL)
(SETQ POS (PLUS TEM 2))
(SETQ HOSTP T)))
(COND
[(EQ DIRFLG 'RETURN)
(LET ((TYPE 'DIRECTORY)
(START (SELCHARQ (NTHCHARCODE FILE POS)
(NIL (RETURN (CONS (SUB1 POS)
(DREVERSE VAL))))
((/ <)
(ADD1 POS))
POS))
END)
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
((/ >)
[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")
(SETQ TYPE 'SUBDIRECTORY]
-2)
(PROGN -1)))
(%%UNPACKFILE1 TYPE START END FILE PACKFLG ONEFIELDFLG VAL))
(RETURN (CONS (SUB1 POS)
(DREVERSE VAL]
((SELCHARQ (NTHCHARCODE FILE POS)
(/ (* ;
 "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 >>")
(SETQ TEM (LASTCHPOS (CHARCODE >)
FILE
(ADD1 POS))))
NIL)
(%%UNPACKFILE1 'DIRECTORY (ADD1 POS)
(SUB1 TEM)
FILE PACKFLG ONEFIELDFLG VAL)
(SETQ POS (ADD1 TEM))
(SETQ HOSTP T)))
[OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (CONS (SUB1 POS)
(DREVERSE VAL]
NAMELP
(SELCHARQ CODE
((%. ! ; NIL) (* ;
 "NAME and SUBDIRECTORY fields definitely terminated by now")
(COND
((AND (EQ CODE (CHARCODE %.))
(NOT BEYONDNAME)
(SETQ TEM2 (STRPOS "." FILE (ADD1 TEM)))
(SETQ TEM2 (NTHCHAR FILE (ADD1 TEM2)))
(NOT (FIXP TEM2)))
(* ;; "If there's another dot followed by something other than a numeric extension, then ignore this dot, since we'll get another chance")
(GO NEXTCHAR)))
[COND
(SUBDIREND (%%UNPACKFILE1 'SUBDIRECTORY POS (SUB1 SUBDIREND)
FILE PACKFLG ONEFIELDFLG VAL)
(SETQ POS (ADD1 SUBDIREND))
(SETQ SUBDIREND)
(COND
((AND (NULL CODE)
(EQ POS TEM)) (* ;
 "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]
POS
(SUB1 TEM)
FILE PACKFLG ONEFIELDFLG VAL)
[COND
((NULL CODE) (* ; "End of string")
(RETURN (CONS (SUB1 POS)
(DREVERSE VAL]
(SETQ POS (ADD1 TEM)))
(%' (* ; "Quoter")
(add TEM 1))
((/ >) (* ;
 "Subdirectory terminating character")
(COND
((AND (NOT HOSTP)
(NOT BEYONDNAME)
DIRFLG) (* ;
 "Ok to treat this as a subdirectory")
(SETQ SUBDIREND TEM))))
NIL)
NEXTCHAR
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
(GO NAMELP)))
(CL:DEFUN CL:TRUENAME (PATHNAME)
(* ;;; "Return the pathname for the actual file described by the pathname. An error is signaled if no such file exists. PATHNAME can be a pathname, string, symbol, or stream. Synonym streams are followed to their sources")
@@ -673,7 +499,8 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(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)
)
(PRETTYCOMPRINT CMLPATHNAMECOMS)
@@ -685,14 +512,14 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(COMS
(* ;; "useful macros")
(FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1))
(FUNCTIONS %%WILD-NAME %%COMPONENT-STRING))
(STRUCTURES PATHNAME DIRECTORY-COMPONENT)
(FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT)
(FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME
CL:PATHNAME-TYPE CL:PATHNAME-VERSION)
(FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING
%%NUMERIC-STRING-P)
(FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME)
(FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING CL:TRUENAME)
(FUNCTIONS %%MAKE-PATHNAME)
(FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL)
(FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME)
@@ -703,33 +530,33 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
(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])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(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)
)
(PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
(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)))))
(FILEMAP (NIL (2107 2238 (%%WILD-NAME 2107 . 2238)) (2240 2319 (%%COMPONENT-STRING 2240 . 2319)) (2924
8695 (%%PRINT-PATHNAME 2934 . 3095) (CL:MAKE-PATHNAME 3097 . 7847) (%%PRINT-DIRECTORY-COMPONENT 7849
. 8693)) (8697 8890 (CL:PATHNAME-HOST 8697 . 8890)) (8892 9091 (CL:PATHNAME-DEVICE 8892 . 9091)) (
9093 9301 (CL:PATHNAME-DIRECTORY 9093 . 9301)) (9303 9496 (CL:PATHNAME-NAME 9303 . 9496)) (9498 9691 (
CL:PATHNAME-TYPE 9498 . 9691)) (9693 9895 (CL:PATHNAME-VERSION 9693 . 9895)) (9896 15220 (PATHNAME
9906 . 10098) (CL:MERGE-PATHNAMES 10100 . 12186) (FILE-NAME 12188 . 12329) (CL:HOST-NAMESTRING 12331
. 12520) (CL:ENOUGH-NAMESTRING 12522 . 14987) (%%NUMERIC-STRING-P 14989 . 15218)) (15222 18975 (
CL:NAMESTRING 15222 . 18975)) (18977 22448 (CL:PARSE-NAMESTRING 18977 . 22448)) (22450 23453 (
CL:TRUENAME 22450 . 23453)) (23455 23647 (%%MAKE-PATHNAME 23455 . 23647)) (23649 24286 (
%%PATHNAME-EQUAL 23649 . 24286)) (24288 24745 (%%DIRECTORY-COMPONENT-EQUAL 24288 . 24745)) (24747
25370 (%%INITIALIZE-DEFAULT-PATHNAME 24747 . 25370)) (25460 25627 (INTERLISP-NAMESTRING 25460 . 25627)
) (25629 28522 (UNPACKPATHNAME.STRING 25629 . 28522)) (28524 29781 (CL:FILE-NAMESTRING 28524 . 29781))
(29783 29981 (CL:DIRECTORY-NAMESTRING 29783 . 29981)))))
STOP