github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-02-26 17:13:17 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request #706 from Interlisp/rmk22

Browse Source 
Rmk22  Minor fix ups for comparisons, GITFNS for renamed files
This commit is contained in:
rmkaplan
2022-02-28 14:30:20 -08:00
committed by GitHub
parent ab8da79d30 fbf33fe8e5
commit 111ebe2d27
13 changed files with 679 additions and 372 deletions
Download Patch File Download Diff File Expand all files Collapse all files

304
lispusers/COMPAREDIRECTORIES
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "18-Feb-2022 17:05:27" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;189 119161
(FILECREATED "25-Feb-2022 21:30:55" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;209 124231
:CHANGES-TO (FNS CD-MENUFN)
:CHANGES-TO (FNS CDFILES)
:PREVIOUS-DATE "11-Feb-2022 16:21:21"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;188)
:PREVIOUS-DATE "24-Feb-2022 21:13:32"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;208)
(* ; "
@@ -19,8 +19,9 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(
(* ;; "Compare the contents of two directories.")
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS CDENTRIES.SELECT
COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME CD.INSURECDVALUE CD.UPDATEWIDTHS)
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS COMPAREDIRECTORIES.CANDIDATES
CDENTRIES.SELECT COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME CD.INSURECDVALUE
CD.UPDATEWIDTHS)
(FNS CDFILES CDFILES.MATCH CDFILES.PATS)
(FNS CDPRINT CDPRINT.HEADER CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS
CDTEDIT)
@@ -65,7 +66,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(COMPAREDIRECTORIES
[LAMBDA (DIR1 DIR2 SELECT INCLUDEDFILES EXCLUDEDFILES USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS
FIXDIRECTORYDATES) (* ; "Edited 4-Feb-2022 13:44 by rmk")
FIXDIRECTORYDATES) (* ; "Edited 23-Feb-2022 21:10 by rmk")
(* ; "Edited 4-Feb-2022 13:44 by rmk")
(* ; "Edited 31-Jan-2022 21:52 by rmk")
(* ; "Edited 26-Jan-2022 13:33 by rmk")
(* ; "Edited 4-Jan-2022 12:09 by rmk")
@@ -97,7 +99,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(*- '*-)
(~= '~=)
(ERROR "UNRECOGNIZED SELECT PARAMETER" S]
(PROG (INFOS1 INFOS2 CANDIDATES CDENTRIES DEPTH1 DEPTH2 CDVALUE (DATE (DATE)))
(PROG (INFOS1 INFOS2 CDENTRIES DEPTH1 DEPTH2 CDVALUE (DATE (DATE)))
(* ;; "DIRECTORYNAME here to get unrelativized specifications for header.")
@@ -121,10 +123,13 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(PRINTOUT T " ... ")
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 INCLUDEDFILES EXCLUDEDFILES
ALLVERSIONS DEPTH1)
USEDIRECTORYDATE DIR1))
USEDIRECTORYDATE DIR1 ALLVERSIONS))
(SETQ INFOS2 (COMPAREDIRECTORIES.INFOS (CDFILES DIR2 INCLUDEDFILES EXCLUDEDFILES
ALLVERSIONS DEPTH2)
USEDIRECTORYDATE DIR2))
USEDIRECTORYDATE DIR2 ALLVERSIONS))
(* ;; "The CAR of each info is the atomic match-name, the CDR is a list of infos with that matchname, only 1 unless AllVERSIONS. ")
(SETQ CDVALUE (CREATE CDVALUE
CDDIR1 _ DIR1
CDDIR2 _ DIR2
@@ -133,40 +138,11 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CL:UNLESS (OR INFOS2 INFOS1)
(RETURN CDVALUE))
(* ;; "At this point the CAR of each info is the atomic match-name. Peel it off to produce candidate entries.")
(* ;; "Correlate the I1's and I2's with the same match name, then do the select filtering and insert the date relations")
(* ;;
 "Look through all of the I2's because multiple versions (if VERSIONS) have the same matchname")
[SETQ CANDIDATES (for I1 in INFOS1
join (if ALLVERSIONS
then (OR (for I2 in INFOS2 when (EQ (CAR I2)
(CAR I1))
collect (LIST (CAR I1)
(CDR I1)
(CDR I2)))
(CONS (LIST (CAR I1)
(CDR I1)
NIL)))
else (CONS (LIST (CAR I1)
(CDR I1)
(CDR (ASSOC (CAR I1)
INFOS2]
(* ;; "Could be some 2's without 1's")
(SETQ CANDIDATES (SORT [NCONC CANDIDATES (for I2 in INFOS2 unless (ASSOC (CAR I2)
CANDIDATES)
collect (LIST (CAR I2)
NIL
(CDR I2]
T))
(* ;; "CANDIDATES is now a sorted list of the form (matchname entry1 entry2) where an entry consists of (fullname date length author)")
(* ;; "Do the SELECT filtering and insert the date relation.")
(SETQ CDENTRIES (CDENTRIES.SELECT CANDIDATES SELECT))
(SETQ CDENTRIES (SORT (CDENTRIES.SELECT (COMPAREDIRECTORIES.CANDIDATES INFOS1 INFOS2)
SELECT)
T))
(PRINTOUT T (LENGTH CDENTRIES)
" entries" T)
(REPLACE CDENTRIES OF CDVALUE WITH CDENTRIES)
@@ -176,13 +152,11 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(RETURN (CDPRINT CDVALUE OUTPUTFILE NIL (MEMB 'AUTHOR SELECT])
(COMPAREDIRECTORIES.INFOS
[LAMBDA (FILES USEDIRECTORYDATE DIR) (* ; "Edited 4-Jan-2022 15:23 by rmk")
(* ; "Edited 23-Dec-2021 18:59 by rmk")
(* ; "Edited 12-Dec-2021 22:50 by rmk")
(* ; "Edited 23-Nov-2021 12:27 by rmk:")
(* ; "Edited 13-Oct-2020 08:42 by rmk:")
[LAMBDA (FILES USEDIRECTORYDATE DIR ALLVERSIONS)
(* ;; "Value is a list of CDINFOS with the match-name consed on to the front")
(* ;; "Edited 24-Feb-2022 09:19 by rmk: is a list of CDINFOS with the match-name consed on to the front. If ALLVERSIONS")
(* ;; "Value is a list of the form (matchname . CDINFOS). CDINFOS is guaranteed to be a singleton, unless ALLVERSIONS. ")
(FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
COLLECT
@@ -194,9 +168,9 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
 "So all the GETFILEINFO's, FILEDATES, etc. don't have to do the directory searching.")
(SETQ LDATE (OR (FILEDATE STREAM T)
(FILEDATE STREAM)))
(PROG1 (CONS (MATCHNAME FULLNAME STARTPOS)
(PROG1 (LIST (MATCHNAME FULLNAME STARTPOS)
(CREATE CDINFO
FULLNAME _ FULLNAME
FULLNAME _ (FULLNAME STREAM)
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
THEN (GETFILEINFO STREAM 'CREATIONDATE)
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
@@ -205,20 +179,86 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
AUTHOR _ (GETFILEINFO STREAM 'AUTHOR)
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE STREAM LDATE)
EOL _ (EOLTYPE STREAM)))
(CLOSEF? STREAM])
(CLOSEF? STREAM))
FINALLY
(* ;; "Sort to get all entries with the same matchname adjacent. Presumably we would only need to collect multiples if ALLVERSIONS, but in a case-sensitive file system we might see files with names that differ in case. We have deliberately given them a case-insensitive matchname, so we can expose this issue in the display.")
(* ;; "If we see (MN X)(MN Y), smash the Y in after the X")
(RETURN (FOR ITAIL I VAL MN ON (SORT $$VAL T)
DO (SETQ I (CAR ITAIL))
(SETQ MN (CAR I))
[WHILE (EQ MN (CAADR ITAIL)) DO (POP ITAIL)
(PUSH (CDR I)
(CADR (CAR ITAIL]
(PUSH VAL I) FINALLY (RETURN (DREVERSE VAL])
(COMPAREDIRECTORIES.CANDIDATES
[LAMBDA (INFOS1 INFOS2)
(* ;; "Edited 24-Feb-2022 10:00 by rmk: Correlate the I1's and I2's with the same match name. Rely on the fact that the lists are sorted.")
(SETQ INFOS1 (SORT INFOS1 T))
(SETQ INFOS2 (SORT INFOS2 T))
(LET (PAIRS)
(BIND I1 I2 (I1TAIL _ INFOS1)
(I2TAIL _ INFOS2) DO (IF (AND I1TAIL I2TAIL)
THEN (SETQ I1 (CAR I1TAIL))
(SETQ I2 (CAR I2TAIL))
(IF (EQ (CAR I1)
(CAR I2))
THEN (PUSH PAIRS (LIST (CAR I1)
(CDR I1)
(CDR I2)))
(POP I1TAIL)
(POP I2TAIL)
ELSEIF (ALPHORDER (CAR I1)
(CAR I2))
THEN (PUSH PAIRS (LIST (CAR I1)
(CDR I1)
(CONS NIL)))
(POP I1TAIL)
ELSE (PUSH PAIRS (LIST (CAR I2)
(CONS NIL)
(CDR I2)))
(POP I2TAIL))
ELSEIF I1TAIL
THEN [FOR I1 IN I1TAIL
DO (PUSH PAIRS (LIST (CAR I1)
(CDR I1)
(CONS NIL]
(RETURN)
ELSEIF I2TAIL
THEN [FOR I2 IN I2TAIL
DO (PUSH PAIRS (LIST (CAR I2)
(CONS NIL)
(CDR I2]
(RETURN)
ELSE (RETURN)))
(* ;; "Take the cross products (if ALLVERSIONS) to create a list of (MN I1 I2) CDENTRIES with singleton infos.")
(FOR P MN CANDIDATES IN PAIRS
DO (SETQ MN (CAR P))
[FOR I1 IN (CADR P)
DO (FOR I2 IN (CADDR P)
DO (PUSH CANDIDATES (CREATE CDENTRY
MATCHNAME _ MN
INFO1 _ I1
INFO2 _ I2] FINALLY (RETURN CANDIDATES])
(CDENTRIES.SELECT
[LAMBDA (CANDIDATES SELECT) (* ; "Edited 4-Jan-2022 21:31 by rmk")
[LAMBDA (CANDIDATES SELECT) (* ; "Edited 23-Feb-2022 20:45 by rmk")
(* ; "Edited 4-Jan-2022 21:31 by rmk")
(* ;; "Does the pairwise select filter and inserts the date relation")
(for C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP [COMPAREDATE
_
(INTERSECTION SELECT
'(< > =] in CANDIDATES
eachtime (SETQ MATCHNAME (pop C))
(SETQ INFO1 (pop C))
(SETQ INFO2 (pop C))
(for CDE MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP
[COMPAREDATE _ (INTERSECTION SELECT '(< > =] in CANDIDATES
eachtime (SETQ MATCHNAME (FETCH (CDENTRY MATCHNAME) OF CDE))
(SETQ INFO1 (FETCH (CDENTRY INFO1) OF CDE))
(SETQ INFO2 (FETCH (CDENTRY INFO2) OF CDE))
(if (AND INFO1 INFO2)
then (SETQ IDATE1 (IDATE (fetch DATE of INFO1)))
(SETQ IDATE2 (IDATE (fetch DATE of INFO2)))
@@ -275,14 +315,11 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
else
(* ;; "OK if INFO1 is missing?")
(MEMB '-* SELECT))
collect (create CDENTRY
MATCHNAME _ MATCHNAME
INFO1 _ INFO1
DATEREL _ DATEREL
INFO2 _ INFO2
EQUIV _ (CL:UNLESS (EQ DATEREL '*)
BINCOMP])
(MEMB '-* SELECT)) collect (REPLACE (CDENTRY DATEREL) OF CDE WITH DATEREL)
(REPLACE (CDENTRY EQUIV) OF CDE
WITH (CL:UNLESS (EQ DATEREL '*)
BINCOMP))
CDE])
(COMPAREDIRECTORIES.INFOS.TYPE
[LAMBDA (FULLNAME LDATE) (* ; "Edited 4-Jan-2022 13:10 by rmk")
@@ -299,19 +336,20 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
'OTHER])
(MATCHNAME
[LAMBDA (NAME STARTPOS) (* ; "Edited 23-Dec-2021 22:41 by rmk")
(* ; "Edited 5-Sep-2020 13:41 by rmk:")
[LAMBDA (NAME STARTPOS) (* ; "Edited 24-Feb-2022 09:10 by rmk")
(* ; "Edited 23-Dec-2021 22:41 by rmk")
(* ; "Edited 5-Sep-2020 13:41 by rmk:")
(* ;; "The NAME.DIR for matching related files")
(* ;; "The canonical name for matching related files")
(LET [(M (PACKFILENAME 'VERSION NIL 'BODY (SUBATOM NAME STARTPOS]
(LET [(M (UNSLASHIT (U-CASE (PACKFILENAME 'VERSION NIL 'BODY (SUBATOM NAME STARTPOS]
(* ;; "Strip off the nuisance period")
(CL:IF (EQ (CHARCODE %.)
(NTHCHARCODE M -1))
(SUBATOM M 1 -2)
M)])
(MKATOM M))])
(CD.INSURECDVALUE
[LAMBDA (CDVALUE?) (* ; "Edited 30-Nov-2021 14:37 by rmk:")
@@ -348,7 +386,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(DEFINEQ
(CDFILES
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 26-Jan-2022 15:25 by rmk")
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 25-Feb-2022 21:26 by rmk")
(* ; "Edited 26-Jan-2022 15:25 by rmk")
(* ; "Edited 21-Jan-2022 22:40 by rmk")
(* ; "Edited 5-Jan-2022 15:07 by rmk")
(* ; "Edited 23-Dec-2021 22:49 by rmk")
@@ -379,11 +418,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(SETQ EXCLUDEDFILES (LDIFFERENCE EXCLUDEDFILES INCLUDEDFILES))
(LET ([INCLUDES (CDFILES.PATS (OR INCLUDEDFILES '*.*]
(EXCLUDES (AND EXCLUDEDFILES (CDFILES.PATS EXCLUDEDFILES)))
(TOPDIR (DIRECTORYNAME (OR DIR T)))
HOST FILING.ENUMERATION.DEPTH ENUMPAT)
(DECLARE (SPECVARS FILING.ENUMERATION.DEPTH))
(SETQ HOST (FILENAMEFIELD TOPDIR 'HOST))
(SETQ TOPDIR (FILENAMEFIELD TOPDIR 'DIRECTORY))
(SETQ HOST (FILENAMEFIELD DIR 'HOST))
(SETQ DIR (FILENAMEFIELD DIR 'DIRECTORY))
[SETQ FILING.ENUMERATION.DEPTH (IF (EQ DEPTH T)
THEN MAX.SMALLP
ELSEIF DEPTH
@@ -411,8 +449,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
(CONCAT "<" TOPDIR ">"
(OR SD ""))
(CONCAT "<" DIR ">" (OR SD ""))
'NAME N 'EXTENSION E 'VERSION
(CL:IF ALLVERSIONS
'*
@@ -424,7 +461,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(* ;; "We enumerate all the files, checking to see that")
(FOR FULLNAME NAME EXT SUBDIR UNPACK THISDEPTH (STARTPOS _ (ADD1 (NCHARS TOPDIR)))
(FOR FULLNAME NAME EXT SUBDIR UNPACK THISDEPTH (STARTPOS _ (ADD1 (NCHARS DIR)))
IN (DIRECTORY ENUMPAT NIL NIL (CL:IF ALLVERSIONS
"*"
""))
@@ -1651,9 +1688,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
BROWSER)])
(CDBROWSER.STRINGS
[LAMBDA (CDVALUE COLHEADINGS SEPARATEDIRECTIONS) (* ; "Edited 14-Dec-2021 21:03 by rmk")
(* ; "Edited 8-Dec-2021 11:22 by rmk")
(* ; "Edited 27-Nov-2021 21:37 by rmk:")
[LAMBDA (CDVALUE COLHEADINGS SEPARATEDIRECTIONS) (* ; "Edited 22-Feb-2022 18:30 by rmk")
(* ; "Edited 14-Dec-2021 21:03 by rmk")
(* ; "Edited 8-Dec-2021 11:22 by rmk")
(* ; "Edited 27-Nov-2021 21:37 by rmk:")
(* ;; "Create a list of elements one for each CDENTRY of the form (printstring CDENTRY LATER)")
@@ -1680,6 +1718,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(IF (FETCH INFO1 OF CDENTRY)
THEN 'LEFT
ELSE 'RIGHT))
((R C) (* ; "Renamed or copied")
(FETCH DATEREL OF CDENTRY))
(SHOULDNT)))
(* ;; "Take off the EQUIV field. Should used COL1START")
@@ -1730,14 +1770,22 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
WINDOW])
(CD.TABLEITEM.COPYFN
[LAMBDA (CDBROWSER ITEM) (* ; "Edited 25-Dec-2021 12:58 by rmk")
(LET [(CDENTRY (CADR (FETCH TIDATA OF ITEM]
(SELECTQ [MENU (CREATE MENU
TITLE _ "Which File?"
ITEMS _ '(Left Right]
(Left (COPYINSERT (FETCH (CDINFO FULLNAME) OF (FETCH (CDENTRY INFO1) OF CDENTRY))))
(Right (COPYINSERT (FETCH (CDINFO FULLNAME) OF (FETCH (CDENTRY INFO2) OF CDENTRY))))
NIL])
[LAMBDA (CDBROWSER ITEM) (* ; "Edited 24-Feb-2022 21:12 by rmk")
(* ; "Edited 25-Dec-2021 12:58 by rmk")
(LET [LEFT RIGHT FILE (CDENTRY (CADR (FETCH TIDATA OF ITEM]
(SETQ LEFT (FETCH (CDINFO FULLNAME) OF (FETCH (CDENTRY INFO1) OF CDENTRY)))
(SETQ RIGHT (FETCH (CDINFO FULLNAME) OF (FETCH (CDENTRY INFO2) OF CDENTRY)))
(SETQ FILE (IF (AND LEFT RIGHT)
THEN (SELECTQ [MENU (CREATE MENU
TITLE _ "Which File?"
ITEMS _ '(Left Right]
(Left LEFT)
(Right RIGHT)
NIL)
ELSE (OR LEFT RIGHT)))
(CL:WHEN FILE
(PUTCLIPBOARD FILE)
(COPYINSERT FILE))])
(CDTABLEBROWSER.HEADING.REPAINTFN
[LAMBDA (WINDOW REGION) (* ; "Edited 28-Nov-2021 09:09 by rmk:")
@@ -1760,7 +1808,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
'DON'T])
(CD.COMMANDSELECTEDFN
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 5-Feb-2022 17:23 by rmk")
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 24-Feb-2022 19:52 by rmk")
(* ; "Edited 5-Feb-2022 17:23 by rmk")
(* ; "Edited 27-Jan-2022 17:46 by rmk")
(* ; "Edited 10-Jan-2022 22:51 by rmk")
(* ; "Edited 25-Dec-2021 11:20 by rmk")
@@ -1777,7 +1826,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
(USERDATA (TB.USERDATA CDBROWSER))
(CDVALUE (LISTGET USERDATA 'CDVALUE))
(FN (CADR (LISTP MENUITEM]
(FN (CADR (LISTP MENUITEM)))
(MIDDLE (EQ KEY 'MIDDLE]
(DECLARE (SPECVARS WINDOW PWINDOW CDVALUE USERDATA))
(GIVE.TTY.PROCESS PWINDOW)
(TTYDISPLAYSTREAM PWINDOW) (* ; "Pwindow")
@@ -1785,7 +1835,14 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
((EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
(FLASHWINDOW PWINDOW)
(PRIN3 "Please make a selection" T))
(T (TB.MAP.SELECTED.ITEMS
(T (CL:WHEN MIDDLE
(GIVE.TTY.PROCESS PWINDOW)
(CLEARW PWINDOW)
(FLASHWINDOW PWINDOW)
(CL:UNLESS (EQ 'Y (ASKUSER NIL 'N "Apply to all selected items? "))
(SETQ KEY 'LEFT)
(PRIN3 " ... " PWINDOW)))
(TB.MAP.SELECTED.ITEMS
CDBROWSER
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
@@ -1804,16 +1861,29 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
FILE2)))
(DECLARE (SPECVARS . T))
(* ;;
 "One of the files is not real if its date is %"%", a rename.")
(CL:WHEN (STREQUAL "" (FETCH (CDINFO DATE)
OF (FETCH (CDENTRY INFO1)
OF CDENTRY)))
(SETQ FILE1 NIL))
(CL:WHEN (STREQUAL "" (FETCH (CDINFO DATE)
OF (FETCH (CDENTRY INFO2)
OF CDENTRY)))
(SETQ FILE2 NIL))
(* ;; "If USERDATA contains a LABELFN, then it is applied to the files and the rest of the USERDATA to produce abbreviated labels for titles and headers.")
(CLEARW T)
(CL:FUNCALL FN TBITEM MENUITEM CDBROWSER KEY]
(FUNCTION NILL]))])
(FUNCTION NILL))
(CL:WHEN MIDDLE (PRIN3 " Done" PWINDOW]))])
(CD-MENUFN
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY)
(* ;; "Edited 18-Feb-2022 16:56 by rmk: FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
(* ;; "Edited 23-Feb-2022 22:27 by rmk: FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
(* ;; "The FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
@@ -2036,24 +2106,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 (2555 19321 (COMPAREDIRECTORIES 2565 . 9265) (COMPAREDIRECTORIES.INFOS 9267 . 11387) (
CDENTRIES.SELECT 11389 . 16075) (COMPAREDIRECTORIES.INFOS.TYPE 16077 . 16705) (MATCHNAME 16707 . 17237
) (CD.INSURECDVALUE 17239 . 18853) (CD.UPDATEWIDTHS 18855 . 19319)) (19322 29594 (CDFILES 19332 .
25688) (CDFILES.MATCH 25690 . 27315) (CDFILES.PATS 27317 . 29592)) (29595 44680 (CDPRINT 29605 . 31950
) (CDPRINT.HEADER 31952 . 32849) (CDPRINT.LINE 32851 . 35407) (CDPRINT.MAXWIDTHS 35409 . 39524) (
CDPRINT.COLHEADERS 39526 . 40164) (CDPRINT.COLUMNS 40166 . 44045) (CDTEDIT 44047 . 44678)) (44681
53050 (CDMAP 44691 . 46123) (CDENTRY 46125 . 46434) (CDSUBSET 46436 . 47875) (CDMERGE 47877 . 51731) (
CDMERGE.COMMON 51733 . 53048)) (53051 60589 (BINCOMP 53061 . 57350) (EOLTYPE 57352 . 59914) (
EOLTYPE.SHOW 59916 . 60587)) (61117 74324 (FIND-UNCOMPILED-FILES 61127 . 64770) (FIND-UNSOURCED-FILES
64772 . 67581) (FIND-SOURCE-FILES 67583 . 69287) (FIND-COMPILED-FILES 69289 . 71367) (
FIND-UNLOADED-FILES 71369 . 72113) (FIND-LOADED-FILES 72115 . 72669) (FIND-MULTICOMPILED-FILES 72671
. 74322)) (74325 82527 (CREATED-AS 74335 . 79132) (SOURCE-FOR-COMPILED-P 79134 . 81832) (
COMPILE-SOURCE-DATE-DIFF 81834 . 82525)) (82528 92834 (FIX-DIRECTORY-DATES 82538 . 85531) (
FIX-EQUIV-DATES 85533 . 87058) (COPY-COMPARED-FILES 87060 . 88881) (COPY-MISSING-FILES 88883 . 91040)
(COMPILED-ON-SAME-SOURCE 91042 . 92832)) (93028 100070 (CDBROWSER 93038 . 96965) (CDBROWSER.STRINGS
96967 . 100068)) (100232 101504 (CD.TABLEITEM 100242 . 100462) (CD.TABLEITEM.PRINTFN 100464 . 100663)
(CD.TABLEITEM.COPYFN 100665 . 101259) (CDTABLEBROWSER.HEADING.REPAINTFN 101261 . 101502)) (101505
118577 (CDTABLEBROWSER.WHENSELECTEDFN 101515 . 101983) (CD.COMMANDSELECTEDFN 101985 . 105485) (
CD-MENUFN 105487 . 111662) (CDBROWSER-COPY 111664 . 115035) (CDBROWSER-DELETE-FILE 115037 . 118056) (
CD-SWAPDIRS 118058 . 118575)))))
(FILEMAP (NIL (2597 22158 (COMPAREDIRECTORIES 2607 . 7834) (COMPAREDIRECTORIES.INFOS 7836 . 10598) (
COMPAREDIRECTORIES.CANDIDATES 10600 . 13985) (CDENTRIES.SELECT 13987 . 18762) (
COMPAREDIRECTORIES.INFOS.TYPE 18764 . 19392) (MATCHNAME 19394 . 20074) (CD.INSURECDVALUE 20076 . 21690
) (CD.UPDATEWIDTHS 21692 . 22156)) (22159 32408 (CDFILES 22169 . 28502) (CDFILES.MATCH 28504 . 30129)
(CDFILES.PATS 30131 . 32406)) (32409 47494 (CDPRINT 32419 . 34764) (CDPRINT.HEADER 34766 . 35663) (
CDPRINT.LINE 35665 . 38221) (CDPRINT.MAXWIDTHS 38223 . 42338) (CDPRINT.COLHEADERS 42340 . 42978) (
CDPRINT.COLUMNS 42980 . 46859) (CDTEDIT 46861 . 47492)) (47495 55864 (CDMAP 47505 . 48937) (CDENTRY
48939 . 49248) (CDSUBSET 49250 . 50689) (CDMERGE 50691 . 54545) (CDMERGE.COMMON 54547 . 55862)) (55865
63403 (BINCOMP 55875 . 60164) (EOLTYPE 60166 . 62728) (EOLTYPE.SHOW 62730 . 63401)) (63931 77138 (
FIND-UNCOMPILED-FILES 63941 . 67584) (FIND-UNSOURCED-FILES 67586 . 70395) (FIND-SOURCE-FILES 70397 .
72101) (FIND-COMPILED-FILES 72103 . 74181) (FIND-UNLOADED-FILES 74183 . 74927) (FIND-LOADED-FILES
74929 . 75483) (FIND-MULTICOMPILED-FILES 75485 . 77136)) (77139 85341 (CREATED-AS 77149 . 81946) (
SOURCE-FOR-COMPILED-P 81948 . 84646) (COMPILE-SOURCE-DATE-DIFF 84648 . 85339)) (85342 95648 (
FIX-DIRECTORY-DATES 85352 . 88345) (FIX-EQUIV-DATES 88347 . 89872) (COPY-COMPARED-FILES 89874 . 91695)
(COPY-MISSING-FILES 91697 . 93854) (COMPILED-ON-SAME-SOURCE 93856 . 95646)) (95842 103188 (CDBROWSER
95852 . 99779) (CDBROWSER.STRINGS 99781 . 103186)) (103350 105086 (CD.TABLEITEM 103360 . 103580) (
CD.TABLEITEM.PRINTFN 103582 . 103781) (CD.TABLEITEM.COPYFN 103783 . 104841) (
CDTABLEBROWSER.HEADING.REPAINTFN 104843 . 105084)) (105087 123647 (CDTABLEBROWSER.WHENSELECTEDFN
105097 . 105565) (CD.COMMANDSELECTEDFN 105567 . 110555) (CD-MENUFN 110557 . 116732) (CDBROWSER-COPY
116734 . 120105) (CDBROWSER-DELETE-FILE 120107 . 123126) (CD-SWAPDIRS 123128 . 123645)))))
STOP

BIN
lispusers/COMPAREDIRECTORIES.LCOM
View File

Binary file not shown.

177
lispusers/COMPARESOURCES
View File

@@ -1,12 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Jan-2022 18:22:40" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;118 41270
(FILECREATED "25-Feb-2022 18:02:24" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;121 41359
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN)
:CHANGES-TO (FNS \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.REC.NAME \CS.ISRECFORM)
(VARS COMPARESOURCETYPES COMPARESOURCESCOMS)
:PREVIOUS-DATE "28-Jan-2022 17:12:39"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;116)
:PREVIOUS-DATE "28-Jan-2022 18:22:40"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;118)
(* ; "
@@ -19,9 +20,9 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.EXAMINE \CS.FIXFNS
\CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE)
(FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM
\CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM
\CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM
\CS.COMPARE.FPKGCOMS \CS.COMPARE.DEFINE-FILE-INFO)
\CS.ISRECFORM \CS.REC.NAME \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES
\CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS
\CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS \CS.COMPARE.DEFINE-FILE-INFO)
[COMS (FNS CSOBJ.CREATE CSOBJ.DISPLAYFN CSOBJ.IMAGEBOXFN CSOBJ.BUTTONEVENTINFN
CSOBJ.COPYBUTTONEVENTINFN)
(INITVARS (COMPARESOURCES-IMAGEFNS (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN
@@ -138,9 +139,10 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
'SAME])
(\CS.COMPARE.MASTERS
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 18-Jan-2022 22:00 by rmk")
(* ; "Edited 19-Dec-2021 21:05 by rmk")
(* ; "Edited 5-Sep-2020 19:01 by rmk:")
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 25-Feb-2022 18:02 by rmk")
(* ; "Edited 18-Jan-2022 22:00 by rmk")
(* ; "Edited 19-Dec-2021 21:05 by rmk")
(* ; "Edited 5-Sep-2020 19:01 by rmk:")
(* ; "Edited 15-Apr-88 14:41 by bvm")
(DECLARE (USEDFREE DIFFERENCES COMPARESTREAM))
(LET (YTHING XTHING PRED DIFS TMP)
@@ -164,58 +166,49 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
do
(* ;; "handle definer based things")
(for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X
when (EQ (CAR X)
DEFFER)))
(SETQ YTHING (for X in BODYY collect X
when (EQ (CAR X)
DEFFER)))
(for DEFFER in DEFFERS WHEN [AND (SETQ XTHING (for X in BODYX collect X
when (EQ (CAR X)
DEFFER)))
(SETQ YTHING (for X in BODYY collect X
when (EQ (CAR X)
DEFFER]
do
(* ;; "Take out all of the THINGS we are about to do. ")
(* ;; "Take out all of the THINGS we are about to do. ")
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
(FUNCTION EQUALALL)))
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
(FUNCTION EQUALALL)))
(COND
((SETQ DIFS (\CS.COMPARE.TYPES
XTHING YTHING
(CONCAT (OR (CL:DOCUMENTATION TYPE
'DEFINE-TYPES)
TYPE)
" defined by " DEFFER)
NIL
(GET DEFFER :DEFINITION-NAME)))
(COND
((SETQ TMP (ASSOC TYPE DIFFERENCES))
(NCONC TMP DIFS))
(T (push DIFFERENCES (CONS TYPE DIFS]
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST (FUNCTION EQUALALL)))
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST (FUNCTION EQUALALL)))
(CL:WHEN (SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING
(CONCAT (OR (CL:DOCUMENTATION TYPE 'DEFINE-TYPES)
TYPE)
" defined by " DEFFER)
NIL
(GET DEFFER :DEFINITION-NAME)
TYPE))
[COND
((SETQ TMP (ASSOC TYPE DIFFERENCES))
(NCONC TMP DIFS))
(T (push DIFFERENCES (CONS TYPE DIFS])]
(* ;; "These are for other filepkage types, as registered in COMPARESOURCETYPES")
[for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE))
(SETQ XTHING (for X in BODYX collect X
when (CL:FUNCALL PRED X)))
(SETQ YTHING (for X in BODYY collect X
when (CL:FUNCALL PRED X)))
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
(FUNCTION EQUALALL)))
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
(FUNCTION EQUALALL)))
(COND
([SETQ DIFS (\CS.COMPARE.TYPES
XTHING YTHING
(OR (fetch (CSTYPE TITLE) of TYPE)
(MKSTRING (fetch (CSTYPE FPKGTYPE)
of TYPE)))
(fetch (CSTYPE COMPAREFN) of TYPE)
(OR (fetch (CSTYPE IDFN) of TYPE)
(FUNCTION CADR]
(SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE))
(COND
((SETQ TMP (ASSOC TYPE DIFFERENCES))
(NCONC TMP DIFS))
(T (push DIFFERENCES (CONS TYPE DIFS]
[for TYPE in COMPARESOURCETYPES EACHTIME (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE))
WHEN [AND (SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X)))
(SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X]
do (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST (FUNCTION EQUALALL)))
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST (FUNCTION EQUALALL)))
(CL:WHEN [SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (OR (fetch (CSTYPE TITLE)
of TYPE)
(MKSTRING (fetch (CSTYPE
FPKGTYPE)
of TYPE)))
(fetch (CSTYPE COMPAREFN) of TYPE)
(OR (fetch (CSTYPE IDFN) of TYPE)
(FUNCTION CADR))
(SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE]
[COND
((SETQ TMP (ASSOC TYPE DIFFERENCES))
(NCONC TMP DIFS))
(T (push DIFFERENCES (CONS TYPE DIFS])]
(SETQ BODYY (CL:SET-DIFFERENCE BODYY (PROG1 BODYX
(SETQ BODYX (CL:SET-DIFFERENCE
BODYX BODYY :TEST
@@ -245,22 +238,23 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
[COND
[BODYX (COND
(BODYY (COMPARELISTS BODYX BODYY COMPARESTREAM)
(\CS.EXAMINE BODYX BODYY))
(\CS.EXAMINE BODYX BODYY NIL 'Expression))
(T (printout COMPARESTREAM "These are not on File 2:" T)
(FOR X IN BODYX DO (LVLPRINT X COMPARESTREAM 2 3)
(\CS.EXAMINE X NIL T]
(\CS.EXAMINE X NIL T NIL 'Expression]
(BODYY (printout COMPARESTREAM "These are not on File 1:" T)
(FOR Y IN BODYY DO (LVLPRINT Y COMPARESTREAM 2 3)
(\CS.EXAMINE NIL Y T]
(\CS.EXAMINE NIL Y T NIL 'Expression]
(OR (ASSOC 'Other DIFFERENCES)
(push DIFFERENCES (LIST 'Other '--])
(\CS.COMPARE.TYPES
[LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN) (* ; "Edited 9-Dec-2021 23:19 by rmk")
(* ; "Edited 1-Dec-2021 23:25 by rmk:")
(* ; "Edited 30-Nov-2021 23:07 by rmk:")
(* ; "Edited 27-Nov-2021 12:32 by rmk:")
(* ; "Edited 25-Nov-2021 13:29 by rmk:")
[LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN TYPE) (* ; "Edited 25-Feb-2022 17:49 by rmk")
(* ; "Edited 9-Dec-2021 23:19 by rmk")
(* ; "Edited 1-Dec-2021 23:25 by rmk:")
(* ; "Edited 30-Nov-2021 23:07 by rmk:")
(* ; "Edited 27-Nov-2021 12:32 by rmk:")
(* ; "Edited 25-Nov-2021 13:29 by rmk:")
(* ; "Edited 29-Dec-86 11:49 by jds")
(* ;;; "Compare things using COMPAREFN. Deltas -> COMPARESTREAM. Anything that passes the WHEN predicate has a difference somewhere, will produce some output. ")
@@ -276,7 +270,6 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
:TEST
(FUNCTION EQUALALL)))
(OR XTHING YTHING)))
DF
(* ;; "We know we are going to have some output. Strings can go directly onto theCONTEXTSTREAM, and objects may then be inserted.")
@@ -288,12 +281,12 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
NAME]
(printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT
" is not on File 2" T T)
(\CS.EXAMINE X NIL T NAME))
(\CS.EXAMINE X NIL T NAME TYPE))
(T (printout COMPARESTREAM .FONT BOLDFONT .P2 NAME ":" .FONT DEFAULTFONT T)
(COND
(COMPAREFN (CL:FUNCALL COMPAREFN X Y COMPARESTREAM))
(T (COMPARELISTS X Y COMPARESTREAM)))
(\CS.EXAMINE X Y NIL NAME)
(\CS.EXAMINE X Y NIL NAME TYPE)
(RPLACA (FMEMB Y YTHING]
(RPLACA TAIL)
(push RESULT NAME))
@@ -301,7 +294,7 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
do (SETQ NAME (CL:FUNCALL IDFN Y))
(printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT
" is not on File 1" T T)
(\CS.EXAMINE Y NIL T NAME)
(\CS.EXAMINE Y NIL T NAME TYPE)
(push RESULT NAME))
RESULT)])
@@ -436,7 +429,21 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
)
(\CS.ISRECFORM
(LAMBDA (X) (* bvm%: "25-Sep-85 12:20") (FMEMB (CAR X) CLISPRECORDTYPES)))
[LAMBDA (X) (* ; "Edited 25-Feb-2022 15:17 by rmk")
(* bvm%: "25-Sep-85 12:20")
(OR (FMEMB (CAR X)
CLISPRECORDTYPES)
(EQ (CAR X)
'/DECLAREDATATYPE])
(\CS.REC.NAME
[LAMBDA (FORM) (* ; "Edited 25-Feb-2022 15:24 by rmk")
(IF (AND (EQ (CAR FORM)
'/DECLAREDATATYPE)
(EQ (CAR (CADR FORM))
'QUOTE))
THEN (CADR (CADR FORM))
ELSE (CADR FORM])
(\CS.ISCOURIERFORM
(LAMBDA (X) (* bvm%: "13-Mar-86 16:21") (EQ (CAR X) (QUOTE COURIERPROGRAM))))
@@ -611,7 +618,7 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
((FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID "FNS defined by DEFINEQ")
(VARS \CS.ISVARFORM \CS.COMPARE.VARS)
(MACROS \CS.ISMACROFORM)
(RECORDS \CS.ISRECFORM)
(RECORDS \CS.ISRECFORM NIL \CS.REC.NAME)
(PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties")
(ADDVARS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS CADR "Additions to lists")
(TEMPLATES \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES CADADR)
@@ -686,16 +693,16 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
)
(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1850 27174 (COMPARESOURCES 1860 . 7906) (\CS.COMPARE.MASTERS 7908 . 16052) (
\CS.COMPARE.TYPES 16054 . 19192) (\CS.EXAMINE 19194 . 23421) (\CS.FIXFNS 23423 . 24925) (
\CS.SORT.DECLARES 24927 . 25270) (\CS.SORT.DECLARE1 25272 . 26692) (\CS.FILTER.GARBAGE 26694 . 27172))
(27175 31155 (\CS.ISFNFORM 27185 . 27453) (\CS.COMPARE.FNS 27455 . 27697) (\CS.FNSID 27699 . 27843) (
\CS.ISVARFORM 27845 . 27950) (\CS.COMPARE.VARS 27952 . 28614) (\CS.ISMACROFORM 28616 . 28754) (
\CS.ISRECFORM 28756 . 28849) (\CS.ISCOURIERFORM 28851 . 28951) (\CS.ISTEMPLATEFORM 28953 . 29051) (
\CS.COMPARE.TEMPLATES 29053 . 29418) (\CS.ISPROPFORM 29420 . 29575) (\CS.PROP.NAME 29577 . 29722) (
\CS.COMPARE.PROPS 29724 . 29881) (\CS.ISADDVARFORM 29883 . 29976) (\CS.COMPARE.ADDVARS 29978 . 30143)
(\CS.ISFPKGCOMFORM 30145 . 30352) (\CS.COMPARE.FPKGCOMS 30354 . 30561) (\CS.COMPARE.DEFINE-FILE-INFO
30563 . 31153)) (31156 37220 (CSOBJ.CREATE 31166 . 31579) (CSOBJ.DISPLAYFN 31581 . 32334) (
CSOBJ.IMAGEBOXFN 32336 . 34497) (CSOBJ.BUTTONEVENTINFN 34499 . 36970) (CSOBJ.COPYBUTTONEVENTINFN 36972
. 37218)) (38084 40788 (CSBROWSER 38094 . 40786)))))
(FILEMAP (NIL (1970 26690 (COMPARESOURCES 1980 . 8026) (\CS.COMPARE.MASTERS 8028 . 15440) (
\CS.COMPARE.TYPES 15442 . 18708) (\CS.EXAMINE 18710 . 22937) (\CS.FIXFNS 22939 . 24441) (
\CS.SORT.DECLARES 24443 . 24786) (\CS.SORT.DECLARE1 24788 . 26208) (\CS.FILTER.GARBAGE 26210 . 26688))
(26691 31227 (\CS.ISFNFORM 26701 . 26969) (\CS.COMPARE.FNS 26971 . 27213) (\CS.FNSID 27215 . 27359) (
\CS.ISVARFORM 27361 . 27466) (\CS.COMPARE.VARS 27468 . 28130) (\CS.ISMACROFORM 28132 . 28270) (
\CS.ISRECFORM 28272 . 28600) (\CS.REC.NAME 28602 . 28921) (\CS.ISCOURIERFORM 28923 . 29023) (
\CS.ISTEMPLATEFORM 29025 . 29123) (\CS.COMPARE.TEMPLATES 29125 . 29490) (\CS.ISPROPFORM 29492 . 29647)
(\CS.PROP.NAME 29649 . 29794) (\CS.COMPARE.PROPS 29796 . 29953) (\CS.ISADDVARFORM 29955 . 30048) (
\CS.COMPARE.ADDVARS 30050 . 30215) (\CS.ISFPKGCOMFORM 30217 . 30424) (\CS.COMPARE.FPKGCOMS 30426 .
30633) (\CS.COMPARE.DEFINE-FILE-INFO 30635 . 31225)) (31228 37292 (CSOBJ.CREATE 31238 . 31651) (
CSOBJ.DISPLAYFN 31653 . 32406) (CSOBJ.IMAGEBOXFN 32408 . 34569) (CSOBJ.BUTTONEVENTINFN 34571 . 37042)
(CSOBJ.COPYBUTTONEVENTINFN 37044 . 37290)) (38173 40877 (CSBROWSER 38183 . 40875)))))
STOP

BIN
lispusers/COMPARESOURCES.LCOM
View File

Binary file not shown.

BIN
lispusers/COMPARETEXT.LCOM
View File

Binary file not shown.

25
lispusers/EXAMINEDEFS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Feb-2022 23:15:24" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;36 11920
(FILECREATED "25-Feb-2022 18:04:08" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;37 12345
:CHANGES-TO (FNS EXAMINEFILES)
:CHANGES-TO (FNS EXAMINEDEFS)
:PREVIOUS-DATE " 1-Feb-2022 15:43:17"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;35)
:PREVIOUS-DATE " 1-Feb-2022 23:15:24"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;36)
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
@@ -19,7 +19,8 @@
(DEFINEQ
(EXAMINEDEFS
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 1-Feb-2022 15:42 by rmk")
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 25-Feb-2022 15:01 by rmk")
(* ; "Edited 1-Feb-2022 15:42 by rmk")
(* ; "Edited 23-Jan-2022 17:40 by rmk")
(* ; "Edited 18-Jan-2022 22:40 by rmk")
(* ; "Edited 12-Jan-2022 17:29 by rmk")
@@ -55,9 +56,15 @@
ELSEIF (GETDEF NAME TYPE SOURCE2)
ELSE (ERROR NAME " not found on " SOURCE2)))
(CL:UNLESS TITLE1
(SETQ TITLE1 (OR SOURCE1 "File 1")))
(SETQ TITLE1 (CL:IF (AND SOURCE1 (ILEQ (COUNT SOURCE1)
5))
SOURCE1
"File 1")))
(CL:UNLESS TITLE2
(SETQ TITLE2 (OR SOURCE2 "File 2")))
(SETQ TITLE2 (CL:IF (AND SOURCE2 (ILEQ (COUNT SOURCE2)
5))
SOURCE12
"File 2")))
(SELECTQ (EDITMODE)
(SEDIT:SEDIT
(* ;;
@@ -199,6 +206,6 @@
(FILESLOAD (SYSLOAD)
COMPARETEXT)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (662 11778 (EXAMINEDEFS 672 . 8792) (EXAMINEFILES 8794 . 10189) (TEDITDEF 10191 . 11776)
(FILEMAP (NIL (661 12203 (EXAMINEDEFS 671 . 9217) (EXAMINEFILES 9219 . 10614) (TEDITDEF 10616 . 12201)
))))
STOP

BIN
lispusers/EXAMINEDEFS.LCOM
View File

Binary file not shown.

472
lispusers/GITFNS
View File

@@ -1,11 +1,11 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Feb-2022 10:22:09" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;58 58648
(FILECREATED "26-Feb-2022 12:26:02" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;102 70973
:CHANGES-TO (FNS GIT-COMPARE-WITH-MYMEDLEY GIT-COMPARE-BRANCHES)
:CHANGES-TO (FNS GIT-REPO-FILENAME)
:PREVIOUS-DATE "13-Feb-2022 21:27:07"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;57)
:PREVIOUS-DATE "26-Feb-2022 11:58:56"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;101)
(PRETTYCOMPRINT GITFNSCOMS)
@@ -16,16 +16,25 @@
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS)
(INITVARS [GITMEDLEYDIR (OR (UNIX-GETENV "GITMEDLEYDIR")
(CONCAT "{UNIX}" (SLASHIT (PACKFILENAME 'HOST NIL 'BODY MEDLEYDIR
)
T]
(* ;; "GITMEDLEYDIR and MYMEDLEYDIR collapse to MEDLEYDIR if not provided")
(INITVARS (GITMEDLEYDIR (SLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "GITMEDLEYDIR")
MEDLEYDIR)
'HOST
'UNIX)
T))
(MYMEDLEYDIR (UNSLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "MYMEDLEYDIR")
MEDLEYDIR)
'HOST
'DSK)
T))
(MYMEDLEYHOST 'MM)
(GITMEDLEYHOST 'GIT))
(INITVARS (GIT-IGNORE-FILES '(EXPORTS.ALL RDSYS RDSYS.LCOM))
(GIT-IGNORE-DIRECTORIES '(loadups patches tmp fontsold deleted clos cltl2))
(GIT-MERGE-COMPARES T))
(P (PSEUDOHOST MYMEDLEYHOST MEDLEYDIR)
(P (PSEUDOHOST MYMEDLEYHOST MYMEDLEYDIR)
(PSEUDOHOST GITMEDLEYHOST GITMEDLEYDIR))
(FNS GIT-CLONEP)
@@ -43,7 +52,7 @@
(FNS ALLSUBDIRS MEDLEYSUBDIRS GITSUBDIRS)
(FNS TOGIT FROMGIT GIT-DELETE-FILE MYMEDLEY-DELETE-FILES)
(FNS MEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME)
(FNS MYMEDLEYSUBDIR GITSUBDIR STRIPDIR STRIPHOST STRIPNAME)
(FNS GFILE4MFILE MFILE4GFILE GIT-REPO-FILENAME)
(* ;; "")
@@ -59,7 +68,8 @@
(* ;; "Branches")
(FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS?)
(FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS?
PICK-BRANCH GIT-PULL-REQUESTS)
(* ;; "My branches")
@@ -79,6 +89,7 @@
(FNS GIT-GET-DIFFERENT-FILES GIT-COMPARE-BRANCHES GIT-COMPARE-WITH-MYMEDLEY
GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN)
(INITVARS (FROMGITN 0))
(* ;; "")
@@ -95,9 +106,22 @@
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
COMPAREDIRECTORIES COMPARESOURCES COMPARETEXT PSEUDOHOSTS)
(RPAQ? GITMEDLEYDIR (OR (UNIX-GETENV "GITMEDLEYDIR")
(CONCAT "{UNIX}" (SLASHIT (PACKFILENAME 'HOST NIL 'BODY MEDLEYDIR)
T))))
(* ;; "GITMEDLEYDIR and MYMEDLEYDIR collapse to MEDLEYDIR if not provided")
(RPAQ? GITMEDLEYDIR (SLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "GITMEDLEYDIR")
MEDLEYDIR)
'HOST
'UNIX)
T))
(RPAQ? MYMEDLEYDIR (UNSLASHIT (PACKFILENAME 'BODY (OR (UNIX-GETENV "MYMEDLEYDIR")
MEDLEYDIR)
'HOST
'DSK)
T))
(RPAQ? MYMEDLEYHOST 'MM)
@@ -109,7 +133,7 @@
(RPAQ? GIT-MERGE-COMPARES T)
(PSEUDOHOST MYMEDLEYHOST MEDLEYDIR)
(PSEUDOHOST MYMEDLEYHOST MYMEDLEYDIR)
(PSEUDOHOST GITMEDLEYHOST GITMEDLEYDIR)
(DEFINEQ
@@ -164,8 +188,16 @@
(* ;; "Compares REMOTEBRANCH against origin/master, for pull-request assessment")
(CL:UNLESS REMOTEBRANCH (ERROR "PR branch not specified" ""))
(GIT-COMPARE-BRANCHES REMOTEBRANCH 'origin/master NIL))
(IF REMOTEBRANCH
THEN (GIT-COMPARE-BRANCHES REMOTEBRANCH 'origin/master NIL)
ELSE (LET [(PRITEMS (FOR PR IN (GIT-PULL-REQUESTS T) COLLECT (LIST (CADDR PR)
(CADDR PR)
(CONCAT " " (CADR PR)
" #"
(CAR PR]
(GIT-COMPARE-BRANCHES (PICK-BRANCH (OR PRITEMS 'REMOTE)
"Pull requests")
'origin/master NIL))))
(DEFCOMMAND cob (BRANCH)
@@ -194,12 +226,14 @@
[LAMBDA (HOST1 HOST2)
(* ;;
 "Edited 4-Feb-2022 17:57 by rmk: the union of the subdirectories that exist under all the hosts")
 "Edited 25-Feb-2022 21:57 by rmk: the union of the subdirectories that exist under all the hosts")
(* ;; "Returns the union of the subdirectories that exist under all the hosts")
(LET ((HOSTS (MKLIST HOST1))
(FILING.ENUMERATION.DEPTH 1)
VAL)
(DECLARE (SPECVARS FILING.ENUMERATION.DEPTH))
(CL:WHEN HOST2 (PUSHNEW HOSTS HOST2))
(CL:UNLESS HOSTS
(SETQ HOSTS (LIST MYMEDLEYHOST GITMEDLEYHOST)))
@@ -312,20 +346,22 @@
)
(DEFINEQ
(MEDLEYSUBDIR
[LAMBDA (SUBDIR STAR) (* ; "Edited 21-Jan-2022 15:18 by rmk")
(* ; "Edited 18-Jan-2022 16:19 by rmk")
(PACKFILENAME 'HOST MYMEDLEYHOST 'BODY (CONCAT SUBDIR (CL:IF STAR
">*"
"")])
(MYMEDLEYSUBDIR
[LAMBDA (SUBDIR STAR HOST) (* ; "Edited 26-Feb-2022 11:57 by rmk")
(* ; "Edited 21-Jan-2022 15:18 by rmk")
(UNSLASHIT (PACK* (PACKFILENAME 'HOST (OR HOST MYMEDLEYHOST)
'DIRECTORY SUBDIR)
(CL:IF STAR
"*"
"")])
(GITSUBDIR
[LAMBDA (SUBDIR STAR) (* ; "Edited 21-Jan-2022 15:18 by rmk")
(* ; "Edited 18-Jan-2022 16:19 by rmk")
(* ; "Edited 30-Oct-2021 23:59 by rmk:")
(SLASHIT (PACKFILENAME 'HOST GITMEDLEYHOST 'BODY (CONCAT SUBDIR (CL:IF STAR
"/*"
"")])
[LAMBDA (SUBDIR STAR HOST) (* ; "Edited 26-Feb-2022 11:56 by rmk")
(SLASHIT (PACK* (PACKFILENAME 'HOST (OR HOST GITMEDLEYHOST)
'DIRECTORY SUBDIR)
(CL:IF STAR
"*"
"")])
(STRIPDIR
[LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk")
@@ -371,14 +407,18 @@
'VERSION NIL 'BODY GFILE])
(GIT-REPO-FILENAME
[LAMBDA (GFILE) (* ; "Edited 18-Jan-2022 15:42 by rmk")
[LAMBDA (GFILE) (* ; "Edited 26-Feb-2022 12:25 by rmk")
(* ; "Edited 18-Jan-2022 15:42 by rmk")
(* ;; "Returns the string that the repo expects for a file name. {GIT} or GITMEDLEYDIR is stripped, brackets go to slashes, subdirectories are lower cased, and a final period is remove.")
(* ;; "Returns the string that the repo expects for a file name. {GIT} or GITMEDLEYDIR is stripped, brackets go to slashes, subdirectories are lower cased, an initial / and a final period is remove.")
(SETQ GFILE (SLASHIT (IF (EQ GITMEDLEYHOST (FILENAMEFIELD GFILE 'HOST))
(SETQ GFILE (SLASHIT (IF (EQ GITMEDLEYHOST (FILENAMEFIELD GFILE 'HOST))
THEN (STRIPHOST GFILE)
ELSE (STRIPDIR GFILE GITMEDLEYDIR))
T))
(CL:WHEN (EQ (CHARCODE /)
(CHCON1 GFILE))
(SETQ GFILE (SUBSTRING GFILE 2)))
(CL:WHEN (EQ (CHARCODE %.)
(NTHCHARCODE GFILE -1))
(SETQ GFILE (SUBSTRING GFILE 1 -2)))
@@ -425,24 +465,69 @@
(GIT-COMMAND (CONCAT "git pull " (OR BRANCH (GIT-WHICH-BRANCH])
(GIT-BRANCH-DIFF
[LAMBDA (BRANCH1 BRANCH2) (* ; "Edited 24-Nov-2021 16:30 by rmk:")
(* ; "Edited 22-Nov-2021 09:07 by rmk:")
(* ; "Edited 16-Nov-2021 08:41 by rmk:")
[LAMBDA (BRANCH1 BRANCH2)
(* ;; "Edited 23-Feb-2022 17:45 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"))
(GIT-REMOTE-UPDATE)
(GIT-REMOTE-UPDATE)
(LET ([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
FILES POS)
LINES POS)
(CL:WHEN (STRPOS "fatal" MERGE)
(ERROR (CONCAT "merge-base failed for " (LIST BRANCH1 BRANCH2))))
(SETQ FILES (GIT-COMMAND (CONCAT "git diff --name-only " MERGE " " BRANCH1)))
(CL:WHEN (SETQ POS (STRPOS "fatal: ambiguous argument '" (CAR FILES)
(SETQ LINES (GIT-COMMAND (CONCAT "git diff --name-status -C --find-copies-harder " MERGE " "
BRANCH1)))
(CL:WHEN (SETQ POS (STRPOS "fatal: ambiguous argument '" (CAR LINES)
1 NIL T T))
(ERROR "Unknown branch " (IF (STRPOS BRANCH1 (CAR FILES)
(ERROR "Unknown branch " (IF (STRPOS BRANCH1 (CAR LINES)
POS NIL T)
THEN BRANCH1
ELSE BRANCH2)))
FILES])
(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 (HELP "COPY NOT UNDERSTOOD" L)
(IF (SETQ POS (STRPOS " " L))
THEN [PUSH COPIED (LIST [SUBSTRING L (ADD1 POS)
(SUB1 (SETQ POS (STRPOS " " L (ADD1 POS]
(SUBSTRING L (ADD1 POS]
ELSE (HELP "COPY NOT UNDERSTOOD" 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)))])
(GIT-APPROVAL
[LAMBDA (BRANCH) (* ; "Edited 19-Nov-2021 15:08 by rmk:")
@@ -450,24 +535,44 @@
(GIT-ADD-WORKTREE "master" T])
(GIT-GET-FILE
[LAMBDA (BRANCH GITFILE LOCALFILE) (* ; "Edited 12-Feb-2022 18:06 by rmk")
(* ; "Edited 3-Jan-2022 23:52 by rmk")
(* ; "Edited 20-Nov-2021 20:28 by rmk:")
[LAMBDA (BRANCH GITFILE LOCALFILE NOERROR)
(* ;; "If GITFILE in (remote) BRANCH exists, it is copied to LOCALFILE and LOCALFILE is returned. If it doesn't exist, return value is NIL. Maybe it should cause a FILENOTFOUND error?")
(* ;; "Edited 24-Feb-2022 19:42 by rmk: the stream, not the name because of the NODIRCORE case.")
(CL:WHEN (GIT-FILE-EXISTS? BRANCH GITFILE)
(CL:WITH-OPEN-FILE (STREAM (OR LOCALFILE '{NODIRCORE)
:IF-EXISTS :NEW-VERSION :DIRECTION :IO)
(CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM (CONCAT (CDGITDIR)
"git show " BRANCH ":" GITFILE))
(* ;; "Returns the stream, not the name because of the NODIRCORE case.")
(* ;; "If GITFILE in (remote) BRANCH exists, it is copied to LOCALFILE and LOCALFILE is returned. If it doesn't exist, return value is NIL if NOERROR, otherwise an ERROR.")
(CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM (CONCAT (CDGITDIR)
"git show " BRANCH ":" GITFILE)))
(SETFILEINFO s 'ENDOFSTREAMOP (FUNCTION NILL))
(LET (BYTES)
(IF (FOR I B C FROM 1 WHILE (SETQ C (NTHCHARCODE "fatal: path '" I))
DO
(* ;;
 "Returns NIL if we run off the fatal string with a match, otherwise T")
(CL:UNLESS (SETQ B (\BIN s))
(RETURN T))
(PUSH BYTES B)
(CL:UNLESS (EQ B C)
(RETURN T)))
THEN
(* ;; "Don't open STREAM until we know the file is real")
(CL:WITH-OPEN-FILE (STREAM (OR LOCALFILE '{NODIRCORE)
:IF-EXISTS :NEW-VERSION :DIRECTION :IO)
(FOR B IN (DREVERSE BYTES) DO (\BOUT STREAM B))
[DO (\BOUT STREAM (OR (\BIN s)
(RETURN]
(SETFILEINFO STREAM 'CREATIONDATE (OR (FILEDATE STREAM T)
(FILEDATE STREAM)
(GIT-FILE-DATE GITFILE BRANCH))
)
(SETFILEINFO s 'ENDOFSTREAMOP (FUNCTION NILL))
(BIND C WHILE (SETQ C (\BIN s)) DO (\BOUT STREAM C)))
(SETFILEINFO STREAM 'CREATIONDATE (OR (FILEDATE STREAM T)
(FILEDATE STREAM)
(GIT-FILE-DATE GITFILE BRANCH)))
STREAM))])
STREAM)
ELSEIF NOERROR
THEN NIL
ELSE (ERROR "GIT FILE NOT FOUND" GITFILE])
(GIT-FILE-EXISTS?
[LAMBDA (BRANCH GITFILE) (* ; "Edited 10-Feb-2022 20:55 by rmk")
@@ -574,18 +679,21 @@
ELSE (HELP "Unexpected git result" RESULT])
(GIT-BRANCHES
[LAMBDA (WHERE) (* ; "Edited 8-Dec-2021 08:43 by rmk")
[LAMBDA (WHERE) (* ; "Edited 24-Feb-2022 21:20 by rmk")
(* ; "Edited 8-Dec-2021 08:43 by rmk")
(* ; "Edited 17-Nov-2021 18:20 by rmk:")
(* ; "Edited 16-Nov-2021 09:21 by rmk:")
(* ;;
 "Strips of the %"* %" that indicates the current branch and the 2-space padding on other branches")
(LET [(LOCAL (CL:WHEN (MEMB WHERE '(NIL ALL LOCAL))
(LET [(LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
'(NIL ALL LOCAL))
(GIT-COMMAND "git branch")))
(REMOTE (CL:WHEN (MEMB WHERE '(NIL ALL REMOTE T))
(REMOTE (CL:WHEN (MEMB (U-CASE WHERE)
'(NIL ALL REMOTE T))
(GIT-COMMAND "git branch -r"]
(FOR B IN (APPEND LOCAL REMOTE) COLLECT (SUBATOM B 3])
(SORT (FOR B IN (APPEND LOCAL REMOTE) COLLECT (SUBATOM B 3])
(GIT-BRANCH-EXISTS?
[LAMBDA (BRANCH WHERE NOERROR) (* ; "Edited 16-Dec-2021 08:50 by rmk")
@@ -604,6 +712,31 @@
(GIT-BRANCHES WHERE)))
ELSEIF (NOT NOERROR)
THEN (ERROR "Unknown branch" BRANCH])
(PICK-BRANCH
[LAMBDA (BRANCHES TITLE) (* ; "Edited 25-Feb-2022 09:02 by rmk")
(MENU (CREATE MENU
TITLE _ (OR TITLE 'Branches)
ITEMS _ (OR (LISTP BRANCHES)
(GIT-BRANCHES BRANCHES))
MENUFONT _ DEFAULTFONT])
(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)
WHEN [AND (SETQ TAB1 (STRPOS " " LINE))
(SETQ TAB2 (STRPOS " " LINE (ADD1 TAB1)))
(SETQ TAB3 (STRPOS " " LINE (ADD1 TAB2)))
(OR INCLUDEDRAFTS (NEQ 'DRAFT (SUBATOM LINE (ADD1 TAB3]
COLLECT (IF ALLINFO
THEN `[,(SUBATOM LINE 1 (SUB1 TAB1))
,(SUBSTRING LINE (ADD1 TAB1)
(SUB1 TAB2))
,(SUBSTRING LINE (ADD1 TAB2)
(SUB1 TAB3))
,(SUBATOM LINE (ADD1 TAB3]
ELSE (SUBATOM LINE (ADD1 TAB2)
(SUB1 TAB3])
)
@@ -748,36 +881,86 @@
(DEFINEQ
(GIT-GET-DIFFERENT-FILES
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 12-Feb-2022 18:35 by rmk")
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "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")
(* ; "Edited 5-Jan-2022 08:01 by rmk")
(* ;; "Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories.")
(* ;; "Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")
(SETQ BRANCH1 (GIT-BRANCH-EXISTS? BRANCH1))
(SETQ BRANCH2 (GIT-BRANCH-EXISTS? BRANCH2))
(LET ([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
DIFFS)
(SETQ DIFFS (GIT-BRANCH-DIFF BRANCH1 MERGE))
(CL:WHEN DIFFS
(PSEUDOHOST 'FROMGIT (CONCAT "{CORE}<gitfiles>" (DATE)
">"))
(LET
([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2]
DIFFS MAPPINGS FROMGIT)
(* ;; "UNSLASHIT because CORE doesn't know about slash")
(* ;; "Collapse them together for now")
(CL:UNLESS DIR1
(SETQ DIR1 (CONCAT "{FROMGIT}" (UNSLASHIT BRANCH1)
">")))
(CL:UNLESS DIR2
(SETQ DIR2 (CONCAT "{FROMGIT}" (UNSLASHIT BRANCH2)
">")))
(FOR GFILE IN DIFFS DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE))
(GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE)))
(LIST DIR1 DIR2))])
(SETQ DIFFS (GIT-BRANCH-DIFF BRANCH1 MERGE))
(* ;; "DIFFS is an alist with keys ADDED, DELETED, CHANGED, MOVED")
(CL:WHEN DIFFS
(SETQ FROMGIT (PACK* '{FROMGIT (ADD FROMGITN 1)
'}))
(PSEUDOHOST FROMGIT (CONCAT "{CORE}<gitfiles>" (DATE)
">"))
(* ;; "UNSLASHIT because CORE doesn't know about slash")
(CL:UNLESS DIR1
(SETQ DIR1 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH1)
">")))
(CL:UNLESS DIR2
(SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2)
">")))
(FOR DLIST IN DIFFS
DO
(SELECTQ (CAR DLIST)
(ADDED (* ;
 "Shouldn't exist in MERGE, should exist in BRANCH1")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE))))
(DELETED (* ;
 "Shouldn't exist in BRANCH1, should exist in MERGE")
(FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE))))
(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))))
(RENAMED
(* ;; "These entries are from-to filename pairs. If (CADDR) is 100, only need to fetch one, mappings is returned so the connection can be reestablished higher up. If renamed, it has disappared from the first location and appeared in the second. The destination is in the CADR, the CAR file doesn't exist. But we store the files in DIR1 because they are coming from branch1")
[FOR GFILE IN (CDR DLIST)
DO (IF (EQ (CADDR GFILE)
100)
THEN (PUSH MAPPINGS (LIST [FULLNAME (GIT-GET-FILE
BRANCH1
(CADR GFILE)
(CONCAT DIR1 (CADR GFILE]
(CONCAT DIR2 (CAR GFILE))
'R))
ELSE (* ;
 "Deleted from MERGE, added to BRANCH1")
(GIT-GET-FILE MERGE (CAR GFILE)
(CONCAT DIR1 (CAR GFILE)))
(GIT-GET-FILE BRANCH1 (CADR GFILE)
(CONCAT DIR2 (CADR GFILE])
(COPIED
(* ;; "Same issue as for renaming")
[FOR GFILE IN (CDR DLIST)
DO (PUSH MAPPINGS (LIST [FULLNAME (GIT-GET-FILE BRANCH1 (CADR GFILE)
(CONCAT DIR1 (CADR GFILE]
(CONCAT DIR2 (CAR GFILE))
'C])
(HELP "UNKNOWN GIT-DIFF TAG" DLIST)))
(LIST DIR1 DIR2 MAPPINGS))])
(GIT-COMPARE-BRANCHES
[LAMBDA (BRANCH1 BRANCH2 LOCAL) (* ; "Edited 19-Feb-2022 10:21 by rmk")
[LAMBDA (BRANCH1 BRANCH2 LOCAL) (* ; "Edited 22-Feb-2022 22:53 by rmk")
(* ; "Edited 19-Feb-2022 10:21 by rmk")
(* ; "Edited 13-Feb-2022 21:27 by rmk")
(* ; "Edited 2-Feb-2022 08:46 by rmk")
(* ; "Edited 28-Jan-2022 23:58 by rmk")
@@ -787,9 +970,10 @@
(SETQ BRANCH2 (GITORIGIN (OR BRANCH2 "master")
LOCAL))
(PRINTOUT T "Comparing all subdirectories of " BRANCH1 " and " BRANCH2 T)
(LET (CDVALUE DIRS NENTRIES)
(LET (CDVALUE DIRS NENTRIES MAPPINGS)
(PRINTOUT T "Fetching differences" T)
(SETQ DIRS (GIT-GET-DIFFERENT-FILES BRANCH1 BRANCH2))
(SETQ MAPPINGS (CADDR DIRS))
(IF DIRS
THEN (TERPRI T)
(SETQ CDVALUE (COMPAREDIRECTORIES (CAR DIRS)
@@ -802,22 +986,42 @@
(* ;;
 " Also, lower case the directories. Perhaps can be done when the files are fetched?")
[CDMAP CDVALUE (FUNCTION (LAMBDA (CDE)
(DECLARE (USEDFREE INFO1 INFO2))
(CL:WHEN INFO1
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
(SLASHIT (CL:IF
(STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))
(CL:WHEN INFO2
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO2)
(SLASHIT (CL:IF
(STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))]
[CDMAP CDVALUE
(FUNCTION (LAMBDA (CDE)
(DECLARE (USEDFREE INFO1 INFO2))
(LET [(MAP (CL:UNLESS INFO2
(FIND M IN MAPPINGS
SUCHTHAT (STRING.EQUAL (CAR M)
(FETCH (CDINFO FULLNAME)
OF INFO1)
FILEDIRCASEARRAY)))]
(CL:WHEN INFO1
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
(SLASHIT (CL:IF (STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))
(CL:WHEN INFO2
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO2)
(SLASHIT (CL:IF (STRPOS ";1" DATUM -2 NIL T)
(SUBSTRING DATUM 1 -3)
DATUM)
T)))
(IF MAP
THEN
(* ;; "This handles renames and copies. We want the nominal source of a rename to be in the first column, even though the target location is the one that was fetched.")
(REPLACE (CDENTRY INFO2) OF CDE
WITH (CREATE CDINFO
FULLNAME _ (CADR MAP)
DATE _ ""
LENGTH _ ""
AUTHOR _ ""
TYPE _ ""
EOL _ ""))
(REPLACE (CDENTRY DATEREL) OF CDE
WITH (CADDR MAP]
(TERPRI T)
(IF (FETCH (CDVALUE CDENTRIES) OF CDVALUE)
THEN (SETQ LAST-BRANCH-CDVALUE CDVALUE)
@@ -839,7 +1043,7 @@
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES TEDIT FIXDIRECTORYDATES UPDATE HOST1 HOST2)
(* ;;
 "Edited 19-Feb-2022 10:19 by rmk: my medley subdirectories with the current local git branch.")
 "Edited 26-Feb-2022 11:58 by rmk: my medley subdirectories with the current local git branch.")
(* ;; "Compares my medley subdirectories with the current local git branch.")
@@ -859,7 +1063,7 @@
(for SUBDIR TITLE CDVAL (NENTRIES _ 0)
(BRANCH2 _ (GIT-WHICH-BRANCH)) INSIDE SUBDIRS
collect (TERPRI T)
(SETQ CDVAL (COMPAREDIRECTORIES (MEDLEYSUBDIR SUBDIR T)
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T)
(GITSUBDIR SUBDIR T)
(OR SELECT '(> < ~= -* *-))
NIL GIT-IGNORE-FILES NIL NIL NIL FIXDIRECTORYDATES))
@@ -1062,7 +1266,8 @@
(OR LABEL2 FILE2])
(GIT-CD-MENUFN
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 5-Feb-2022 17:36 by rmk")
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 24-Feb-2022 11:30 by rmk")
(* ; "Edited 5-Feb-2022 17:36 by rmk")
(* ; "Edited 19-Dec-2021 23:28 by rmk")
(* ; "Edited 16-Dec-2021 13:49 by rmk")
(* ; "Edited 10-Dec-2021 08:52 by rmk")
@@ -1076,7 +1281,8 @@
(IF FILE1
THEN (PRIN3 "Use 'Delete BOTH' instead")
ELSE (GIVE.TTY.PROCESS PWINDOW)
(CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? ")))
(CL:WHEN [OR (EQ KEY 'MIDDLE)
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? "]
(GIT-DELETE-FILE FILE2)
(TB.DELETE.ITEM CDBROWSER TBITEM))))
(|Delete ALL <-|
@@ -1084,9 +1290,10 @@
(IF FILE2
THEN (PRIN3 "Use 'Delete BOTH' instead")
ELSE (GIVE.TTY.PROCESS PWINDOW)
(CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
(NAMEFIELD LABEL1 T)
" ? ")))
(CL:WHEN [OR (EQ KEY 'MIDDLE)
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
(NAMEFIELD LABEL1 T)
" ? "]
(MYMEDLEY-DELETE-FILES FILE1)
(TB.DELETE.ITEM CDBROWSER TBITEM))))
(Delete% BOTH (FLASHWINDOW PWINDOW)
@@ -1101,6 +1308,8 @@
(SHOULDNT])
)
(RPAQ? FROMGITN 0)
(* ;; "")
@@ -1124,15 +1333,17 @@
" ; "])
(GIT-COMMAND
[LAMBDA (CMD ALL NOERROR) (* ; "Edited 3-Jan-2022 10:47 by rmk")
(* ; "Edited 24-Nov-2021 16:44 by rmk:")
(* ; "Edited 16-Nov-2021 09:07 by rmk:")
(* ; "Edited 2-Nov-2021 21:08 by rmk:")
(* ; "Edited 7-Oct-2021 11:15 by rmk:")
[LAMBDA (CMD ALL NOERROR) (* ; "Edited 25-Feb-2022 09:25 by rmk")
(* ; "Edited 3-Jan-2022 10:47 by rmk")
(* ; "Edited 24-Nov-2021 16:44 by rmk:")
(* ; "Edited 16-Nov-2021 09:07 by rmk:")
(* ; "Edited 2-Nov-2021 21:08 by rmk:")
(* ; "Edited 7-Oct-2021 11:15 by rmk:")
(* ;; "Suppress .git lines unless ALL")
(CL:UNLESS (EQ 1 (STRPOS "git" CMD))
(CL:UNLESS (OR (EQ 1 (STRPOS "git" CMD))
(EQ 1 (STRPOS "gh" CMD)))
(SETQ CMD (CONCAT "git " CMD)))
[BIND LPOS WHILE (SETQ LPOS (STRPOS "local/" CMD))
DO (SETQ CMD (CONCAT (SUBSTRING CMD 1 (SUB1 LPOS))
@@ -1146,7 +1357,10 @@
WHEN [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P NIL :EOF-VALUE NIL))
(OR ALL (NOT (STRPOS ".git" LINE 1 NIL T] COLLECT LINE
FINALLY (CL:UNLESS NOERROR
(CL:WHEN (STRPOS "fatal" (CAR $$VAL))
(CL:WHEN (OR (EQ 1 (STRPOS "fatal" (CAR $$VAL)
1 NIL NIL T))
(EQ 1 (STRPOS "gh: Command not found" (CAR $$VAL)
1 NIL NIL T)))
(ERROR (CONCAT "Git command %"" CMD "%" failed")
(CAR $$VAL))))])
@@ -1174,22 +1388,22 @@
(ERROR "INITIALS is not set"])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3466 4312 (GIT-CLONEP 3476 . 4310)) (5552 7490 (ALLSUBDIRS 5562 . 6688) (MEDLEYSUBDIRS
6690 . 7129) (GITSUBDIRS 7131 . 7488)) (7491 12965 (TOGIT 7501 . 9649) (FROMGIT 9651 . 10629) (
GIT-DELETE-FILE 10631 . 11525) (MYMEDLEY-DELETE-FILES 11527 . 12963)) (12966 15362 (MEDLEYSUBDIR 12976
. 13416) (GITSUBDIR 13418 . 13994) (STRIPDIR 13996 . 14367) (STRIPHOST 14369 . 14605) (STRIPNAME
14607 . 15360)) (15363 16664 (GFILE4MFILE 15373 . 15619) (MFILE4GFILE 15621 . 15963) (
GIT-REPO-FILENAME 15965 . 16662)) (16713 23632 (GIT-COMMIT 16723 . 17301) (GIT-PUSH 17303 . 17859) (
GIT-PULL 17861 . 18267) (GIT-BRANCH-DIFF 18269 . 19464) (GIT-APPROVAL 19466 . 19667) (GIT-GET-FILE
19669 . 21044) (GIT-FILE-EXISTS? 21046 . 21770) (GIT-REMOTE-UPDATE 21772 . 22814) (GIT-REMOTE-ADD
22816 . 23123) (GIT-FILE-DATE 23125 . 23630)) (23677 27854 (GIT-CHECKOUT 23687 . 23928) (
GIT-WHICH-BRANCH 23930 . 24514) (GIT-MAKE-BRANCH 24516 . 26007) (GIT-BRANCHES 26009 . 26789) (
GIT-BRANCH-EXISTS? 26791 . 27852)) (27884 30589 (GIT-MY-CURRENT-BRANCH 27894 . 28067) (GIT-MY-BRANCHP
28069 . 28988) (GIT-MY-NEXT-BRANCH 28990 . 29431) (GIT-MY-BRANCHES 29433 . 30587)) (30635 34405 (
GIT-ADD-WORKTREE 30645 . 32405) (GIT-REMOVE-WORKTREE 32407 . 32985) (GIT-LIST-WORKTREES 32987 . 33791)
(WORKTREEDIR 33793 . 34403)) (34453 55532 (GIT-GET-DIFFERENT-FILES 34463 . 36052) (
GIT-COMPARE-BRANCHES 36054 . 39902) (GIT-COMPARE-WITH-MYMEDLEY 39904 . 43622) (GIT-COMPARE-WORKTREE
43624 . 47101) (GITCDOBJBUTTONFN 47103 . 52107) (GIT-CD-LABELFN 52109 . 53191) (GIT-CD-MENUFN 53193 .
55530)) (55578 58625 (CDGITDIR 55588 . 56168) (GIT-COMMAND 56170 . 57738) (GITORIGIN 57740 . 58317) (
GIT-INITIALS 58319 . 58623)))))
(FILEMAP (NIL (4364 5210 (GIT-CLONEP 4374 . 5208)) (7068 9104 (ALLSUBDIRS 7078 . 8302) (MEDLEYSUBDIRS
8304 . 8743) (GITSUBDIRS 8745 . 9102)) (9105 14579 (TOGIT 9115 . 11263) (FROMGIT 11265 . 12243) (
GIT-DELETE-FILE 12245 . 13139) (MYMEDLEY-DELETE-FILES 13141 . 14577)) (14580 16729 (MYMEDLEYSUBDIR
14590 . 15036) (GITSUBDIR 15038 . 15361) (STRIPDIR 15363 . 15734) (STRIPHOST 15736 . 15972) (STRIPNAME
15974 . 16727)) (16730 18258 (GFILE4MFILE 16740 . 16986) (MFILE4GFILE 16988 . 17330) (
GIT-REPO-FILENAME 17332 . 18256)) (18307 28711 (GIT-COMMIT 18317 . 18895) (GIT-PUSH 18897 . 19453) (
GIT-PULL 19455 . 19861) (GIT-BRANCH-DIFF 19863 . 23715) (GIT-APPROVAL 23717 . 23918) (GIT-GET-FILE
23920 . 26123) (GIT-FILE-EXISTS? 26125 . 26849) (GIT-REMOTE-UPDATE 26851 . 27893) (GIT-REMOTE-ADD
27895 . 28202) (GIT-FILE-DATE 28204 . 28709)) (28756 34375 (GIT-CHECKOUT 28766 . 29007) (
GIT-WHICH-BRANCH 29009 . 29593) (GIT-MAKE-BRANCH 29595 . 31086) (GIT-BRANCHES 31088 . 32066) (
GIT-BRANCH-EXISTS? 32068 . 33129) (PICK-BRANCH 33131 . 33475) (GIT-PULL-REQUESTS 33477 . 34373)) (
34405 37110 (GIT-MY-CURRENT-BRANCH 34415 . 34588) (GIT-MY-BRANCHP 34590 . 35509) (GIT-MY-NEXT-BRANCH
35511 . 35952) (GIT-MY-BRANCHES 35954 . 37108)) (37156 40926 (GIT-ADD-WORKTREE 37166 . 38926) (
GIT-REMOVE-WORKTREE 38928 . 39506) (GIT-LIST-WORKTREES 39508 . 40312) (WORKTREEDIR 40314 . 40924)) (
40974 67428 (GIT-GET-DIFFERENT-FILES 40984 . 46074) (GIT-COMPARE-BRANCHES 46076 . 51568) (
GIT-COMPARE-WITH-MYMEDLEY 51570 . 55290) (GIT-COMPARE-WORKTREE 55292 . 58769) (GITCDOBJBUTTONFN 58771
. 63775) (GIT-CD-LABELFN 63777 . 64859) (GIT-CD-MENUFN 64861 . 67426)) (67498 70950 (CDGITDIR 67508
. 68088) (GIT-COMMAND 68090 . 70063) (GITORIGIN 70065 . 70642) (GIT-INITIALS 70644 . 70948)))))
STOP

BIN
lispusers/GITFNS.LCOM
View File

Binary file not shown.

BIN
lispusers/GITFNS.TEDIT
View File

Binary file not shown.

42
lispusers/PSEUDOHOSTS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 5-Feb-2022 08:23:53" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;136 25474
(FILECREATED "24-Feb-2022 23:56:08" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;138 25865
:CHANGES-TO (FNS EXPAND.PH)
:CHANGES-TO (FNS PSEUDOHOST PSEUDOHOSTP)
:PREVIOUS-DATE "30-Jan-2022 08:58:48"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;135)
:PREVIOUS-DATE " 5-Feb-2022 08:23:53"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;136)
(PRETTYCOMPRINT PSEUDOHOSTSCOMS)
@@ -38,12 +38,18 @@
(PSEUDOHOST
[LAMBDA (HOST PREFIX)
(* ;; "Edited 30-Jan-2022 08:58 by rmk: Expand prefix so that it is rooted in a real host and not a previously defined pseudohost.")
(* ;; "Edited 24-Feb-2022 23:56 by rmk: Expand prefix so that it is rooted in a real host and not a previously defined pseudohost.")
(CL:WHEN (AND (LISTP HOST)
(NULL PREFIX))
(SETQ PREFIX (CADR HOST))
(SETQ HOST (CAR HOST)))
(CL:WHEN (EQ (CHCON1 HOST)
(CHARCODE {))
(SETQ HOST (SUBSTRING HOST 2)))
(CL:WHEN (EQ (NTHCHARCODE HOST -1)
(CHARCODE }))
(SETQ HOST (SUBSTRING HOST 1 -2)))
(SETQ HOST (U-CASE (MKATOM HOST)))
[IF PREFIX
THEN (CL:WHEN (PSEUDOHOSTP HOST) (* ;
@@ -121,11 +127,13 @@
HOST])
(PSEUDOHOSTP
[LAMBDA (HOST) (* ; "Edited 18-Jan-2022 11:29 by rmk")
[LAMBDA (HOST) (* ; "Edited 24-Feb-2022 23:51 by rmk")
(* ; "Edited 18-Jan-2022 11:29 by rmk")
(LET ((DEV (\GETDEVICEFROMNAME HOST T T)))
(CL:WHEN (AND DEV (TYPE? FDEV (FETCH (PHDEVICE TARGETDEV) OF DEV)))
(LIST HOST (FETCH (PHDEVICE PREFIX)
DEV)))])
(LIST (FETCH (FDEV DEVICENAME) OF DEV)
(FETCH (PHDEVICE PREFIX)
DEV)))])
(PSEUDOHOSTS
[LAMBDA NIL (* ; "Edited 17-Jan-2022 18:15 by rmk")
@@ -470,12 +478,12 @@
(LOAD 'EXPORTS.ALL))
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1226 8796 (PSEUDOHOST 1236 . 6496) (PSEUDOHOSTP 6498 . 6848) (PSEUDOHOSTS 6850 . 7207)
(TARGETHOST 7209 . 7483) (TRUEFILENAME 7485 . 8172) (PSEUDOFILENAME 8174 . 8794)) (8824 16095 (
EXPAND.PH 8834 . 10108) (CONTRACT.PH 10110 . 12775) (SLASHIT 12777 . 14345) (UNSLASHIT 14347 . 16093))
(16096 22886 (OPENFILE.PH 16106 . 16667) (GETFILENAME.PH 16669 . 16958) (DIRECTORYNAMEP.PH 16960 .
17584) (CLOSEFILE.PH 17586 . 17940) (REOPENFILE.PH 17942 . 18507) (DELETEFILE.PH 18509 . 18793) (
OPENP.PH 18795 . 18971) (UNREGISTERFILE.PH 18973 . 19278) (REGISTERFILE.PH 19280 . 19581) (
GENERATEFILES.PH 19583 . 20623) (GETFILEINFO.PH 20625 . 20927) (SETFILEINFO.PH 20929 . 21128) (
NEXTFILEFN.PH 21130 . 21672) (FILEINFOFN.PH 21674 . 21945) (RENAMEFILE.PH 21947 . 22884)))))
(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)))))
STOP

BIN
lispusers/PSEUDOHOSTS.LCOM
View File

Binary file not shown.

31
lispusers/comparetext
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Feb-2022 12:01:45" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;115 46109
(FILECREATED "25-Feb-2022 14:36:43" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;116 46252
:CHANGES-TO (FNS COMPARETEXT.WINDOW)
:PREVIOUS-DATE "18-Feb-2022 17:05:22"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;114)
:PREVIOUS-DATE "19-Feb-2022 12:01:45"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;115)
(* ; "
@@ -58,7 +58,8 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
HASH.TYPE REGION FILELABELS TITLE])
(COMPARETEXT.WINDOW
[LAMBDA (GRAPH REGION TITLE) (* ; "Edited 19-Feb-2022 12:01 by rmk")
[LAMBDA (GRAPH REGION TITLE) (* ; "Edited 25-Feb-2022 14:34 by rmk")
(* ; "Edited 19-Feb-2022 12:01 by rmk")
(* ; "Edited 2-Feb-2022 17:29 by rmk")
(* ; "Edited 23-Jan-2022 18:18 by rmk")
(* ; "Edited 12-Jan-2022 10:06 by rmk")
@@ -68,8 +69,8 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(LET [WINDOW GRAPHREGION WIDTH HEIGHT (FILEPREFIX (CAR (GRAPHERPROP GRAPH 'FILELABELS]
(SETQ GRAPHREGION (GRAPHREGION GRAPH))
(SETQ WIDTH (IPLUS (TIMES 2 WBorder)
(FETCH (REGION WIDTH) OF GRAPHREGION)))
[SETQ WIDTH (IMIN SCREENWIDTH (IPLUS (TIMES 2 WBorder)
(FETCH (REGION WIDTH) OF GRAPHREGION]
[SETQ HEIGHT (IMIN 200 (IPLUS (FETCH (REGION HEIGHT) OF GRAPHREGION)
(ITIMES 2 (FONTHEIGHT DEFAULTFONT]
(SETQ REGION
@@ -736,12 +737,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
)
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1344 38729 (COMPARETEXT 1354 . 2854) (COMPARETEXT.WINDOW 2856 . 6214) (
COMPARETEXT.TEXTOBJ 6216 . 8924) (COMPARETEXT.SETSEL 8926 . 9716) (CHUNKNODELABEL 9718 . 10839) (
IMCOMPARE.BOXNODE 10841 . 11608) (IMCOMPARE.CHUNKS 11610 . 15986) (IMCOMPARE.COLLECT.HASH.CHUNKS 15988
. 18905) (IMCOMPARE.DISPLAYGRAPH 18907 . 26750) (IMCOMPARE.HASH 26752 . 30939) (
IMCOMPARE.MERGE.CONNECTED.CHUNKS 30941 . 34437) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 34439 . 36394) (
IMCOMPARE.SHOW.DIST 36396 . 36842) (IMCOMPARE.UPDATE.SYMBOL.TABLE 36844 . 38727)) (38730 44887 (
IMCOMPARE.LEFTBUTTONFN 38740 . 41317) (IMCOMPARE.MIDDLEBUTTONFN 41319 . 44435) (IMCOMPARE.COPYBUTTONFN
44437 . 44885)) (44940 45631 (TAIL1 44950 . 45304) (TAIL2 45306 . 45629)))))
(FILEMAP (NIL (1344 38872 (COMPARETEXT 1354 . 2854) (COMPARETEXT.WINDOW 2856 . 6357) (
COMPARETEXT.TEXTOBJ 6359 . 9067) (COMPARETEXT.SETSEL 9069 . 9859) (CHUNKNODELABEL 9861 . 10982) (
IMCOMPARE.BOXNODE 10984 . 11751) (IMCOMPARE.CHUNKS 11753 . 16129) (IMCOMPARE.COLLECT.HASH.CHUNKS 16131
. 19048) (IMCOMPARE.DISPLAYGRAPH 19050 . 26893) (IMCOMPARE.HASH 26895 . 31082) (
IMCOMPARE.MERGE.CONNECTED.CHUNKS 31084 . 34580) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 34582 . 36537) (
IMCOMPARE.SHOW.DIST 36539 . 36985) (IMCOMPARE.UPDATE.SYMBOL.TABLE 36987 . 38870)) (38873 45030 (
IMCOMPARE.LEFTBUTTONFN 38883 . 41460) (IMCOMPARE.MIDDLEBUTTONFN 41462 . 44578) (IMCOMPARE.COPYBUTTONFN
44580 . 45028)) (45083 45774 (TAIL1 45093 . 45447) (TAIL2 45449 . 45772)))))
STOP