github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-11 10:54:58 +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

329
lispusers/COMPAREDIRECTORIES
View File

@@ -1,12 +1,14 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Mar-2022 11:53:34" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;215 123553
(FILECREATED "25-Apr-2022 09:25:02" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;217 123829
:CHANGES-TO (FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS)
:CHANGES-TO (FNS CDBROWSER-COPY COMPAREDIRECTORIES.INFOS.TYPE CDFILES FIND-UNSOURCED-FILES
FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES
FIND-MULTICOMPILED-FILES SOURCE-FOR-COMPILED-P CDBROWSER-DELETE-FILE)
:PREVIOUS-DATE " 6-Mar-2022 19:53:40"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;214)
:PREVIOUS-DATE "29-Mar-2022 11:53:34"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;215)
(* ; "
@@ -319,18 +321,18 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
CDE])
(COMPAREDIRECTORIES.INFOS.TYPE
[LAMBDA (FULLNAME LDATE) (* ; "Edited 4-Jan-2022 13:10 by rmk")
[LAMBDA (FULLNAME LDATE) (* ; "Edited 25-Apr-2022 09:02 by rmk")
(* ; "Edited 4-Jan-2022 13:10 by rmk")
(* ; "Edited 12-Dec-2021 22:50 by rmk")
(IF LDATE
THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION)
*COMPILED-EXTENSIONS*)
'COMPILED
'SOURCE)
ELSEIF (PRINTFILETYPE FULLNAME)
ELSE (SELECTQ (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION))
((TXT TEXT SH MD C)
'TEXT)
'OTHER])
(LET [(EXT (FILENAMEFIELD FULLNAME 'EXTENSION]
(IF LDATE
THEN (CL:IF (MEMB EXT *COMPILED-EXTENSIONS*)
'COMPILED
'SOURCE)
ELSEIF (PRINTFILETYPE FULLNAME)
ELSE (CL:IF (MEMB EXT '(TXT TEXT SH MD C))
'TEXT
'OTHER)])
(MATCHNAME
[LAMBDA (NAME STARTPOS) (* ; "Edited 24-Feb-2022 09:10 by rmk")
@@ -383,7 +385,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(DEFINEQ
(CDFILES
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 5-Mar-2022 15:05 by rmk")
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 25-Apr-2022 08:42 by rmk")
(* ; "Edited 5-Mar-2022 15:05 by rmk")
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
(* ;; "Returns a list of fullnames for files that satisfy the criteria. We generate all candidates that match INCLUDEDFILES but not EXCLUDEDFILES in DIR.")
@@ -411,8 +414,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(LET ([INCLUDES (CDFILES.PATS (OR INCLUDEDFILES '*.*]
(EXCLUDES (AND EXCLUDEDFILES (CDFILES.PATS EXCLUDEDFILES)))
HOST ENUMPAT)
(SETQ HOST (FILENAMEFIELD DIR 'HOST))
(SETQ DIR (FILENAMEFIELD DIR 'DIRECTORY))
(SETQ HOST (FILENAMEFIELD.STRING DIR 'HOST))
(SETQ DIR (FILENAMEFIELD.STRING DIR 'DIRECTORY))
(CL:UNLESS DEPTH
(* ;; "DEPTH is the number of internal > or /")
@@ -436,7 +439,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(* ;;
 "If We don't prefix TOPDIR with <, then if TOPDIR contains a colon it is interpreted as a device.")
(SETQ ENUMPAT (PACKFILENAME 'HOST HOST 'DIRECTORY
(SETQ ENUMPAT (PACKFILENAME.STRING 'HOST HOST 'DIRECTORY
(CONCAT "<" DIR ">" (OR SD ""))
'NAME N 'EXTENSION E 'VERSION
(CL:IF ALLVERSIONS
@@ -1141,154 +1144,144 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
CF SCREATION])
(FIND-UNSOURCED-FILES
[LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:")
(* ; "Edited 3-Nov-94 15:17 by jds")
[LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 25-Apr-2022 08:43 by rmk")
(* ; "Edited 15-Sep-2020 15:32 by rmk:")
(* ; "Edited 3-Nov-94 15:17 by jds")
(* ;;
 "Produces a list of compiled FILES for which no source file can be found in the same directory.")
(* ;;
 "Produces a list of compiled FILES for which no source file can be found in the same directory.")
(* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.")
(* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.")
(* ;;
"We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.")
(* ;;
 "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.")
(* ;; "Sort to get lcoms and dfasls next to each other.")
(* ;; "Sort to get lcoms and dfasls next to each other.")
(LET (CCREATEDS)
(SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS
*COMPILED-EXTENSIONS*)
(SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*)
JOIN (FOR CF IN [OR (LISTP FILES)
(FILDIR (PACKFILENAME 'EXTENSION CEXT
'VERSION "" 'BODY
'*]
WHEN (CDDR (SETQ CCREATED (CREATED-AS CF)))
UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED)))
(FILDIR (PACKFILENAME.STRING 'EXTENSION CEXT
'VERSION "" 'BODY '*]
WHEN (CDDR (SETQ CCREATED (CREATED-AS CF)))
UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED)))
(* ;; "CCREATEDS is now a list of CREATED-AS items")
(* ;; "CCREATEDS is now a list of CREATED-AS items")
(FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION
NIL 'VERSION NIL
'BODY
(CAR CC]
(SOURCE-FOR-COMPILED-P (SETQ SF
(CREATED-AS
SF))
CC DFASLMARGIN))
(FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME.STRING 'EXTENSION NIL
'VERSION NIL 'BODY (CAR CC]
(SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF))
CC DFASLMARGIN))
COLLECT [LIST (CAR CC)
(AND SF (LIST (CAR SF)
(ROUND (COMPILE-SOURCE-DATE-DIFF CC SF]
(AND SF (LIST (CAR SF)
(ROUND (COMPILE-SOURCE-DATE-DIFF CC SF]
FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2)
(ALPHORDER (FILENAMEFIELD (CAR CF1)
'NAME)
(FILENAMEFIELD (CAR CF2)
'NAME])
(ALPHORDER (FILENAMEFIELD.STRING (CAR CF1)
'NAME)
(FILENAMEFIELD.STRING (CAR CF2)
'NAME])
(FIND-SOURCE-FILES
[LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:")
[LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 25-Apr-2022 08:43 by rmk")
(* ; "Edited 9-Sep-2020 12:26 by rmk:")
(* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.")
(* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.")
(* ;; "This suggests that one of CFILES should be copied to the SFILE directory.")
(* ;; "This suggests that one of CFILES should be copied to the SFILE directory.")
(SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD)))
(SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES)
(FILDIR CFILES))
(FILDIR CFILES))
WHEN (AND (SETQ CNAME (INFILEP CF))
(CDDR (SETQ CCREATED (CREATED-AS CF)))
(SETQ SFILES (FOR SD SF IN SDIRS
WHEN (AND (SETQ SF (INFILEP (PACKFILENAME
'NAME
(FILENAMEFIELD
CF
'NAME)
'BODY SD)))
(SOURCE-FOR-COMPILED-P SF CCREATED
DFASLMARGIN)) COLLECT SF)))
COLLECT (CONS CNAME SFILES))
(CDDR (SETQ CCREATED (CREATED-AS CF)))
(SETQ SFILES (FOR SD SF IN SDIRS
WHEN (AND (SETQ SF (INFILEP (PACKFILENAME.STRING
'NAME
(FILENAMEFIELD.STRING
CF
'NAME)
'BODY SD)))
(SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN))
COLLECT SF))) COLLECT (CONS CNAME SFILES))
(FUNCTION (LAMBDA (P1 P2)
(ALPHORDER (FILENAMEFIELD (CAR P1))
(FILENAMEFIELD (CAR P2])
(ALPHORDER (FILENAMEFIELD.STRING (CAR P1))
(FILENAMEFIELD.STRING (CAR P2])
(FIND-COMPILED-FILES
[LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:")
[LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 25-Apr-2022 08:44 by rmk")
(* ; "Edited 9-Sep-2020 12:26 by rmk:")
(* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.")
(* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.")
(* ;; "FILEDATE is true for source files and compiled files")
(* ;; "FILEDATE is true for source files and compiled files")
(* ;; "This suggests that one of CFILES should be copied to the SFILE directory.")
(* ;; "This suggests that one of CFILES should be copied to the SFILE directory.")
(SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD)))
(SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES)
(FILDIR SFILES))
(FILDIR SFILES))
WHEN [AND (SETQ SNAME (INFILEP SF))
(SETQ SCREATED (CREATED-AS SF))
(NOT (CDDR SCREATED))
(SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME))
IN *COMPILED-EXTENSIONS*
JOIN (FOR CD CF IN CDIRS
WHEN (AND (SETQ CF
(INFILEP (PACKFILENAME
'NAME ROOT
'EXTENSION CEXT
'BODY CD)))
(SOURCE-FOR-COMPILED-P
SCREATED CF DFASLMARGIN))
COLLECT CF] COLLECT (CONS SNAME CFILES
))
(SETQ SCREATED (CREATED-AS SF))
(NOT (CDDR SCREATED))
(SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD.STRING SNAME 'NAME))
IN *COMPILED-EXTENSIONS*
JOIN (FOR CD CF IN CDIRS
WHEN (AND (SETQ CF (INFILEP (PACKFILENAME.STRING
'NAME ROOT 'EXTENSION
CEXT 'BODY CD)))
(SOURCE-FOR-COMPILED-P SCREATED CF
DFASLMARGIN)) COLLECT CF]
COLLECT (CONS SNAME CFILES))
(FUNCTION (LAMBDA (P1 P2)
(ALPHORDER (FILENAMEFIELD (CAR P1))
(FILENAMEFIELD (CAR P2])
(ALPHORDER (FILENAMEFIELD.STRING (CAR P1))
(FILENAMEFIELD.STRING (CAR P2])
(FIND-UNLOADED-FILES
[LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:")
[LAMBDA (FILES) (* ; "Edited 25-Apr-2022 08:49 by rmk")
(* ; "Edited 9-Sep-2020 19:35 by rmk:")
(* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.")
(* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.")
(FOR F IN (OR (LISTP FILES)
(FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F)
(CAR F)
F)))
(FILEDATE F))
UNLESS (GETP (FILENAMEFIELD F 'NAME)
'FILEDATES) COLLECT F])
(FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F)
(CAR F)
F)))
(FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME)
'FILEDATES) COLLECT F])
(FIND-LOADED-FILES
[LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:")
[LAMBDA (ROOTFILENAMES) (* ; "Edited 25-Apr-2022 09:04 by rmk")
(* ; "Edited 19-Sep-2020 07:20 by rmk:")
(FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES)
COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD
F
'NAME)) COLLECT
F])
COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F])
(FIND-MULTICOMPILED-FILES
[LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:")
[LAMBDA (FILES SHOWINFO) (* ; "Edited 25-Apr-2022 09:07 by rmk")
(* ; "Edited 20-Sep-2020 20:57 by rmk:")
(* ;; "Returns a list of names for files in FILES that have multiple compilations")
(* ;; "Returns a list of names for files in FILES that have multiple compilations")
(LET (SFILES)
(FOR F EXT NAME IN (OR (LISTP FILES)
(FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD
F
'EXTENSION))
*COMPILED-EXTENSIONS*)
(FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION))
*COMPILED-EXTENSIONS*)
DO (SETQ NAME (FILENAMEFIELD F 'NAME))
(* ;; "PUSHNEW because we haven't filtered out versions")
(* ;; "PUSHNEW because we haven't filtered out versions")
(PUSHNEW [CDR (OR (ASSOC NAME SFILES)
(CAR (PUSH SFILES (CONS NAME]
EXT))
(PUSHNEW [CDR (OR (ASSOC NAME SFILES)
(CAR (PUSH SFILES (CONS NAME]
EXT))
(FOR S IN SFILES WHEN (CDDR S)
COLLECT (IF SHOWINFO
THEN `[,(CAR S)
,(CADAR (FIND-LOADED-FILES (CAR S)))
,(CREATED-AS (CAR S))
,@(FOR EXT IN (SORT (CDR S))
COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT
'BODY
(CAR S]
ELSE (CAR S])
THEN `[,(CAR S)
,(CADAR (FIND-LOADED-FILES (CAR S)))
,(CREATED-AS (CAR S))
,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME.STRING
'EXTENSION EXT
'BODY
(CAR S]
ELSE (CAR S])
)
(DEFINEQ
@@ -1383,21 +1376,22 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))])
(SOURCE-FOR-COMPILED-P
[LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:")
[LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 25-Apr-2022 08:46 by rmk")
(* ; "Edited 31-Oct-2020 09:12 by rmk:")
(* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS")
(* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS")
(* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.")
(* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.")
(* ;; "")
(* ;; "")
(* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).")
(* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).")
(* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).")
(* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).")
(* ;; "Default is (20 0).")
(* ;; "Default is (20 0).")
(* ;; "T is positive or negative infinity")
(* ;; "T is positive or negative infinity")
(CL:UNLESS (LISTP SOURCE)
(SETQ SOURCE (CREATED-AS SOURCE)))
@@ -1405,11 +1399,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(SETQ COMPILED (CREATED-AS COMPILED)))
(SETQ DFASLMARGIN (IF (NULL DFASLMARGIN)
THEN
(* ;;
 "If compiled is later than source by less than 20 minutes, it's probably OK")
(* ;;
 "If compiled is later than source by less than 20 minutes, it's probably OK")
'(20 0)
'(20 0)
ELSEIF (EQ T DFASLMARGIN)
THEN '(T 0)
ELSEIF (LISTP DFASLMARGIN)
@@ -1417,17 +1410,17 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN)
ELSEIF (MINUSP DFASLMARGIN)
THEN (LIST (MINUS DFASLMARGIN)
DFASLMARGIN)
DFASLMARGIN)
ELSE (LIST DFASLMARGIN 0)))
(OR (EQUAL (CAR SOURCE)
(CADDR COMPILED))
(EQUAL (CADR SOURCE)
(CADDDR COMPILED))
(AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED)
'EXTENSION]
(AND [STREQUAL 'DFASL (U-CASE (FILENAMEFIELD.STRING (CAR COMPILED)
'EXTENSION]
(LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE)))
(* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.")
(* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.")
(AND (OR (EQ T (CAR DFASLMARGIN))
(LEQ TIMEDIFF (CAR DFASLMARGIN)))
@@ -1972,7 +1965,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(MOVEWITH CHILDREN WINDOW])
(CDBROWSER-COPY
[LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 5-Feb-2022 17:27 by rmk")
[LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 25-Apr-2022 09:24 by rmk")
(* ; "Edited 5-Feb-2022 17:27 by rmk")
(* ; "Edited 2-Feb-2022 22:18 by rmk")
(* ;; "Copies the file identified as SOURCE (LEFT or RIGHT) in CDENTRY to the other file of the end. If the destination file is missing, it is assumed to be a new/unversioned file of the same name as the source but with the directory prefix switched. CDVALUE needed to know what directory prefixes are involved.")
@@ -2008,8 +2002,9 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
"Target is newer than source. Really copy? "]
(RETURN NIL))
(CL:WHEN [AND (SETQ SOURCEVER (FILENAMEFIELD SOURCE 'VERSION))
(ILESSP SOURCEVER (FILENAMEFIELD (INFILEP (PACKFILENAME 'VERFSION NIL
'BODY SOURCEFILE))
(ILESSP SOURCEVER (FILENAMEFIELD (INFILEP (PACKFILENAME.STRING
'VERSION NIL 'BODY SOURCEFILE
))
'VERSION))
(PROGN (FLASHWINDOW T)
(EQ 'N (ASKUSER NIL NIL (CONCAT SOURCEFILE
@@ -2019,7 +2014,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CLEARW T)
(CL:UNLESS DESTFILE
(SETQ DESTFILE (CD-SWAPDIRS SOURCEFILE SOURCEDIR DESTDIR)))
(SETQ RESULT (COPYFILE SOURCEFILE (PACKFILENAME 'VERSION NIL 'BODY DESTFILE)))
(SETQ RESULT (COPYFILE SOURCEFILE (PACKFILENAME.STRING 'VERSION NIL 'BODY DESTFILE)))
(PRIN3 (IF RESULT
THEN (TB.DELETE.ITEM CDBROWSER TBITEM)
(CONCAT "Copied to " RESULT)
@@ -2029,7 +2024,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(RETURN RESULT)))])
(CDBROWSER-DELETE-FILE
[LAMBDA (CDBROWSER TBITEM SIDE ONLYONE SAVE) (* ; "Edited 5-Feb-2022 17:46 by rmk")
[LAMBDA (CDBROWSER TBITEM SIDE ONLYONE SAVE) (* ; "Edited 25-Apr-2022 09:06 by rmk")
(* ; "Edited 5-Feb-2022 17:46 by rmk")
(* ; "Edited 18-Jan-2022 23:02 by rmk")
(* ; "Edited 19-Dec-2021 23:33 by rmk")
@@ -2049,10 +2045,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CL:WHEN (EQ SIDE 'RIGHT)
(SWAP FILE OTHERFILE))
(CL:WHEN FILE
(FOR F INSIDE (IF (FILENAMEFIELD FILE 'VERSION)
(FOR F INSIDE (IF (FILENAMEFIELD.STRING FILE 'VERSION)
THEN [IF ONLYONE
THEN FILE
ELSE (DREVERSE (FILDIR (PACKFILENAME 'VERSION '*
ELSE (DREVERSE (FILDIR (PACKFILENAME.STRING 'VERSION "*"
'BODY FILE]
ELSE FILE)
COLLECT
@@ -2060,11 +2056,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(* ;; "Delete the earlier ones first, if it goes bad, you don't want them to persist. This preserves the original version numbers, maybe it should start fresh from 1 (or from whatever might have been deleted before).")
(IF SAVE
THEN (CL:UNLESS (RENAMEFILE F (PACKFILENAME 'DIRECTORY
(CONCAT "deleted>"
(FILENAMEFIELD F
THEN (CL:UNLESS (RENAMEFILE F (PACKFILENAME.STRING
'DIRECTORY
(CONCAT "deleted>" (FILENAMEFIELD.STRING
F
'DIRECTORY))
'BODY F))
'BODY F))
(ERROR "Could not delete " F))
ELSE (DELFILE FILE))
F FINALLY
@@ -2099,24 +2096,24 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998
2018 2020 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2633 21889 (COMPAREDIRECTORIES 2643 . 7476) (COMPAREDIRECTORIES.INFOS 7478 . 10329) (
COMPAREDIRECTORIES.CANDIDATES 10331 . 13716) (CDENTRIES.SELECT 13718 . 18493) (
COMPAREDIRECTORIES.INFOS.TYPE 18495 . 19123) (MATCHNAME 19125 . 19805) (CD.INSURECDVALUE 19807 . 21421
) (CD.UPDATEWIDTHS 21423 . 21887)) (21890 31429 (CDFILES 21900 . 27523) (CDFILES.MATCH 27525 . 29150)
(CDFILES.PATS 29152 . 31427)) (31430 46515 (CDPRINT 31440 . 33785) (CDPRINT.HEADER 33787 . 34684) (
CDPRINT.LINE 34686 . 37242) (CDPRINT.MAXWIDTHS 37244 . 41359) (CDPRINT.COLHEADERS 41361 . 41999) (
CDPRINT.COLUMNS 42001 . 45880) (CDTEDIT 45882 . 46513)) (46516 54885 (CDMAP 46526 . 47958) (CDENTRY
47960 . 48269) (CDSUBSET 48271 . 49710) (CDMERGE 49712 . 53566) (CDMERGE.COMMON 53568 . 54883)) (54886
62424 (BINCOMP 54896 . 59185) (EOLTYPE 59187 . 61749) (EOLTYPE.SHOW 61751 . 62422)) (62952 76159 (
FIND-UNCOMPILED-FILES 62962 . 66605) (FIND-UNSOURCED-FILES 66607 . 69416) (FIND-SOURCE-FILES 69418 .
71122) (FIND-COMPILED-FILES 71124 . 73202) (FIND-UNLOADED-FILES 73204 . 73948) (FIND-LOADED-FILES
73950 . 74504) (FIND-MULTICOMPILED-FILES 74506 . 76157)) (76160 84362 (CREATED-AS 76170 . 80967) (
SOURCE-FOR-COMPILED-P 80969 . 83667) (COMPILE-SOURCE-DATE-DIFF 83669 . 84360)) (84363 94669 (
FIX-DIRECTORY-DATES 84373 . 87366) (FIX-EQUIV-DATES 87368 . 88893) (COPY-COMPARED-FILES 88895 . 90716)
(COPY-MISSING-FILES 90718 . 92875) (COMPILED-ON-SAME-SOURCE 92877 . 94667)) (94863 102209 (CDBROWSER
94873 . 98800) (CDBROWSER.STRINGS 98802 . 102207)) (102371 104107 (CD.TABLEITEM 102381 . 102601) (
CD.TABLEITEM.PRINTFN 102603 . 102802) (CD.TABLEITEM.COPYFN 102804 . 103862) (
CDTABLEBROWSER.HEADING.REPAINTFN 103864 . 104105)) (104108 122969 (CDTABLEBROWSER.WHENSELECTEDFN
104118 . 104586) (CD.COMMANDSELECTEDFN 104588 . 109689) (CD-MENUFN 109691 . 116054) (CDBROWSER-COPY
116056 . 119427) (CDBROWSER-DELETE-FILE 119429 . 122448) (CD-SWAPDIRS 122450 . 122967)))))
(FILEMAP (NIL (2856 22205 (COMPAREDIRECTORIES 2866 . 7699) (COMPAREDIRECTORIES.INFOS 7701 . 10552) (
COMPAREDIRECTORIES.CANDIDATES 10554 . 13939) (CDENTRIES.SELECT 13941 . 18716) (
COMPAREDIRECTORIES.INFOS.TYPE 18718 . 19439) (MATCHNAME 19441 . 20121) (CD.INSURECDVALUE 20123 . 21737
) (CD.UPDATEWIDTHS 21739 . 22203)) (22206 31875 (CDFILES 22216 . 27969) (CDFILES.MATCH 27971 . 29596)
(CDFILES.PATS 29598 . 31873)) (31876 46961 (CDPRINT 31886 . 34231) (CDPRINT.HEADER 34233 . 35130) (
CDPRINT.LINE 35132 . 37688) (CDPRINT.MAXWIDTHS 37690 . 41805) (CDPRINT.COLHEADERS 41807 . 42445) (
CDPRINT.COLUMNS 42447 . 46326) (CDTEDIT 46328 . 46959)) (46962 55331 (CDMAP 46972 . 48404) (CDENTRY
48406 . 48715) (CDSUBSET 48717 . 50156) (CDMERGE 50158 . 54012) (CDMERGE.COMMON 54014 . 55329)) (55332
62870 (BINCOMP 55342 . 59631) (EOLTYPE 59633 . 62195) (EOLTYPE.SHOW 62197 . 62868)) (63398 75925 (
FIND-UNCOMPILED-FILES 63408 . 67051) (FIND-UNSOURCED-FILES 67053 . 69437) (FIND-SOURCE-FILES 69439 .
71177) (FIND-COMPILED-FILES 71179 . 73056) (FIND-UNLOADED-FILES 73058 . 73911) (FIND-LOADED-FILES
73913 . 74341) (FIND-MULTICOMPILED-FILES 74343 . 75923)) (75926 84255 (CREATED-AS 75936 . 80733) (
SOURCE-FOR-COMPILED-P 80735 . 83560) (COMPILE-SOURCE-DATE-DIFF 83562 . 84253)) (84256 94562 (
FIX-DIRECTORY-DATES 84266 . 87259) (FIX-EQUIV-DATES 87261 . 88786) (COPY-COMPARED-FILES 88788 . 90609)
(COPY-MISSING-FILES 90611 . 92768) (COMPILED-ON-SAME-SOURCE 92770 . 94560)) (94756 102102 (CDBROWSER
94766 . 98693) (CDBROWSER.STRINGS 98695 . 102100)) (102264 104000 (CD.TABLEITEM 102274 . 102494) (
CD.TABLEITEM.PRINTFN 102496 . 102695) (CD.TABLEITEM.COPYFN 102697 . 103755) (
CDTABLEBROWSER.HEADING.REPAINTFN 103757 . 103998)) (104001 123245 (CDTABLEBROWSER.WHENSELECTEDFN
104011 . 104479) (CD.COMMANDSELECTEDFN 104481 . 109582) (CD-MENUFN 109584 . 115947) (CDBROWSER-COPY
115949 . 119509) (CDBROWSER-DELETE-FILE 119511 . 122724) (CD-SWAPDIRS 122726 . 123243)))))
STOP

BIN
lispusers/COMPAREDIRECTORIES.LCOM
View File

Binary file not shown.

298
lispusers/GITFNS
View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Mar-2022 13:59:00" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;132 74961
(FILECREATED "29-Apr-2022 11:37:08" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;147 76981
:CHANGES-TO (FNS GIT-COMPARE-WITH-MYMEDLEY)
:CHANGES-TO (FNS GIT-PRC-MENU)
:PREVIOUS-DATE "10-Mar-2022 20:26:42"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;131)
:PREVIOUS-DATE "29-Apr-2022 11:14:35"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;146)
(PRETTYCOMPRINT GITFNSCOMS)
@@ -71,7 +71,7 @@
(* ;; "Branches")
(FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS?
PICK-BRANCH GIT-PULL-REQUESTS)
GIT-PICK-BRANCH GIT-PRC-MENU GIT-PULL-REQUESTS GIT-BRANCH-RELATIONS)
(* ;; "My branches")
@@ -200,18 +200,9 @@
(SETQ DR T))
(IF RB
THEN (GIT-COMPARE-BRANCHES RB 'origin/master)
ELSE (GIT-COMPARE-BRANCHES (PICK-BRANCH
(OR [FOR PR IN (GIT-PULL-REQUESTS T DR)
COLLECT (LIST (CL:IF (MEMB 'DRAFT PR)
(CONCAT (CADDR PR)
" (draft)")
(CADDR PR))
(CADDR PR)
(CONCAT " " (CADR PR)
" #"
(CAR PR]
'REMOTE)
"Pull requests")
ELSE (GIT-COMPARE-BRANCHES (GIT-PICK-BRANCH (OR (GIT-PRC-MENU DR)
'REMOTE)
"Pull requests")
'origin/master NIL))))
(DEFCOMMAND cob (BRANCH)
@@ -222,7 +213,7 @@
(T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH)))
((NEW NEXT)
(GIT-MAKE-BRANCH))
(GIT-CHECKOUT (OR BRANCH (PICK-BRANCH NIL "Branches" 'LOCAL])
(GIT-CHECKOUT (OR BRANCH (GIT-PICK-BRANCH NIL "Branches" 'LOCAL])
(DEFCOMMAND b? (BRANCH) (GIT-WHICH-BRANCH))
@@ -481,12 +472,14 @@
(GIT-BRANCH-DIFF
[LAMBDA (BRANCH1 BRANCH2)
(* ;; "Edited 6-Mar-2022 14:52 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
(* ;; "Edited 29-Apr-2022 07:17 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
(* ;; "This returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
(CL:UNLESS BRANCH1 (SETQ BRANCH1 "origin/master"))
(CL:UNLESS BRANCH2 (SETQ BRANCH2 "origin/master"))
(CL:UNLESS BRANCH1
(SETQ BRANCH1 'origin/master))
(CL:UNLESS BRANCH2
(SETQ BRANCH2 'origin/master))
(GIT-REMOTE-UPDATE)
(LET ([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
LINES POS)
@@ -500,50 +493,42 @@
POS NIL T)
THEN BRANCH1
ELSE BRANCH2)))
(FOR L ADDED DELETED RENAMED CHANGED COPIED IN LINES
DO (SELCHARQ (CHCON1 L)
(A (CL:IF (EQ (CHARCODE TAB)
(NTHCHARCODE L 2))
(PUSH ADDED (SUBSTRING L 3))
(ERROR "ADDED NOT RECOGNIZED" L)))
(D (CL:IF (EQ (CHARCODE TAB)
(NTHCHARCODE L 2))
(PUSH DELETED (SUBSTRING L 3))
(ERROR "DELETED NOT RECOGNIZED" L)))
(M (CL:IF (SETQ POS (STRPOS " " L))
(PUSH CHANGED (SUBSTRING L (ADD1 POS)))
(ERROR "CHANGED NOT RECOGNIZED" L)))
(C (IF (AND (EQ (CHARCODE TAB)
(NTHCHARCODE L 5))
(SETQ POS (STRPOS " " L 7)))
THEN [PUSH COPIED (LIST (SUBSTRING L 6 (SUB1 POS))
(SUBSTRING L (ADD1 POS))
(OR (FIXP (SUBATOM L 2 4))
(HELP "C without a number" L]
ELSE (HELP "COPY NOT RECOGNIZED" L)))
(R (IF (AND (EQ (CHARCODE TAB)
(NTHCHARCODE L 5))
(SETQ POS (STRPOS " " L 7)))
THEN [PUSH RENAMED (LIST (SUBSTRING L 6 (SUB1 POS))
(SUBSTRING L (ADD1 POS))
(OR (FIXP (SUBATOM L 2 4))
(HELP "R without a number" L]
ELSE (HELP "RENAME NOT RECOGNIZED" L)))
(w (CL:UNLESS (STRPOS "warning: " L 1)
(HELP "UNRECOGNZED GIT LINE" L))
(CL:UNLESS (EQ 'Y (ASKUSER NIL NIL (CONCAT L " Ignore remaining files? ")))
(ERROR!)))
(HELP "Unrecognized git-diff code" (NTHCHAR L 1)))
FINALLY (CL:WHEN ADDED
(PUSH $$VAL (CONS 'ADDED ADDED)))
(CL:WHEN DELETED
(PUSH $$VAL (CONS 'DELETED DELETED)))
(CL:WHEN RENAMED
(PUSH $$VAL (CONS 'RENAMED RENAMED)))
(CL:WHEN CHANGED
(PUSH $$VAL (CONS 'CHANGED CHANGED)))
(CL:WHEN COPIED
(PUSH $$VAL (CONS 'COPIED COPIED)))])
(SORT [FOR L IN LINES
COLLECT (SELCHARQ (CHCON1 L)
(A (CL:IF (EQ (CHARCODE TAB)
(NTHCHARCODE L 2))
(LIST 'ADDED (SUBSTRING L 3))
(ERROR "ADDED NOT RECOGNIZED" L)))
(D (CL:IF (EQ (CHARCODE TAB)
(NTHCHARCODE L 2))
(LIST 'DELETED (SUBSTRING L 3))
(ERROR "DELETED NOT RECOGNIZED" L)))
(M (CL:IF (SETQ POS (STRPOS " " L))
(LIST 'CHANGED (SUBSTRING L (ADD1 POS)))
(ERROR "CHANGED NOT RECOGNIZED" L)))
(C (IF (AND (EQ (CHARCODE TAB)
(NTHCHARCODE L 5))
(SETQ POS (STRPOS " " L 7)))
THEN (LIST 'COPIED (SUBSTRING L 6 (SUB1 POS))
(OR (FIXP (SUBATOM L 2 4))
(HELP "C without a number" L)))
ELSE (HELP "COPY NOT RECOGNIZED" L)))
(R (IF (AND (EQ (CHARCODE TAB)
(NTHCHARCODE L 5))
(SETQ POS (STRPOS " " L 7)))
THEN (LIST 'RENAMED (SUBSTRING L 6 (SUB1 POS))
(SUBSTRING L (ADD1 POS))
(OR (FIXP (SUBATOM L 2 4))
(HELP "R without a number" L)))
ELSE (HELP "RENAME NOT RECOGNIZED" L)))
(w (CL:UNLESS (STRPOS "warning: " L 1)
(HELP "UNRECOGNZED GIT LINE" L))
(CL:UNLESS (EQ 'Y (ASKUSER NIL NIL (CONCAT L
" Ignore remaining files? "
)))
(ERROR!)))
(HELP "Unrecognized git-diff code" (NTHCHAR L 1]
T])
(GIT-APPROVAL
[LAMBDA (BRANCH) (* ; "Edited 19-Nov-2021 15:08 by rmk:")
@@ -734,7 +719,7 @@
ELSEIF (NOT NOERROR)
THEN (ERROR "Unknown branch" BRANCH])
(PICK-BRANCH
(GIT-PICK-BRANCH
[LAMBDA (BRANCHES TITLE WHERE) (* ; "Edited 6-Mar-2022 08:55 by rmk")
(* ; "Edited 25-Feb-2022 09:02 by rmk")
(MENU (CREATE MENU
@@ -743,6 +728,28 @@
(GIT-BRANCHES WHERE))
MENUFONT _ DEFAULTFONT])
(GIT-PRC-MENU
[LAMBDA (DRAFT) (* ; "Edited 29-Apr-2022 11:36 by rmk")
(LET* [(PRS (GIT-PULL-REQUESTS T DRAFT))
(SUPERSETS (CAR (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (CADDR PR]
(* ;; "Reverse on the theory that rmknnn's should be ordered from nnn highest to lowest")
(DREVERSE (SORT [FOR PR SUP LABEL IN PRS
COLLECT (SETQ LABEL (CL:IF [SETQ SUP (CAR (CDR (ASSOC (CADDR PR)
SUPERSETS]
(CONCAT (CADDR PR)
" > " SUP)
(CADDR PR)))
(LIST (CL:IF (MEMB 'DRAFT PR)
(CONCAT LABEL " (draft)")
LABEL)
(GITORIGIN (CADDR PR))
(CONCAT " " (CADR PR)
" #"
(CAR PR]
T])
(GIT-PULL-REQUESTS
[LAMBDA (ALLINFO INCLUDEDRAFTS) (* ; "Edited 25-Feb-2022 09:26 by rmk")
(FOR LINE TAB1 TAB2 TAB3 VAL IN (GIT-COMMAND "gh pr list" T)
@@ -759,6 +766,53 @@
,(SUBATOM LINE (ADD1 TAB3]
ELSE (SUBATOM LINE (ADD1 TAB2)
(SUB1 TAB3])
(GIT-BRANCH-RELATIONS
[LAMBDA (BRANCHES BRANCH2) (* ; "Edited 29-Apr-2022 11:05 by rmk")
(* ;; "Returns a pair (SUPERSETS EQUALS), where each item in SUPERSETS is a list of the form (B0 B1 B2...) where each Bi is a superset of Bj for i < j and EQUALS is a list of branch equivalence classes. ")
(CL:WHEN BRANCH2
(SETQ BRANCHES (LIST BRANCHES BRANCH2)))
(FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS ON [FOR B IN BRANCHES
COLLECT (CONS B (GIT-BRANCH-DIFF (GITORIGIN
B)
'origin/master]
DO (SETQ D1 (CAR DTAIL))
[FOR D2 IN (CDR DTAIL)
DO (SETQ MORE1 (CL:SET-DIFFERENCE (CDR D1)
(CDR D2)
:TEST
(FUNCTION EQUAL)))
(SETQ MORE2 (CL:SET-DIFFERENCE (CDR D2)
(CDR D1)
:TEST
(FUNCTION EQUAL)))
(IF MORE2
THEN (CL:UNLESS MORE1
(PUSH [CDR (OR (ASSOC (CAR D2)
SUPERSETS)
(CAR (PUSH SUPERSETS (CONS (CAR D2]
(CAR D1)))
ELSEIF MORE1
THEN (PUSH [CDR (OR (ASSOC (CAR D1)
SUPERSETS)
(CAR (PUSH SUPERSETS (CONS (CAR D1]
(CAR D2))
ELSE (PUSH [CDR (OR (ASSOC (CAR D1)
EQUALS)
(CAR (PUSH EQUALS (CONS (CAR D1]
(CAR D2]
FINALLY
(* ;; "Sort the supersets so that the larger ones come before the smaller ones")
[FOR S IN SUPERSETS
DO (CHANGE (CDR S)
(SORT DATUM (FUNCTION (LAMBDA (B1 B2)
(OR (MEMB B2 (CDR (ASSOC B1 SUPERSETS)))
(NOT (MEMB B1 (CDR (ASSOC B2 SUPERSETS]
(RETURN (LIST SUPERSETS EQUALS])
)
@@ -905,12 +959,7 @@
(DEFINEQ
(GIT-GET-DIFFERENT-FILES
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 7-Mar-2022 08:14 by rmk")
(* ; "Edited 24-Feb-2022 23:57 by rmk")
(* ; "Edited 23-Feb-2022 18:47 by rmk")
(* ; "Edited 12-Feb-2022 18:35 by rmk")
(* ; "Edited 23-Jan-2022 21:45 by rmk")
(* ; "Edited 11-Jan-2022 11:03 by rmk")
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 29-Apr-2022 07:53 by rmk")
(* ; "Edited 5-Jan-2022 08:01 by rmk")
(DECLARE (USEDFREE FROMGITN))
@@ -942,26 +991,23 @@
(CL:UNLESS DIR2
(SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2)
">")))
(FOR DLIST IN DIFFS
DO (SELECTQ (CAR DLIST)
(FOR D IN DIFFS
DO (SELECTQ (CAR D)
(ADDED (* ;
 "Shouldn't exist in MERGE, should exist in BRANCH1")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE
))))
(GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 (CADR D))))
(DELETED
(* ;; "Shouldn't exist in BRANCH1, should exist in MERGE. But maybe git is just confused in marking a file that exists in the wrong place as a delete instead of an add, or maybe it may think of a file that doesn't exist at all as having been deleted. Try for both, but don't cause an error.")
(FOR GFILE IN (CDR DLIST) DO (OR (GIT-GET-FILE MERGE GFILE
(CONCAT DIR2 GFILE)
T)
(GIT-GET-FILE BRANCH1 GFILE
(CONCAT DIR1 GFILE)
T))))
(SETQ D (CADR D))
(OR (GIT-GET-FILE MERGE D (CONCAT DIR2 D)
T)
(GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)
T)))
(CHANGED (* ; "Should exist in both branches")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1
GFILE))
(GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE
))))
(SETQ D (CADR D))
(GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D))
(GIT-GET-FILE MERGE D (CONCAT DIR2 D)))
((RENAMED COPIED)
(* ;; "These entries are from-to filename pairs. If (CADDR) is 100, only need to fetch one, because it presumably has disappeared in MERGE and reappeared in BRANCH1. MAPPINGS is returned so the connection can be reestablished higher up. ")
@@ -971,32 +1017,35 @@
(* ;; "For copied files, presumably 2 files are exactly the same. But we hope we can show them on the same line, by virtue of the mapping.")
(FOR GFILE F1 IN (CDR DLIST)
DO
(* ;; "F1 is the file in branch 1, if any, F2 is in branch 2")
(LET ((GFILE (CDR D))
F1)
[SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE)
(CONCAT DIR1 (CADR GFILE]
(IF (EQ (CADDR GFILE)
100)
THEN
(* ;; "GFILE is a triple (F2 F1 N )")
(* ;; "F1 is the file in branch 1, if any, F2 is in branch 2")
[SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE)
(CONCAT DIR1 (CADR GFILE]
(IF (EQ (CADDR GFILE)
100)
THEN
(* ;; "A little tricky to figure out what corresponds to the real file in the mapping, which directory it belongs to. Maybe the first one should always be one that exists, the second may just be a useful name. But we have to know whether to match against INFO1 or INFO2")
(PUSH MAPPINGS (LIST (FULLNAME F1)
(SLASHIT (U-CASE (CONCAT DIR2
(CAR GFILE)))
T)
(NTHCHAR (CAR DLIST)
1)
100))
ELSE
(* ;;
(PUSH MAPPINGS (LIST (FULLNAME F1)
(SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE))
)
T)
(NTHCHAR (CAR D)
1)
100))
ELSE
(* ;;
 "If not a perfect match, then the directory should figure it out")
(GIT-GET-FILE MERGE (CAR GFILE)
(CONCAT DIR2 (CAR GFILE))
T))))
(GIT-GET-FILE MERGE (CAR GFILE)
(CONCAT DIR2 (CAR GFILE))
T))))
(HELP "UNKNOWN GIT-DIFF TAG" DLIST)))
(LIST DIR1 DIR2 MAPPINGS))])
@@ -1436,22 +1485,23 @@
(ERROR "INITIALS is not set"])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4696 5542 (GIT-CLONEP 4706 . 5540)) (7977 9957 (ALLSUBDIRS 7987 . 9155) (MEDLEYSUBDIRS
9157 . 9596) (GITSUBDIRS 9598 . 9955)) (9958 15432 (TOGIT 9968 . 12116) (FROMGIT 12118 . 13096) (
GIT-DELETE-FILE 13098 . 13992) (MYMEDLEY-DELETE-FILES 13994 . 15430)) (15433 17582 (MYMEDLEYSUBDIR
15443 . 15889) (GITSUBDIR 15891 . 16214) (STRIPDIR 16216 . 16587) (STRIPHOST 16589 . 16825) (STRIPNAME
16827 . 17580)) (17583 19111 (GFILE4MFILE 17593 . 17839) (MFILE4GFILE 17841 . 18183) (
GIT-REPO-FILENAME 18185 . 19109)) (19160 30112 (GIT-COMMIT 19170 . 19748) (GIT-PUSH 19750 . 20306) (
GIT-PULL 20308 . 20714) (GIT-BRANCH-DIFF 20716 . 24696) (GIT-APPROVAL 24698 . 24899) (GIT-GET-FILE
24901 . 27201) (GIT-FILE-EXISTS? 27203 . 28030) (GIT-REMOTE-UPDATE 28032 . 29074) (GIT-REMOTE-ADD
29076 . 29383) (GIT-FILE-DATE 29385 . 30110)) (30157 36214 (GIT-CHECKOUT 30167 . 30408) (
GIT-WHICH-BRANCH 30410 . 30994) (GIT-MAKE-BRANCH 30996 . 32487) (GIT-BRANCHES 32489 . 33663) (
GIT-BRANCH-EXISTS? 33665 . 34862) (PICK-BRANCH 34864 . 35314) (GIT-PULL-REQUESTS 35316 . 36212)) (
36244 39076 (GIT-MY-CURRENT-BRANCH 36254 . 36427) (GIT-MY-BRANCHP 36429 . 37348) (GIT-MY-NEXT-BRANCH
37350 . 37791) (GIT-MY-BRANCHES 37793 . 39074)) (39122 43014 (GIT-ADD-WORKTREE 39132 . 41014) (
GIT-REMOVE-WORKTREE 41016 . 41594) (GIT-LIST-WORKTREES 41596 . 42400) (WORKTREEDIR 42402 . 43012)) (
43062 71199 (GIT-GET-DIFFERENT-FILES 43072 . 49507) (GIT-COMPARE-BRANCHES 49509 . 55301) (
GIT-COMPARE-WITH-MYMEDLEY 55303 . 59061) (GIT-COMPARE-WORKTREE 59063 . 62540) (GITCDOBJBUTTONFN 62542
. 67546) (GIT-CD-LABELFN 67548 . 68630) (GIT-CD-MENUFN 68632 . 71197)) (71269 74938 (CDGITDIR 71279
. 71975) (GIT-COMMAND 71977 . 74051) (GITORIGIN 74053 . 74630) (GIT-INITIALS 74632 . 74936)))))
(FILEMAP (NIL (4721 5567 (GIT-CLONEP 4731 . 5565)) (7335 9315 (ALLSUBDIRS 7345 . 8513) (MEDLEYSUBDIRS
8515 . 8954) (GITSUBDIRS 8956 . 9313)) (9316 14790 (TOGIT 9326 . 11474) (FROMGIT 11476 . 12454) (
GIT-DELETE-FILE 12456 . 13350) (MYMEDLEY-DELETE-FILES 13352 . 14788)) (14791 16940 (MYMEDLEYSUBDIR
14801 . 15247) (GITSUBDIR 15249 . 15572) (STRIPDIR 15574 . 15945) (STRIPHOST 15947 . 16183) (STRIPNAME
16185 . 16938)) (16941 18469 (GFILE4MFILE 16951 . 17197) (MFILE4GFILE 17199 . 17541) (
GIT-REPO-FILENAME 17543 . 18467)) (18518 29311 (GIT-COMMIT 18528 . 19106) (GIT-PUSH 19108 . 19664) (
GIT-PULL 19666 . 20072) (GIT-BRANCH-DIFF 20074 . 23895) (GIT-APPROVAL 23897 . 24098) (GIT-GET-FILE
24100 . 26400) (GIT-FILE-EXISTS? 26402 . 27229) (GIT-REMOTE-UPDATE 27231 . 28273) (GIT-REMOTE-ADD
28275 . 28582) (GIT-FILE-DATE 28584 . 29309)) (29356 39349 (GIT-CHECKOUT 29366 . 29607) (
GIT-WHICH-BRANCH 29609 . 30193) (GIT-MAKE-BRANCH 30195 . 31686) (GIT-BRANCHES 31688 . 32862) (
GIT-BRANCH-EXISTS? 32864 . 34061) (GIT-PICK-BRANCH 34063 . 34517) (GIT-PRC-MENU 34519 . 35819) (
GIT-PULL-REQUESTS 35821 . 36717) (GIT-BRANCH-RELATIONS 36719 . 39347)) (39379 42211 (
GIT-MY-CURRENT-BRANCH 39389 . 39562) (GIT-MY-BRANCHP 39564 . 40483) (GIT-MY-NEXT-BRANCH 40485 . 40926)
(GIT-MY-BRANCHES 40928 . 42209)) (42257 46149 (GIT-ADD-WORKTREE 42267 . 44149) (GIT-REMOVE-WORKTREE
44151 . 44729) (GIT-LIST-WORKTREES 44731 . 45535) (WORKTREEDIR 45537 . 46147)) (46197 73219 (
GIT-GET-DIFFERENT-FILES 46207 . 51527) (GIT-COMPARE-BRANCHES 51529 . 57321) (GIT-COMPARE-WITH-MYMEDLEY
57323 . 61081) (GIT-COMPARE-WORKTREE 61083 . 64560) (GITCDOBJBUTTONFN 64562 . 69566) (GIT-CD-LABELFN
69568 . 70650) (GIT-CD-MENUFN 70652 . 73217)) (73289 76958 (CDGITDIR 73299 . 73995) (GIT-COMMAND 73997
. 76071) (GITORIGIN 76073 . 76650) (GIT-INITIALS 76652 . 76956)))))
STOP

BIN
lispusers/GITFNS.LCOM
View File

Binary file not shown.

547
lispusers/PRETTYFILEINDEX
View File

@@ -1,10 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-Nov-2021 22:12:37" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;2 94399
(FILECREATED " 5-May-2022 23:33:03" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PRETTYFILEINDEX.;10 96446
:CHANGES-TO (FNS PFI.PRINT.FILECREATED)
:CHANGES-TO (FNS PFI.PRINT.COMMENTS PFI.MAYBE.NEW.PAGE PFI.MAYBE.PP.DEFINITION
PFI.PRINT.FILECREATED PFI.MAYBE.SEE.PRETTY PRETTYFILEINDEX PFI.PRINT.TO.TAB)
:PREVIOUS-DATE " 9-Jul-2021 21:55:15" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;1)
:PREVIOUS-DATE "30-Nov-2021 22:12:37"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PRETTYFILEINDEX.;6)
(* ; "
@@ -39,7 +42,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST
PFI.MERGE.INDICES))
(COMS (* ;
 "Hooks for seeing files pretty elsewhere")
 "Hooks for seeing files pretty elsewhere")
(FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION)
(INITVARS (*PRINT-PRETTY-FROM-FILES* T)))
(COMS (* ; "Bitmap hack")
@@ -57,7 +60,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
*KEYWORD-PACKAGE*)))
(* ;;
 "Properties of definers changed between Lyric and Medley (yech).")
 "Properties of definers changed between Lyric and Medley (yech).")
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
(FUNCTION CL:INTERN]
@@ -102,7 +105,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(READVICE ADVICE))
(*PFI-FILTERS* (VARIABLES . CONSTANTS)))
(COMS (* ;
 "Prettyprint augmentation to mimic system makefile dumping")
 "Prettyprint augmentation to mimic system makefile dumping")
(FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT
MAYBE.PRETTYPRINT.BOLD)
(ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM)))
@@ -119,7 +122,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS*
*COMMON-LISP-READ-ENVIRONMENT*))
[DECLARE%: EVAL@COMPILE DOCOPY (* ;
 "Public variables to declare special")
 "Public variables to declare special")
(P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS*
*PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS*
*PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS*
@@ -130,11 +133,11 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(FILESLOAD (SYSLOAD)
DEFINERPRINT))
(* ;
 "Get prettyprinter fixes if running in old sysout")
 "Get prettyprinter fixes if running in old sysout")
(MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
S)
(* ;
 "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
 "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
LP
(COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
(GETD S))
@@ -145,8 +148,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
((SETQ SYMS (CDR SYMS))
(GO LP))
(T (* ;
 "Neither one loaded, take original")
(T (* ; "Neither one loaded, take original")
(RETURN 'LISTFILES1]
'PFI.ORIGINAL.LISTFILES1 NIL T)
(MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T)
@@ -182,11 +184,12 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(DEFINEQ
(PRETTYFILEINDEX
[LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 9-Jul-2021 21:35 by rmk:")
(* ; "Edited 11-Apr-95 00:02 by rmk:")
(* ; "Edited 11-Jun-92 15:58 by cat")
[LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 5-May-2022 14:38 by rmk")
(* ; "Edited 9-Jul-2021 21:35 by rmk:")
(* ; "Edited 11-Apr-95 00:02 by rmk:")
(* ; "Edited 11-Jun-92 15:58 by cat")
(* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.")
(* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.")
(RESETLST
[PROG ((*STANDARD-OUTPUT* *STANDARD-OUTPUT*)
@@ -215,146 +218,140 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(*PFI-PENDING-COMMENTS*)
FILECREATED ENV WASOPEN MULTIFILEINDEX CRDATE INDICES PART# FIRSTPAGE LASTPAGE CRDATE)
(* ;; "Specials are as follows:")
(* ;; "Specials are as follows:")
(* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image")
(* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image")
(* ;; "*PFI-PAGE-COUNT* -- number of current page")
(* ;; "*PFI-PAGE-COUNT* -- number of current page")
(* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing")
(* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing")
(* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers")
(* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers")
(* ;; "*PFI-ITEM* -- function, etc currently being printed")
(* ;; "*PFI-ITEM* -- function, etc currently being printed")
(* ;; "*PFI-TYPES* -- list specifying the type associated with an expression")
(* ;; "*PFI-TYPES* -- list specifying the type associated with an expression")
(* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*")
(* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*")
(* ;;
 "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF")
(* ;;
 "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF")
(* ;;
 "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences")
(* ;;
 "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences")
(* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.")
(* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.")
(* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars")
(* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars")
(* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default")
(* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default")
(* ;;
 "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed")
(* ;;
 "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed")
(* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.")
(* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.")
[if (TYPENAMEP FILENAME 'STREAM)
then (* ; "Already have input stream")
[SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT]
then (* ; "Already have input stream")
[SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT]
else (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
(SETQ *STANDARD-INPUT* (OPENSTREAM
FILENAME
'INPUT
'OLD
'((SEQUENTIAL T]
(SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME 'INPUT
'OLD
'((SEQUENTIAL T]
(SETQ FILENAME (FULLNAME *STANDARD-INPUT*))
[if (LISTGET PRINTOPTIONS :COMMON)
then (* ; "Common Lisp file")
(SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*)
else (* ;
 "Figure out if this is a file manager file, and if so get environment")
(CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED)
(\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T))
(if (NULL FILECREATED)
then (* ; "Not a File Manager file")
(RETURN NIL)
elseif (NEQ (CAR (LISTP FILECREATED))
'FILECREATED)
then (* ;
 "File started with open paren, but isn't file manager file.")
(RETURN (if WASOPEN
then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy")
(PRINTDEF FILECREATED T T NIL NIL OUTSTREAM)
(PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM)
(* ; "non-nil return says we did it")
FILENAME))
elseif (LISTP (CADDR FILECREATED))
then (* ;
 "A compiled file--just use COPYBYTES to avoid binary hassles.")
(RETURN (if WASOPEN
then (* ;
 "Print environment and filecreated before copying rest")
(PRINT-READER-ENVIRONMENT ENV OUTSTREAM)
(WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED
OUTSTREAM))
(COPYBYTES *STANDARD-INPUT* OUTSTREAM)
(* ; "non-nil return says we did it")
FILENAME]
then (* ; "Common Lisp file")
(SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*)
else (* ;
 "Figure out if this is a file manager file, and if so get environment")
(CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED)
(\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T))
(if (NULL FILECREATED)
then (* ; "Not a File Manager file")
(RETURN NIL)
elseif (NEQ (CAR (LISTP FILECREATED))
'FILECREATED)
then (* ;
 "File started with open paren, but isn't file manager file.")
(RETURN (if WASOPEN
then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy")
(PRINTDEF FILECREATED T T NIL NIL OUTSTREAM)
(PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM)
(* ; "non-nil return says we did it")
FILENAME))
elseif (LISTP (CADDR FILECREATED))
then (* ;
 "A compiled file--just use COPYBYTES to avoid binary hassles.")
(RETURN (if WASOPEN
then (* ;
 "Print environment and filecreated before copying rest")
(PRINT-READER-ENVIRONMENT ENV OUTSTREAM)
(WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED
OUTSTREAM))
(COPYBYTES *STANDARD-INPUT* OUTSTREAM)
(* ; "non-nil return says we did it")
FILENAME]
(CL:UNLESS DONTINDEX (CL:FORMAT PROMPTWINDOW "~%%Starting index of ~A." FILENAME))
[if OUTSTREAM
then (SETQ *PFI-TITLE* FILENAME)
(SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT))
(SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT))
else (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS 'DOCUMENT.NAME))
(push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME)))
(SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT)
(if NOPRINT
then
(* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually")
(\CORE.CLOSEFILE STREAM)
(replace (STREAM ACCESS)
of STREAM with NIL)
(\GENERIC-UNREGISTER-STREAM
(fetch (STREAM DEVICE)
of STREAM)
STREAM)
(\CORE.DELETEFILE
(FULLNAME STREAM)
(fetch (STREAM DEVICE)
of STREAM))
else (CLOSEF? STREAM]
*STANDARD-OUTPUT*
(LISTGET PRINTOPTIONS :DONTPRINT]
(* ;
 "Make sure printer knows original name of file")
(push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME)))
(SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT)
(if NOPRINT
then
(* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually")
(\CORE.CLOSEFILE STREAM)
(replace (STREAM ACCESS) of STREAM
with NIL)
(\GENERIC-UNREGISTER-STREAM
(fetch (STREAM DEVICE) of STREAM)
STREAM)
(\CORE.DELETEFILE (FULLNAME STREAM)
(fetch (STREAM DEVICE)
of STREAM))
else (CLOSEF? STREAM]
*STANDARD-OUTPUT*
(LISTGET PRINTOPTIONS :DONTPRINT]
(* ;
 "Make sure printer knows original name of file")
(RESETSAVE (LINELENGTH (IQUOTIENT (- (DSPRIGHTMARGIN)
(DSPLEFTMARGIN))
(CHARWIDTH (CHARCODE X)
*STANDARD-OUTPUT*))
*STANDARD-OUTPUT*))
(if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*))
(if (NOT (IMAGESTREAMP *STANDARD-OUTPUT*))
then (PFI.SETUP.TRANSLATIONS))
[if DONTINDEX
then (* ; "This is for SEE etc")
(SETQ *PFI-MAX-WASTED-LINES* 0)
(SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother")
(SETQ *PFI-LOCATIONS* :NONE)
else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE))
(* ; "Enable header printing")
then (* ; "This is for SEE etc")
(SETQ *PFI-MAX-WASTED-LINES* 0)
(SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother")
(SETQ *PFI-LOCATIONS* :NONE)
else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE))
(* ; "Enable header printing")
(* ;; "RMK: NOBIND here seems to be deliberate, it seems somehow to match the NOBIND that appears in PFI.HANDLE.RPAQQ.")
(* ;; "RMK: NOBIND here seems to be deliberate, it seems somehow to match the NOBIND that appears in PFI.HANDLE.RPAQQ.")
[SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND]
(* ; "Says to do something with coms")
[if (NOT (FIXP *PFI-MAX-WASTED-LINES*))
then (* ;
 "a parameter expressed as a fraction of page")
(SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES*
(- (PFI.LINES.REMAINING
)
2]
[SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES)
(PFI.COLLECT.DEFINERS
*PFI-TYPES*]
(* ;
 "Add known record types and definers to the list.")
(SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE]
[SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND]
(* ; "Says to do something with coms")
[if (NOT (FIXP *PFI-MAX-WASTED-LINES*))
then (* ;
 "a parameter expressed as a fraction of page")
(SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES*
(- (PFI.LINES.REMAINING)
2]
[SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES)
(PFI.COLLECT.DEFINERS *PFI-TYPES*]
(* ;
 "Add known record types and definers to the list.")
(SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE]
[SETQ *PFI-PAGE-COUNT* (SETQ FIRSTPAGE (LOGOR (OR (LISTGET PRINTOPTIONS :FIRSTPAGE)
1)
(if *PFI-TWO-SIDED*
then
(* ; "Make first page odd")
1
(* ; "Make first page odd")
1
else 0]
(if (SETQ PART# (LISTGET PRINTOPTIONS :PART))
then (SETQ *PFI-PAGE-PREFIX* (CONCAT *PFI-PAGE-PREFIX* PART# "-")))
@@ -363,30 +360,29 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
then (PFI.PRINT.FILECREATED FILECREATED ENV))
(PFI.PROCESS.FILE DONTINDEX)
(if (NOT WASOPEN)
then (* ;
 "We're through with input file now, so release it")
(CLOSEF *STANDARD-INPUT*))
then (* ;
 "We're through with input file now, so release it")
(CLOSEF *STANDARD-INPUT*))
(if (SETQ MULTIFILEINDEX (LISTGET PRINTOPTIONS 'MULTIFILEINDEX))
then (* ;
 "True on calls from multifileindex-remember the date and last page#")
(SETQ LASTPAGE *PFI-PAGE-COUNT*))
then (* ;
 "True on calls from multifileindex-remember the date and last page#")
(SETQ LASTPAGE *PFI-PAGE-COUNT*))
(if (NOT DONTINDEX)
then (* ;
 "Now that we've scanned whole file, print the index")
(SETQ INDICES (PFI.PRINT.INDEX CRDATE)))
then (* ;
 "Now that we've scanned whole file, print the index")
(SETQ INDICES (PFI.PRINT.INDEX CRDATE)))
[if (NULL OUTSTREAM)
then (CL:FORMAT PROMPTWINDOW "~%%Finished indexing ~A (~D pages)"
FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE]
FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE]
(if (NULL MULTIFILEINDEX)
then FILENAME
else (push INDICES (LIST FILENAME CRDATE LASTPAGE ENV))
(if (NLISTP MULTIFILEINDEX)
then (* ;
 "More to do yet, so just return this index")
INDICES
else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX
INDICES)
PRINTOPTIONS))))])])
(if (NLISTP MULTIFILEINDEX)
then (* ;
 "More to do yet, so just return this index")
INDICES
else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX INDICES)
PRINTOPTIONS))))])])
(PFI.MAKE.LPT.STREAM
[LAMBDA (PRINTOPTIONS) (* ; "Edited 12-Nov-93 09:53 by rmk:")
@@ -458,22 +454,20 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(DEFINEQ
(PFI.PRINT.FILECREATED
[LAMBDA (EXPR ENV) (* ;
 "Edited 30-Nov-2021 22:08 by larry")
(* ;
 "Edited 30-Nov-2021 21:40 by larry")
(* ;
 "Edited 9-Jul-2021 07:59 by rmk:")
[LAMBDA (EXPR ENV) (* ; "Edited 5-May-2022 21:53 by rmk")
(* ; "Edited 30-Nov-2021 22:08 by larry")
(* ; "Edited 30-Nov-2021 21:40 by larry")
(* ; "Edited 9-Jul-2021 07:59 by rmk:")
(* ;; "Display the FILECREATED expression and environment prettily")
(* ;;
 "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
 "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
(pop EXPR)
(CHANGEFONT ITALICFONT)
(LET* [(STRINGS '("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:"
"Format:"))
(LET* [(STRINGS '("File created: " "changes to: " "previous date: " "Read Table: "
"Package: " "Base: " "Format: "))
(FONT (DSPFONT))
(STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT)))
(TABSTOP (+ (DSPLEFTMARGIN)
@@ -486,42 +480,42 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
" " .FONT LAMBDAFONT (pop EXPR)
T T) (* ; "date and file name")
(if (OR (NULL (CAR EXPR))
(FIXP (CAR EXPR)))
then (* ; "Skip over filemaploc")
(pop EXPR))
(FIXP (CAR EXPR)))
then (* ; "Skip over filemaploc")
(pop EXPR))
(if (SELECTQ (CAR EXPR)
(changes (SETQ EXPR (CDR EXPR))
T)
(:CHANGES-TO T)
NIL)
then (* ; "handle %"Changes to:%"")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(SETQ EXPR (CDR EXPR))
(PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR))
T NIL T)
(TERPRI)
(TERPRI)
else (pop STRINGS)
(pop STRWIDTHS))
(if (SELECTQ (CAR EXPR)
(previous (SETQ EXPR (CDR EXPR))
T)
(:PREVIOUS-DATE
(changes (SETQ EXPR (CDR EXPR))
T)
NIL)
then (* ; "Handle %"Previous date:%"")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(SETQ EXPR (CDR EXPR))
(PRINTOUT NIL (pop EXPR)
" "
(pop EXPR)
T T)
(:CHANGES-TO T)
NIL)
then (* ; "handle %"Changes to:%"")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(SETQ EXPR (CDR EXPR))
(PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR))
T NIL T)
(TERPRI)
(TERPRI)
else (pop STRINGS)
(pop STRWIDTHS))
(pop STRWIDTHS))
(if (SELECTQ (CAR EXPR)
(previous (SETQ EXPR (CDR EXPR))
T)
(:PREVIOUS-DATE
T)
NIL)
then (* ; "Handle %"Previous date:%"")
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(SETQ EXPR (CDR EXPR))
(PRINTOUT NIL (pop EXPR)
" "
(pop EXPR)
T T)
else (pop STRINGS)
(pop STRWIDTHS))
(* ;; "Show environment")
@@ -535,9 +529,9 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(PFI.PRINT.ENVIRONMENT ENV :PACKAGE)
(if (NEQ *PRINT-BASE* 10)
then (PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
TABSTOP)
(PFI.PRINT.ENVIRONMENT ENV :BASE)
(pop STRWIDTHS)
TABSTOP)
(PFI.PRINT.ENVIRONMENT ENV :BASE)
else (pop STRINGS))
(PFI.PRINT.TO.TAB (pop STRINGS)
(pop STRWIDTHS)
@@ -545,8 +539,16 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(PFI.PRINT.ENVIRONMENT ENV :FORMAT])
(PFI.PRINT.TO.TAB
(LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT))
)
[LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm")
(* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.")
(CHANGEFONT ITALICFONT)
(DSPXPOSITION (- TABSTOP WIDTH))
(PRIN3 STR)
(RELMOVETO (TIMES 12 (DSPSCALE))
0)
(CHANGEFONT DEFAULTFONT])
(PFI.PRINT.ENVIRONMENT
[LAMBDA (ENV KEYWORD) (* ; "Edited 9-Jul-2021 08:03 by rmk:")
@@ -614,8 +616,19 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
)
(PFI.MAYBE.NEW.PAGE
(LAMBDA (EXPR MINLINES) (* ; "Edited 13-Apr-88 14:32 by bvm") (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") (LET (REMAINING) (if (OR (DISPLAYSTREAMP *STANDARD-OUTPUT*) (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) *PFI-MAX-WASTED-LINES*) (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR)))) then (TERPRI) else (* ; "put it on a new page") (DSPNEWPAGE))))
)
[LAMBDA (EXPR MINLINES) (* ; "Edited 5-May-2022 23:31 by rmk")
(* ; "Edited 13-Apr-88 14:32 by bvm")
(* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess")
(LET (REMAINING)
(if [OR (IMAGESTREAMP *STANDARD-OUTPUT*)
(> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING)))
*PFI-MAX-WASTED-LINES*)
(>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR]
then (TERPRI)
else (* ; "put it on a new page")
(DSPNEWPAGE])
(PFI.ESTIMATE.SIZE
(LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:37 by bvm") (* ;; "Guess how many lines EXPR will take, so that we can try getting it all on one page if we're near the bottom. Heuristic is that after the first list element in any element, each subsequent element gets its own line") (+ (LET ((TEMPLATE (AND (LITATOM (CAR EXPR)) (GET (CAR EXPR) :DEFINITION-PRINT-TEMPLATE)))) (if (AND TEMPLATE (MEMB :BODY TEMPLATE)) then (* ; "Make extra space for things that have body") 2 else 1)) (PFI.ESTIMATE.SIZE1 EXPR 0)))
@@ -677,8 +690,29 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
)
(PFI.PRINT.COMMENTS
(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:27 by bvm") (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") (TERPRI) (DESTRUCTURING-BIND (LINES . BODIES) *PFI-PENDING-COMMENTS* (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (LET ((REMAINING (PFI.LINES.REMAINING))) (if (OR (>= LINES REMAINING) (AND (< REMAINING *PFI-MAX-WASTED-LINES*) (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) LINES)))) then (* ; "put it on a new page") (DSPNEWPAGE)))) (for B in BODIES do (PRINTDEF B T T) (if (> (DSPXPOSITION) (DSPLEFTMARGIN)) then (* ; "Go to new line for next comment. Usually this has already been done") (TERPRI))) (SETQ *PFI-PENDING-COMMENTS* NIL)))
)
[LAMBDA (EXPR) (* ; "Edited 5-May-2022 23:27 by rmk")
(* ; "Edited 7-Apr-88 12:27 by bvm")
(* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.")
(TERPRI)
(DESTRUCTURING-BIND (LINES . BODIES)
*PFI-PENDING-COMMENTS*
[if (NOT (IMAGESTREAMP *STANDARD-OUTPUT*))
then (LET ((REMAINING (PFI.LINES.REMAINING)))
(if [OR (>= LINES REMAINING)
(AND (< REMAINING *PFI-MAX-WASTED-LINES*)
(< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR)
LINES]
then (* ; "put it on a new page")
(DSPNEWPAGE]
(for B in BODIES do (PRINTDEF B T T)
(if (> (DSPXPOSITION)
(DSPLEFTMARGIN))
then (* ;
 "Go to new line for next comment. Usually this has already been done")
(TERPRI)))
(SETQ *PFI-PENDING-COMMENTS* NIL])
(PFI.HANDLE.FILEMAP
(LAMBDA (EXPR) (* ; "Edited 31-Mar-88 15:28 by bvm") (* ;; "Only get here from declare: previewer (during SEE), since declare: expression handler filters out the whole thing.") (PFI.PRETTYPRINT (LIST (QUOTE *) (QUOTE ;;) "---Filemap elided by lister---") NIL T))
@@ -791,12 +825,57 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(DEFINEQ
(PFI.MAYBE.SEE.PRETTY
(LAMBDA (FROMFILE TOFILE) (* ; "Edited 1-Apr-88 11:23 by bvm") (* ;; "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) OUTSTREAM INSTREAM) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NULL (SETQ OUTSTREAM (DISPLAYP TOFILE)))) then (* ; "Not a display window, or don't want prettyprinting") (if (STREAMP FROMFILE) then (* ; "Wanted PFCOPYBYTES") (PFCOPYBYTES FROMFILE TOFILE) else (COPYALLBYTES FROMFILE TOFILE)) else (if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ INSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) else (PFCOPYBYTES INSTREAM OUTSTREAM) (FULLNAME INSTREAM))))))
)
[LAMBDA (FROMFILE TOFILE) (* ; "Edited 5-May-2022 14:29 by rmk")
(* ; "Edited 1-Apr-88 11:23 by bvm")
(* ;;
 "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file")
(RESETLST
[LET ((*UPPER-CASE-FILE-NAMES* NIL)
OUTSTREAM INSTREAM)
(if [OR (NULL *PRINT-PRETTY-FROM-FILES*)
(NULL (SETQ OUTSTREAM (IMAGESTREAMP TOFILE]
then (* ;
 "Not a display window, or don't want prettyprinting")
(if (STREAMP FROMFILE)
then (* ; "Wanted PFCOPYBYTES")
(PFCOPYBYTES FROMFILE TOFILE)
else (COPYALLBYTES FROMFILE TOFILE))
else [if (NOT (SETQ INSTREAM (STREAMP FROMFILE)))
then (RESETSAVE NIL (LIST 'CLOSEF (SETQ INSTREAM (OPENSTREAM
FROMFILE
'INPUT NIL
'((SEQUENTIAL T]
(* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file")
(if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T)
else (PFCOPYBYTES INSTREAM OUTSTREAM)
(FULLNAME INSTREAM])])
(PFI.MAYBE.PP.DEFINITION
(LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 1-Apr-88 11:22 by bvm") (LET (ENV) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NOT (DISPLAYP OUTSTREAM)) (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) (WITH-READER-ENVIRONMENT ENV (SETFILEPTR INSTREAM START) (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) (IGNORE-ERRORS (READ INSTREAM)) (LET ((*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT)))) (if CONDITION then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) T else (PFI.PRINT.LAMBDA.BODY DEF) (TERPRI) NIL))))) then (* ;; "Punt to what we were called for in the first place") (PFCOPYBYTES INSTREAM OUTSTREAM START END))))
)
[LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 5-May-2022 23:14 by rmk")
(* ; "Edited 1-Apr-88 11:22 by bvm")
(LET (ENV)
(if [OR (NULL *PRINT-PRETTY-FROM-FILES*)
(NOT (IMAGESTREAMP OUTSTREAM))
(NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM)))
(WITH-READER-ENVIRONMENT ENV
(SETFILEPTR INSTREAM START)
(CL:MULTIPLE-VALUE-BIND (DEF CONDITION)
(IGNORE-ERRORS (READ INSTREAM))
(LET [(*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT]
(if CONDITION
then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION)
T
else (PFI.PRINT.LAMBDA.BODY DEF)
(TERPRI)
NIL))))]
then
(* ;; "Punt to what we were called for in the first place")
(PFCOPYBYTES INSTREAM OUTSTREAM START END])
)
(RPAQ? *PRINT-PRETTY-FROM-FILES* T)
@@ -821,20 +900,19 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(RPAQ? *PFI-MAX-WASTED-LINES* 12)
(RPAQ? *PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172)
(96 169 FAMILY CLASSIC)
(39 185 FAMILY CLASSIC))))
(96 169 FAMILY CLASSIC)
(39 185 FAMILY CLASSIC))))
(RPAQ? *PFI-INDEX-ORDER* '(FUNCTIONS))
(RPAQ? *PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC)
then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))
)
(* ;;
 "Properties of definers changed between Lyric and Medley (yech).")
then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*)))
(* ;;
 "Properties of definers changed between Lyric and Medley (yech).")
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
(FUNCTION CL:INTERN))))
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
(FUNCTION CL:INTERN))))
(RPAQ? \PFI.PROCESS.COMMANDS )
@@ -885,10 +963,10 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN))
(ADDTOVAR *PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE)
(DEFINEQ . PFI.PREVIEW.DEFINEQ))
(DEFINEQ . PFI.PREVIEW.DEFINEQ))
(ADDTOVAR *PFI-PROPERTIES* (COPYRIGHT)
(READVICE ADVICE))
(READVICE ADVICE))
(ADDTOVAR *PFI-FILTERS* (VARIABLES . CONSTANTS))
@@ -916,11 +994,11 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
)
(ADDTOVAR PRETTYPRINTMACROS (RPAQ . RPAQX.PRETTYPRINT)
(RPAQQ . RPAQX.PRETTYPRINT)
(RPAQ? . RPAQX.PRETTYPRINT)
(ADDTOVAR . RPAQX.PRETTYPRINT)
(PUTPROPS . PUTPROPS.PRETTYPRINT)
(COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT))
(RPAQQ . RPAQX.PRETTYPRINT)
(RPAQ? . RPAQX.PRETTYPRINT)
(ADDTOVAR . RPAQX.PRETTYPRINT)
(PUTPROPS . PUTPROPS.PRETTYPRINT)
(COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: DOEVAL@COMPILE DONTCOPY
@@ -960,11 +1038,11 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
DEFINERPRINT))
(* ;
 "Get prettyprinter fixes if running in old sysout")
 "Get prettyprinter fixes if running in old sysout")
(MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
S) (* ;
 "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
 "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
LP (COND
[(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
(GETD S))
@@ -975,8 +1053,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
(MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
((SETQ SYMS (CDR SYMS))
(GO LP))
(T (* ;
 "Neither one loaded, take original")
(T (* ; "Neither one loaded, take original")
(RETURN 'LISTFILES1]
'PFI.ORIGINAL.LISTFILES1 NIL T)
@@ -994,28 +1071,28 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
)
(PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (10070 12305 (PFI.NEW.LISTFILES1 10080 . 10574) (PFI.ENQUEUE 10576 . 11200) (
\PFI.DO.HARDCOPY 11202 . 11788) (MAYBE.PRETTYFILEINDEX 11790 . 12303)) (12306 35220 (PRETTYFILEINDEX
12316 . 26748) (PFI.MAKE.LPT.STREAM 26750 . 29801) (PFI.SETUP.TRANSLATIONS 29803 . 31317) (
PFI.OUTCHARFN 31319 . 33293) (PFI.COLLECT.DEFINERS 33295 . 34107) (PFI.AFTER.NEW.PAGE 34109 . 35218))
(35221 41169 (PFI.PRINT.FILECREATED 35231 . 39436) (PFI.PRINT.TO.TAB 39438 . 39803) (
PFI.PRINT.ENVIRONMENT 39805 . 41167)) (41170 48354 (PFI.PROCESS.FILE 41180 . 42410) (PFI.PASS.COMMENT
42412 . 43382) (PFI.HANDLE.EXPR 43384 . 44051) (PFI.DEFAULT.HANDLER 44053 . 46106) (PFI.PRETTYPRINT
46108 . 46443) (PFI.LINES.REMAINING 46445 . 46772) (PFI.MAYBE.NEW.PAGE 46774 . 47277) (
PFI.ESTIMATE.SIZE 47279 . 47810) (PFI.ESTIMATE.SIZE1 47812 . 48352)) (48391 57878 (PFI.HANDLE.RPAQQ
48401 . 49809) (PFI.HANDLE.DECLARE 49811 . 50750) (PFI.HANDLE.EVAL-WHEN 50752 . 51235) (
PFI.HANDLE.DEFDEFINER 51237 . 52527) (PFI.HANDLE.DEFINEQ 52529 . 52773) (PFI.PRINT.LAMBDA 52775 .
53113) (PFI.PRINT.LAMBDA.BODY 53115 . 53450) (PFI.HANDLE.PUTDEF 53452 . 53949) (PFI.HANDLE.PUTPROPS
53951 . 54566) (PFI.HANDLE./DECLAREDATATYPE 54568 . 55115) (PFI.HANDLE.* 55117 . 56379) (
PFI.PRINT.COMMENTS 56381 . 57281) (PFI.HANDLE.FILEMAP 57283 . 57571) (PFI.HANDLE.PACKAGE 57573 . 57876
)) (57906 58898 (PFI.PREVIEW.DECLARE 57916 . 58578) (PFI.PREVIEW.DEFINEQ 58580 . 58896)) (58934 69922
(PFI.PRINT.INDEX 58944 . 59795) (PFI.CONDENSE.INDEX 59797 . 61604) (PFI.SORT.INDICES 61606 . 62745) (
PFI.COMPUTE.INDEX.SHAPE 62747 . 64211) (PFI.PRINT.INDICES 64213 . 68755) (PFI.CENTER.PRINT 68757 .
69327) (PFI.INDEX.BREAK 69329 . 69787) (PFI.LOOKUP.NAME 69789 . 69920)) (69923 71154 (PFI.ADD.TO.INDEX
69933 . 70443) (PFI.VARNAME 70445 . 70855) (PFI.CONSTANTNAMES 70857 . 71152)) (71189 79502 (
MULTIFILEINDEX 71199 . 71995) (MULTIFILEINDEX1 71997 . 73453) (PFI.PRINT.MULTI.INDEX 73455 . 78558) (
PFI.CHOOSE.BEST 78560 . 78787) (PFI.MERGE.INDICES 78789 . 79500)) (79559 81177 (PFI.MAYBE.SEE.PRETTY
79569 . 80499) (PFI.MAYBE.PP.DEFINITION 80501 . 81175)) (81247 85082 (PFI.PRINT.BITMAP 81257 . 85080))
(87927 91041 (PUTPROPS.PRETTYPRINT 87937 . 89348) (RPAQX.PRETTYPRINT 89350 . 90075) (
COURIERPROGRAM.PRETTYPRINT 90077 . 90777) (MAYBE.PRETTYPRINT.BOLD 90779 . 91039)))))
(FILEMAP (NIL (10203 12438 (PFI.NEW.LISTFILES1 10213 . 10707) (PFI.ENQUEUE 10709 . 11333) (
\PFI.DO.HARDCOPY 11335 . 11921) (MAYBE.PRETTYFILEINDEX 11923 . 12436)) (12439 34954 (PRETTYFILEINDEX
12449 . 26482) (PFI.MAKE.LPT.STREAM 26484 . 29535) (PFI.SETUP.TRANSLATIONS 29537 . 31051) (
PFI.OUTCHARFN 31053 . 33027) (PFI.COLLECT.DEFINERS 33029 . 33841) (PFI.AFTER.NEW.PAGE 33843 . 34952))
(34955 40868 (PFI.PRINT.FILECREATED 34965 . 39055) (PFI.PRINT.TO.TAB 39057 . 39502) (
PFI.PRINT.ENVIRONMENT 39504 . 40866)) (40869 48384 (PFI.PROCESS.FILE 40879 . 42109) (PFI.PASS.COMMENT
42111 . 43081) (PFI.HANDLE.EXPR 43083 . 43750) (PFI.DEFAULT.HANDLER 43752 . 45805) (PFI.PRETTYPRINT
45807 . 46142) (PFI.LINES.REMAINING 46144 . 46471) (PFI.MAYBE.NEW.PAGE 46473 . 47307) (
PFI.ESTIMATE.SIZE 47309 . 47840) (PFI.ESTIMATE.SIZE1 47842 . 48382)) (48421 58630 (PFI.HANDLE.RPAQQ
48431 . 49839) (PFI.HANDLE.DECLARE 49841 . 50780) (PFI.HANDLE.EVAL-WHEN 50782 . 51265) (
PFI.HANDLE.DEFDEFINER 51267 . 52557) (PFI.HANDLE.DEFINEQ 52559 . 52803) (PFI.PRINT.LAMBDA 52805 .
53143) (PFI.PRINT.LAMBDA.BODY 53145 . 53480) (PFI.HANDLE.PUTDEF 53482 . 53979) (PFI.HANDLE.PUTPROPS
53981 . 54596) (PFI.HANDLE./DECLAREDATATYPE 54598 . 55145) (PFI.HANDLE.* 55147 . 56409) (
PFI.PRINT.COMMENTS 56411 . 58033) (PFI.HANDLE.FILEMAP 58035 . 58323) (PFI.HANDLE.PACKAGE 58325 . 58628
)) (58658 59650 (PFI.PREVIEW.DECLARE 58668 . 59330) (PFI.PREVIEW.DEFINEQ 59332 . 59648)) (59686 70674
(PFI.PRINT.INDEX 59696 . 60547) (PFI.CONDENSE.INDEX 60549 . 62356) (PFI.SORT.INDICES 62358 . 63497) (
PFI.COMPUTE.INDEX.SHAPE 63499 . 64963) (PFI.PRINT.INDICES 64965 . 69507) (PFI.CENTER.PRINT 69509 .
70079) (PFI.INDEX.BREAK 70081 . 70539) (PFI.LOOKUP.NAME 70541 . 70672)) (70675 71906 (PFI.ADD.TO.INDEX
70685 . 71195) (PFI.VARNAME 71197 . 71607) (PFI.CONSTANTNAMES 71609 . 71904)) (71941 80254 (
MULTIFILEINDEX 71951 . 72747) (MULTIFILEINDEX1 72749 . 74205) (PFI.PRINT.MULTI.INDEX 74207 . 79310) (
PFI.CHOOSE.BEST 79312 . 79539) (PFI.MERGE.INDICES 79541 . 80252)) (80311 83380 (PFI.MAYBE.SEE.PRETTY
80321 . 82104) (PFI.MAYBE.PP.DEFINITION 82106 . 83378)) (83450 87285 (PFI.PRINT.BITMAP 83460 . 87283))
(90054 93168 (PUTPROPS.PRETTYPRINT 90064 . 91475) (RPAQX.PRETTYPRINT 91477 . 92202) (
COURIERPROGRAM.PRETTYPRINT 92204 . 92904) (MAYBE.PRETTYPRINT.BOLD 92906 . 93166)))))
STOP

BIN
lispusers/PRETTYFILEINDEX.LCOM
View File

Binary file not shown.

52
lispusers/PSEUDOHOSTS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "24-Feb-2022 23:56:08" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;138 25865
(FILECREATED "25-Apr-2022 09:38:17" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;140 26309
:CHANGES-TO (FNS PSEUDOHOST PSEUDOHOSTP)
:CHANGES-TO (FNS EXPAND.PH)
:PREVIOUS-DATE " 5-Feb-2022 08:23:53"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;136)
:PREVIOUS-DATE "24-Apr-2022 14:18:32"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;139)
(PRETTYCOMPRINT PSEUDOHOSTSCOMS)
@@ -19,11 +19,13 @@
(* ;; "Internals")
(FNS EXPAND.PH CONTRACT.PH SLASHIT UNSLASHIT)
(FNS EXPAND.PH CONTRACT.PH SLASHIT UNSLASHIT GETHOSTINFO.PH)
(FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH
OPENP.PH UNREGISTERFILE.PH REGISTERFILE.PH GENERATEFILES.PH GETFILEINFO.PH
SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH RENAMEFILE.PH)
(P (PSEUDOHOST 'LI LOGINHOST/DIR))
(P (PSEUDOHOST 'LI LOGINHOST/DIR)
(MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG)
(MOVD 'GETHOSTINFO.PH 'GETHOSTINFO))
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE TARGETDEVICE)
(MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL)
(P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE)
@@ -178,7 +180,7 @@
(EXPAND.PH
[LAMBDA (FILENAME PHDEV)
(* ;; "Edited 5-Feb-2022 08:23 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
(* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
(* ;; "Assumes that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
@@ -187,7 +189,7 @@
(SETQ PHDEV (FETCH (STREAM DEVICE) OF FILENAME)))
(SETQ FILENAME (FETCH (STREAM FULLNAME) OF FILENAME))
ELSEIF (NOT (TYPE? FDEV PHDEV))
THEN (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV (FILENAMEFIELD FILENAME 'HOST]
THEN (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV FILENAME]
(IF (TYPE? PHDEVICE PHDEV)
THEN (LET (SUFFIX SUFFIXPOS)
(CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME))
@@ -293,6 +295,17 @@
UNSLASHED
(CONCAT (SUBSTRING X 1 (SUB1 DIRPOS))
UNSLASHED))])
(GETHOSTINFO.PH
[LAMBDA (HOST ATTRIBUTE)
(* ;; "Edited 24-Apr-2022 14:16 by rmk: the info from the true host")
(* ;; "Want the info from the true host")
(GETHOSTINFO.ORIG (OR (TARGETHOST HOST)
HOST)
HOST ATTRIBUTE])
)
(DEFINEQ
@@ -422,6 +435,10 @@
)
(PSEUDOHOST 'LI LOGINHOST/DIR)
(MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG)
(MOVD 'GETHOSTINFO.PH 'GETHOSTINFO)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
@@ -478,12 +495,13 @@
(LOAD 'EXPORTS.ALL))
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1239 9187 (PSEUDOHOST 1249 . 6724) (PSEUDOHOSTP 6726 . 7239) (PSEUDOHOSTS 7241 . 7598)
(TARGETHOST 7600 . 7874) (TRUEFILENAME 7876 . 8563) (PSEUDOFILENAME 8565 . 9185)) (9215 16486 (
EXPAND.PH 9225 . 10499) (CONTRACT.PH 10501 . 13166) (SLASHIT 13168 . 14736) (UNSLASHIT 14738 . 16484))
(16487 23277 (OPENFILE.PH 16497 . 17058) (GETFILENAME.PH 17060 . 17349) (DIRECTORYNAMEP.PH 17351 .
17975) (CLOSEFILE.PH 17977 . 18331) (REOPENFILE.PH 18333 . 18898) (DELETEFILE.PH 18900 . 19184) (
OPENP.PH 19186 . 19362) (UNREGISTERFILE.PH 19364 . 19669) (REGISTERFILE.PH 19671 . 19972) (
GENERATEFILES.PH 19974 . 21014) (GETFILEINFO.PH 21016 . 21318) (SETFILEINFO.PH 21320 . 21519) (
NEXTFILEFN.PH 21521 . 22063) (FILEINFOFN.PH 22065 . 22336) (RENAMEFILE.PH 22338 . 23275)))))
(FILEMAP (NIL (1338 9286 (PSEUDOHOST 1348 . 6823) (PSEUDOHOSTP 6825 . 7338) (PSEUDOHOSTS 7340 . 7697)
(TARGETHOST 7699 . 7973) (TRUEFILENAME 7975 . 8662) (PSEUDOFILENAME 8664 . 9284)) (9314 16853 (
EXPAND.PH 9324 . 10577) (CONTRACT.PH 10579 . 13244) (SLASHIT 13246 . 14814) (UNSLASHIT 14816 . 16562)
(GETHOSTINFO.PH 16564 . 16851)) (16854 23644 (OPENFILE.PH 16864 . 17425) (GETFILENAME.PH 17427 . 17716
) (DIRECTORYNAMEP.PH 17718 . 18342) (CLOSEFILE.PH 18344 . 18698) (REOPENFILE.PH 18700 . 19265) (
DELETEFILE.PH 19267 . 19551) (OPENP.PH 19553 . 19729) (UNREGISTERFILE.PH 19731 . 20036) (
REGISTERFILE.PH 20038 . 20339) (GENERATEFILES.PH 20341 . 21381) (GETFILEINFO.PH 21383 . 21685) (
SETFILEINFO.PH 21687 . 21886) (NEXTFILEFN.PH 21888 . 22430) (FILEINFOFN.PH 22432 . 22703) (
RENAMEFILE.PH 22705 . 23642)))))
STOP

BIN
lispusers/PSEUDOHOSTS.LCOM
View File

Binary file not shown.

38
lispusers/TEDIT-PF-SEE
View File

@@ -1,28 +1,32 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jan-2022 13:16:00" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;110 7695
(FILECREATED " 5-May-2022 23:48:59" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;112 7835
:CHANGES-TO (FNS PF-TEDIT)
:CHANGES-TO (COMMANDS ts tf)
(FNS PF-TEDIT)
(VARS TEDIT-PF-SEECOMS)
:PREVIOUS-DATE " 2-Jan-2022 22:03:27"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104)
:PREVIOUS-DATE " 5-May-2022 23:26:29"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;111)
(PRETTYCOMPRINT TEDIT-PF-SEECOMS)
(RPAQQ TEDIT-PF-SEECOMS [(FNS PF-TEDIT)
(COMMANDS ts tf)
(FILES (SYSLOAD)
REGIONMANAGER)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
(NLAMA)
(NLAML)
(LAMA])
(RPAQQ TEDIT-PF-SEECOMS
[(FNS PF-TEDIT)
(COMMANDS ts tf)
(FILES (SYSLOAD)
REGIONMANAGER)
(P (MOVD? 'PFCOPYBYTES 'PFI.mAYBE.PP.DEFINITION))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(DEFINEQ
(PF-TEDIT
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 12-Jan-2022 13:15 by rmk")
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 5-May-2022 23:11 by rmk")
(* ; "Edited 12-Jan-2022 13:15 by rmk")
(* ; "Edited 30-Dec-2021 23:17 by rmk")
(* ;; "PF* to a read-only TEDIT window. First argument is the function name, second if given is the input file.")
@@ -98,7 +102,7 @@
3 T T NIL TSTREAM)
(PRIN3 ")" TSTREAM)
ELSE (PRINTDEF EXPR 3 NIL NIL NIL TSTREAM)))
ELSE (PFCOPYBYTES ISTREAM TSTREAM (POP LOC)
ELSE (PFI.MAYBE.PP.DEFINITION ISTREAM TSTREAM (POP LOC)
(POP LOC)))
(TERPRI TSTREAM)
[TEDIT TSTREAM (OR WINDOW 'PF-TEDIT)
@@ -133,6 +137,8 @@
(FILESLOAD (SYSLOAD)
REGIONMANAGER)
(MOVD? 'PFCOPYBYTES 'PFI.mAYBE.PP.DEFINITION)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
@@ -142,5 +148,5 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (947 7216 (PF-TEDIT 957 . 7214)))))
(FILEMAP (NIL (911 7309 (PF-TEDIT 921 . 7307)))))
STOP

BIN
lispusers/TEDIT-PF-SEE.LCOM
View File

Binary file not shown.