github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-10 21:03:22 +00:00
Code Issues Projects Releases Wiki Activity

COMPAREDIRECTORIES, COMPARESOURCES, COMPARETEXT, EXAMINEDEFS (#1329)

Browse Source 
* COMPAREDIRECTORIES, COMPARESOURCES, COMPARETEXT, EXAMINEDEFS

Relatively minor cleanups, little or no functionality improvements

* COMPAREDIRECTORIES:  Get AUTHOR only if selected

This may provide a little speed up.  But of more importance, almost all the array crashes I am seeing are underneath (GETFILEINFO xxx 'AUTHOR).  The UFS implementation may be smashing array space, or maybe it is just detecting the corruption.  For now, I'm eliminating this potential source of bad behavior.

* EXAMINEDEFS: Better interpretation of TYPE NIL = (FNS FUNCTIONS) with better formatting

* COMPARETEXT: fixed to avoid EOF error if EOL gets confused
This commit is contained in:
rmkaplan
2023-11-02 19:23:38 -07:00
committed by GitHub
parent f49729cbd3
commit 713f2388c7
8 changed files with 317 additions and 247 deletions
Download Patch File Download Diff File Expand all files Collapse all files

155
lispusers/COMPAREDIRECTORIES
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Oct-2022 12:03:37" 
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;252 128695
(FILECREATED "29-Sep-2023 17:25:57" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;257 130870
:CHANGES-TO (FNS CDFILES)
:EDIT-BY rmk
:PREVIOUS-DATE "14-Aug-2022 12:13:45"
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;250)
:CHANGES-TO (FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS)
:PREVIOUS-DATE "28-Sep-2023 23:20:57" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;256)
(* ; "
@@ -16,7 +16,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)
(RPAQQ COMPAREDIRECTORIESCOMS
(
[
(* ;; "Compare the contents of two directories.")
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS COMPAREDIRECTORIES.CANDIDATES
@@ -25,7 +25,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(FNS CDFILES CDFILES.MATCH CDFILES.PATS)
(FNS CDPRINT CDPRINT.HEADER CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS
CDTEDIT)
(FNS CDMAP CDENTRY CDSUBSET CDMERGE CDMERGE.COMMON)
(FNS CDMAP CDENTRY CDSUBSET CDMERGE CDMERGE.COMMON CD.SORT)
(FNS BINCOMP EOLTYPE EOLTYPE.SHOW)
(RECORDS CDMAXNCHARS CDVALUE CDENTRY CDINFO)
@@ -56,7 +56,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
CDBROWSER-COPY CDBROWSER-DELETE-FILE CD-SWAPDIRS)
(VARS CDTABLEBROWSER.MENUITEMS)
(FILES (SYSLOAD)
COMPARESOURCES COMPARETEXT))))
COMPARESOURCES COMPARETEXT)
(P (MOVD? 'NILL 'TEDIT.FILEDATE])
@@ -66,7 +67,9 @@ 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 29-Mar-2022 11:50 by rmk")
FIXDIRECTORYDATES) (* ; "Edited 29-Sep-2023 17:25 by rmk")
(* ; "Edited 5-Apr-2023 10:12 by rmk")
(* ; "Edited 29-Mar-2022 11:50 by rmk")
(* ; "Edited 23-Feb-2022 21:10 by rmk")
(* ; "Edited 4-Jan-2022 12:09 by rmk")
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
@@ -120,7 +123,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CDPRINT.HEADER DIR1 DIR2 SELECT DATE T)
(PRINTOUT T " ... ")
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS DIR1 INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH1
USEDIRECTORYDATE))
USEDIRECTORYDATE (MEMB 'AUTHOR SELECT)))
(SETQ INFOS2 (COMPAREDIRECTORIES.INFOS DIR2 INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH2
USEDIRECTORYDATE))
@@ -138,7 +141,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(SETQ CDENTRIES (SORT (CDENTRIES.SELECT (COMPAREDIRECTORIES.CANDIDATES INFOS1 INFOS2)
SELECT)
T))
(FUNCTION CD.SORT)))
(PRINTOUT T (LENGTH CDENTRIES)
" entries" T)
(REPLACE CDENTRIES OF CDVALUE WITH CDENTRIES)
@@ -148,7 +151,9 @@ 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 (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH USEDIRECTORYDATE)
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH USEDIRECTORYDATE INCLUDEAUTHOR)
(* ;; "Edited 29-Sep-2023 17:25 by rmk")
(* ;; "Edited 22-May-2022 14:17 by rmk")
@@ -176,7 +181,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
LDATE)))
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
AUTHOR _ (GETFILEINFO STREAM 'AUTHOR)
AUTHOR _ (AND INCLUDEAUTHOR (GETFILEINFO STREAM 'AUTHOR))
TYPE _ TYPE
EOL _ (EOLTYPE STREAM)))
(CLOSEF? STREAM))
@@ -322,7 +327,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
CDE])
(COMPAREDIRECTORIES.INFOS.TYPE
[LAMBDA (FILE) (* ; "Edited 22-May-2022 14:27 by rmk")
[LAMBDA (FILE) (* ; "Edited 28-Sep-2023 23:09 by rmk")
(* ; "Edited 22-May-2022 14:27 by rmk")
(* ; "Edited 25-Apr-2022 09:02 by rmk")
(* ; "Edited 4-Jan-2022 13:10 by rmk")
(* ; "Edited 12-Dec-2021 22:50 by rmk")
@@ -330,9 +336,11 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CL:MULTIPLE-VALUE-SETQ (TYPE DATE)
(LISPFILETYPE FILE))
(CL:UNLESS TYPE
(SETQ TYPE (IF (PRINTFILETYPE FILE)
ELSEIF (MEMB (FILENAMEFIELD FILE 'EXTENSION)
'(TXT TEXT SH MD C))
(SETQ TYPE (IF (SETQ DATE (TEDIT.FILEDATE FILE))
THEN 'TEDIT
ELSEIF (PRINTFILETYPE FILE)
ELSE (MEMB (FILENAMEFIELD FILE 'EXTENSION)
'(TXT TEXT SH MD C))
THEN 'TEXT
ELSE 'OTHER)))
(CL:VALUES TYPE DATE])
@@ -388,7 +396,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(DEFINEQ
(CDFILES
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 3-Oct-2022 12:03 by rmk")
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 17-Jun-2023 23:04 by rmk")
(* ; "Edited 3-Oct-2022 12:03 by rmk")
(* ; "Edited 25-Apr-2022 08:42 by rmk")
(* ; "Edited 5-Mar-2022 15:05 by rmk")
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
@@ -457,7 +466,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 DIR)))
(FOR FULLNAME NAME EXT SUBDIR UNPACK THISDEPTH (STARTPOS _ (IPLUS 2 (NCHARS DIR)))
IN (DIRECTORY ENUMPAT `(DEPTH ,DEPTH COLLECT)
NIL
(CL:IF ALLVERSIONS
@@ -509,7 +518,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(ILEQ THISDEPTH (CADDDR P])
(CDFILES.PATS
[LAMBDA (PATTERNS) (* ; "Edited 23-Dec-2021 17:02 by rmk")
[LAMBDA (PATTERNS) (* ; "Edited 17-Jun-2023 23:36 by rmk")
(* ; "Edited 23-Dec-2021 17:02 by rmk")
(* ;; "Returns (NAME EXT SUBDIR DEPTH) items where NAME or EXT may be the wildcard *, SD is the subdirectory (if any) and DEPTH is the number of / or > in the subdirectory")
@@ -519,38 +529,47 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(* * NIL 1)
)
ELSE (FOR P N E SD D UNPACK INSIDE PATTERNS
JOIN (SETQ UNPACK (UNPACKFILENAME P))
(SETQ SD (LISTGET UNPACK 'SUBDIRECTORY))
ELSE (FOR P N E SD DEPTH UNPACK INSIDE PATTERNS
JOIN (SETQ UNPACK (UNPACKFILENAME.STRING P)) (* ;
 "String so we can tell the difference between x and x.")
[SETQ SD (MKATOM (LISTGET UNPACK 'SUBDIRECTORY]
(* ;; "Count the subdirectory depth")
[SETQ D (IF (EQ SD '*)
THEN MAX.SMALLP
ELSE (FOR I (CNT _ 1) FROM 1 DO (SELCHARQ (NTHCHARCODE SD I)
((/ >)
(ADD CNT 1))
(NIL (RETURN CNT))
NIL]
[SETQ DEPTH (IF (EQ SD '*)
THEN MAX.SMALLP
ELSE (FOR I (CNT _ 1) FROM 1 DO (SELCHARQ (NTHCHARCODE SD I)
((/ >)
(ADD CNT 1))
(NIL (RETURN CNT))
NIL]
(SETQ N (LISTGET UNPACK 'NAME))
(SETQ N (if (NULL N)
then '*
elseif (NEQ 0 (NCHARS N))
then (MKATOM N)))
(SETQ E (LISTGET UNPACK 'EXTENSION))
(IF [OR (AND (STRING.EQUAL N 'COM)
(SETQ E (if (NULL E)
then '*
elseif (NEQ 0 (NCHARS E))
then (MKATOM E)))
(if [OR (AND (STRING.EQUAL N 'COM)
(NULL E))
(AND (STRING.EQUAL E 'COM)
(MEMB N ' (* NIL)]
THEN (FOR CE IN *COMPILED-EXTENSIONS* COLLECT (LIST '* CE SD D))
THEN (FOR CE IN *COMPILED-EXTENSIONS* COLLECT (LIST '* CE SD DEPTH))
ELSE (CONS (IF N
THEN (LIST N E SD D)
THEN (LIST N E SD DEPTH)
ELSEIF E
THEN
(* ;; "This is the case .XXX, which presumably identifies a dotted file. If this is supposed to be all files with extension XXX, it shoud be specified as *.XXX, the case above. So we move .E into the N field.")
(LIST (PACK* '%. E)
NIL SD D)
NIL SD DEPTH)
ELSE `
(* * (\, SD) (\, D))
(* * (\, SD) (\, DEPTH))
])
)
(DEFINEQ
@@ -881,7 +900,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
WHEN (APPLY* FN CDE) COLLECT CDE])
(CDMERGE
[LAMBDA (CDVALUES) (* ; "Edited 24-Jan-2022 17:01 by rmk")
[LAMBDA (CDVALUES) (* ; "Edited 5-Apr-2023 10:10 by rmk")
(* ; "Edited 24-Jan-2022 17:01 by rmk")
(* ;; "This merges a collection of CDVALUES on different directories into a single CDVALUE with the union of the CDENTRIES, provided that they have the same selection criteria. The merged directories will be the minimal common prefix of all of the entries on each side, and the residual of the directory will be packed onto all the names.")
@@ -919,8 +939,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
 "Merge the CDENTRIES with matchnames pulled back so that subdirectories show up")
(SETQ MERGEDENTRIES
(SORT [FOR CDV NC1 _ (ADD1 (NCHARS DIR1))
NC2 _ (ADD1 (NCHARS DIR2)) IN (CDR CDS)
(SORT [FOR CDV (NC1 _ (ADD1 (NCHARS DIR1)))
(NC2 _ (ADD1 (NCHARS DIR2))) IN (CDR CDS)
JOIN (FOR CDE IN (FETCH CDENTRIES OF CDV)
COLLECT (CREATE CDENTRY
USING CDE MATCHNAME _
@@ -933,7 +953,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
OF (FETCH INFO2
OF CDE))
NC2]
T))
(FUNCTION CD.SORT)))
(CD.UPDATEWIDTHS (CREATE CDVALUE
CDDIR1 _ DIR1
CDDIR2 _ DIR2
@@ -962,6 +982,19 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(L-CASECODE CY] DO (RETURN (CL:IF (EQ I 1)
""
(SUBSTRING DIRX 1 LASTDIRPOS))])
(CD.SORT
[LAMBDA (ENTRY1 ENTRY2) (* ; "Edited 5-Apr-2023 10:15 by rmk")
(* ;; "Groups same file with different extensions together. FOO and FOO.LCOM together, even if FOO-FUM exists (hyphen comes before period).")
(LET ((M1 (FETCH MATCHNAME OF ENTRY1))
(M2 (FETCH MATCHNAME OF ENTRY2))
ORDER)
(CL:IF [EQ 'EQUAL (SETQ ORDER (ALPHORDER (PACKFILENAME 'EXTENSION NIL 'BODY M1)
(PACKFILENAME 'EXTENSION NIL 'BODY M2]
(ALPHORDER M1 M2)
ORDER)])
)
(DEFINEQ
@@ -2154,28 +2187,30 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(FILESLOAD (SYSLOAD)
COMPARESOURCES COMPARETEXT)
(MOVD? 'NILL 'TEDIT.FILEDATE)
(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998
2018 2020 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2624 22181 (COMPAREDIRECTORIES 2634 . 7467) (COMPAREDIRECTORIES.INFOS 7469 . 10343) (
COMPAREDIRECTORIES.CANDIDATES 10345 . 13730) (CDENTRIES.SELECT 13732 . 18507) (
COMPAREDIRECTORIES.INFOS.TYPE 18509 . 19415) (MATCHNAME 19417 . 20097) (CD.INSURECDVALUE 20099 . 21713
) (CD.UPDATEWIDTHS 21715 . 22179)) (22182 32000 (CDFILES 22192 . 28094) (CDFILES.MATCH 28096 . 29721)
(CDFILES.PATS 29723 . 31998)) (32001 49822 (CDPRINT 32011 . 34528) (CDPRINT.HEADER 34530 . 35427) (
CDPRINT.LINE 35429 . 38661) (CDPRINT.MAXWIDTHS 38663 . 42778) (CDPRINT.COLHEADERS 42780 . 44065) (
CDPRINT.COLUMNS 44067 . 49187) (CDTEDIT 49189 . 49820)) (49823 58192 (CDMAP 49833 . 51265) (CDENTRY
51267 . 51576) (CDSUBSET 51578 . 53017) (CDMERGE 53019 . 56873) (CDMERGE.COMMON 56875 . 58190)) (58193
65731 (BINCOMP 58203 . 62492) (EOLTYPE 62494 . 65056) (EOLTYPE.SHOW 65058 . 65729)) (66259 78786 (
FIND-UNCOMPILED-FILES 66269 . 69912) (FIND-UNSOURCED-FILES 69914 . 72298) (FIND-SOURCE-FILES 72300 .
74038) (FIND-COMPILED-FILES 74040 . 75917) (FIND-UNLOADED-FILES 75919 . 76772) (FIND-LOADED-FILES
76774 . 77202) (FIND-MULTICOMPILED-FILES 77204 . 78784)) (78787 87218 (CREATED-AS 78797 . 83594) (
SOURCE-FOR-COMPILED-P 83596 . 86523) (COMPILE-SOURCE-DATE-DIFF 86525 . 87216)) (87219 97525 (
FIX-DIRECTORY-DATES 87229 . 90222) (FIX-EQUIV-DATES 90224 . 91749) (COPY-COMPARED-FILES 91751 . 93572)
(COPY-MISSING-FILES 93574 . 95731) (COMPILED-ON-SAME-SOURCE 95733 . 97523)) (97719 105557 (CDBROWSER
97729 . 101656) (CDBROWSER.STRINGS 101658 . 105555)) (105719 107455 (CD.TABLEITEM 105729 . 105949) (
CD.TABLEITEM.PRINTFN 105951 . 106150) (CD.TABLEITEM.COPYFN 106152 . 107210) (
CDTABLEBROWSER.HEADING.REPAINTFN 107212 . 107453)) (107456 128111 (CDTABLEBROWSER.WHENSELECTEDFN
107466 . 107934) (CD.COMMANDSELECTEDFN 107936 . 113037) (CD-MENUFN 113039 . 117350) (CD-COMPARE-FILES
117352 . 120704) (CDBROWSER-COPY 120706 . 124375) (CDBROWSER-DELETE-FILE 124377 . 127590) (CD-SWAPDIRS
127592 . 128109)))))
(FILEMAP (NIL (2651 22769 (COMPAREDIRECTORIES 2661 . 7751) (COMPAREDIRECTORIES.INFOS 7753 . 10711) (
COMPAREDIRECTORIES.CANDIDATES 10713 . 14098) (CDENTRIES.SELECT 14100 . 18875) (
COMPAREDIRECTORIES.INFOS.TYPE 18877 . 20003) (MATCHNAME 20005 . 20685) (CD.INSURECDVALUE 20687 . 22301
) (CD.UPDATEWIDTHS 22303 . 22767)) (22770 33392 (CDFILES 22780 . 28794) (CDFILES.MATCH 28796 . 30421)
(CDFILES.PATS 30423 . 33390)) (33393 51214 (CDPRINT 33403 . 35920) (CDPRINT.HEADER 35922 . 36819) (
CDPRINT.LINE 36821 . 40053) (CDPRINT.MAXWIDTHS 40055 . 44170) (CDPRINT.COLHEADERS 44172 . 45457) (
CDPRINT.COLUMNS 45459 . 50579) (CDTEDIT 50581 . 51212)) (51215 60336 (CDMAP 51225 . 52657) (CDENTRY
52659 . 52968) (CDSUBSET 52970 . 54409) (CDMERGE 54411 . 58395) (CDMERGE.COMMON 58397 . 59712) (
CD.SORT 59714 . 60334)) (60337 67875 (BINCOMP 60347 . 64636) (EOLTYPE 64638 . 67200) (EOLTYPE.SHOW
67202 . 67873)) (68403 80930 (FIND-UNCOMPILED-FILES 68413 . 72056) (FIND-UNSOURCED-FILES 72058 . 74442
) (FIND-SOURCE-FILES 74444 . 76182) (FIND-COMPILED-FILES 76184 . 78061) (FIND-UNLOADED-FILES 78063 .
78916) (FIND-LOADED-FILES 78918 . 79346) (FIND-MULTICOMPILED-FILES 79348 . 80928)) (80931 89362 (
CREATED-AS 80941 . 85738) (SOURCE-FOR-COMPILED-P 85740 . 88667) (COMPILE-SOURCE-DATE-DIFF 88669 .
89360)) (89363 99669 (FIX-DIRECTORY-DATES 89373 . 92366) (FIX-EQUIV-DATES 92368 . 93893) (
COPY-COMPARED-FILES 93895 . 95716) (COPY-MISSING-FILES 95718 . 97875) (COMPILED-ON-SAME-SOURCE 97877
. 99667)) (99863 107701 (CDBROWSER 99873 . 103800) (CDBROWSER.STRINGS 103802 . 107699)) (107863
109599 (CD.TABLEITEM 107873 . 108093) (CD.TABLEITEM.PRINTFN 108095 . 108294) (CD.TABLEITEM.COPYFN
108296 . 109354) (CDTABLEBROWSER.HEADING.REPAINTFN 109356 . 109597)) (109600 130255 (
CDTABLEBROWSER.WHENSELECTEDFN 109610 . 110078) (CD.COMMANDSELECTEDFN 110080 . 115181) (CD-MENUFN
115183 . 119494) (CD-COMPARE-FILES 119496 . 122848) (CDBROWSER-COPY 122850 . 126519) (
CDBROWSER-DELETE-FILE 126521 . 129734) (CD-SWAPDIRS 129736 . 130253)))))
STOP

BIN
lispusers/COMPAREDIRECTORIES.LCOM
View File

Binary file not shown.

145
lispusers/COMPARESOURCES
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "22-May-2022 18:46:01" 
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPARESOURCES.;128 39655
(FILECREATED "17-Jun-2023 15:22:40" {WMEDLEY}<lispusers>COMPARESOURCES.;131 39663
:CHANGES-TO (FNS COMPARESOURCES CSBROWSER \CS.EXAMINE)
(VARS COMPARESOURCESCOMS)
:EDIT-BY rmk
:PREVIOUS-DATE "12-May-2022 10:17:13"
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPARESOURCES.;123)
:CHANGES-TO (FNS CSBROWSER \CS.COMPARE.MASTERS)
:PREVIOUS-DATE "22-May-2022 18:46:01" {WMEDLEY}<lispusers>COMPARESOURCES.;128)
(* ; "
@@ -141,25 +140,26 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
'SAME])
(\CS.COMPARE.MASTERS
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 25-Feb-2022 18:02 by rmk")
[LAMBDA (BODY1 BODY2 DW?) (* ; "Edited 17-Jun-2023 15:19 by rmk")
(* ; "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)
(SETQ BODYX (CL:REMOVE-IF (FUNCTION EDITDATE?)
BODYX)) (* ;
(LET (THING2 THING1 PRED DIFS TMP)
(SETQ BODY1 (CL:REMOVE-IF (FUNCTION EDITDATE?)
BODY1)) (* ;
 "We don't care about editdate comments")
(SETQ BODYY (CL:REMOVE-IF (FUNCTION EDITDATE?)
BODYY))
(SETQ BODYX (\CS.FIXFNS BODYX))
(SETQ BODYY (\CS.FIXFNS BODYY))
(CL:WHEN (AND (SETQ XTHING (ASSOC 'DEFINE-FILE-INFO BODYX))
(SETQ YTHING (ASSOC 'DEFINE-FILE-INFO BODYY))
(\CS.COMPARE.DEFINE-FILE-INFO XTHING YTHING))
(SETQ BODYX (REMOVE XTHING BODYX))
(SETQ BODYY (REMOVE YTHING BODYY)))
(SETQ BODY2 (CL:REMOVE-IF (FUNCTION EDITDATE?)
BODY2))
(SETQ BODY1 (\CS.FIXFNS BODY1))
(SETQ BODY2 (\CS.FIXFNS BODY2))
(CL:WHEN (AND (SETQ THING1 (ASSOC 'DEFINE-FILE-INFO BODY1))
(SETQ THING2 (ASSOC 'DEFINE-FILE-INFO BODY2))
(\CS.COMPARE.DEFINE-FILE-INFO THING1 THING2))
(SETQ BODY1 (REMOVE THING1 BODY1))
(SETQ BODY2 (REMOVE THING2 BODY2)))
(* ;; "These are for commonlispy definers")
@@ -168,18 +168,18 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
do
(* ;; "handle definer based things")
(for DEFFER in DEFFERS WHEN [AND (SETQ XTHING (for X in BODYX collect X
(for DEFFER in DEFFERS WHEN [AND (SETQ THING1 (for X in BODY1 collect X
when (EQ (CAR X)
DEFFER)))
(SETQ YTHING (for X in BODYY collect X
(SETQ THING2 (for X in BODY2 collect X
when (EQ (CAR X)
DEFFER]
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)))
(CL:WHEN (SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING
(SETQ BODY1 (CL:SET-DIFFERENCE BODY1 THING1 :TEST (FUNCTION EQUALALL)))
(SETQ BODY2 (CL:SET-DIFFERENCE BODY2 THING2 :TEST (FUNCTION EQUALALL)))
(CL:WHEN (SETQ DIFS (\CS.COMPARE.TYPES THING1 THING2
(CONCAT (OR (CL:DOCUMENTATION TYPE 'DEFINE-TYPES)
TYPE)
" defined by " DEFFER)
@@ -194,11 +194,11 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
(* ;; "These are for other filepkage types, as registered in COMPARESOURCETYPES")
[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)
WHEN [AND (SETQ THING1 (for X in BODY1 collect X when (CL:FUNCALL PRED X)))
(SETQ THING2 (for X in BODY2 collect X when (CL:FUNCALL PRED X]
do (SETQ BODY1 (CL:SET-DIFFERENCE BODY1 THING1 :TEST (FUNCTION EQUALALL)))
(SETQ BODY2 (CL:SET-DIFFERENCE BODY2 THING2 :TEST (FUNCTION EQUALALL)))
(CL:WHEN [SETQ DIFS (\CS.COMPARE.TYPES THING1 THING2 (OR (fetch (CSTYPE TITLE)
of TYPE)
(MKSTRING (fetch (CSTYPE
FPKGTYPE)
@@ -211,23 +211,23 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
((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
(SETQ BODY2 (CL:SET-DIFFERENCE BODY2 (PROG1 BODY1
(SETQ BODY1 (CL:SET-DIFFERENCE
BODY1 BODY2 :TEST
(FUNCTION EQUALALL))))
:TEST
(FUNCTION EQUALALL)))
(COND
((OR BODYX BODYY)
((OR BODY1 BODY2)
(printout CONTEXTSTREAM T "---Expressions:" T)
(LET ((COMMENTX 0)
(COMMENTY 0)) (* ; "Remove comments")
[SETQ BODYX (for X in BODYX collect X unless (COND
[SETQ BODY1 (for X in BODY1 collect X unless (COND
((EQ (CAR X)
COMMENTFLG)
(add COMMENTX 1)
T]
[SETQ BODYY (for Y in BODYY collect Y unless (COND
[SETQ BODY2 (for Y in BODY2 collect Y unless (COND
((EQ (CAR Y)
COMMENTFLG)
(add COMMENTY 1)
@@ -238,14 +238,14 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
(printout CONTEXTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments."
T T)))
[COND
[BODYX (COND
(BODYY (COMPARELISTS BODYX BODYY COMPARESTREAM)
(\CS.EXAMINE BODYX BODYY NIL 'Expression))
[BODY1 (COND
(BODY2 (COMPARELISTS BODY1 BODY2 COMPARESTREAM)
(\CS.EXAMINE BODY1 BODY2 NIL 'Expression))
(T (printout COMPARESTREAM "These are not on File 2:" T)
(FOR X IN BODYX DO (LVLPRINT X COMPARESTREAM 2 3)
(FOR X IN BODY1 DO (LVLPRINT X COMPARESTREAM 2 3)
(\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)
(BODY2 (printout COMPARESTREAM "These are not on File 1:" T)
(FOR Y IN BODY2 DO (LVLPRINT Y COMPARESTREAM 2 3)
(\CS.EXAMINE NIL Y T NIL 'Expression]
(OR (ASSOC 'Other DIFFERENCES)
(push DIFFERENCES (LIST 'Other '--])
@@ -622,7 +622,9 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
(DEFINEQ
(CSBROWSER
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION IGNORECOMMENTS TITLE)
[LAMBDA (FILE1 FILE2 DW? LABEL1 LABEL2 REGION IGNORECOMMENTS TITLE)
(* ;; "Edited 17-Jun-2023 15:21 by rmk")
(* ;; "Edited 22-May-2022 18:42 by rmk")
@@ -637,28 +639,29 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
(* ;; "Don't use the INFILEP value, because that might screw with capitalization that the caller prefers. If the file can be found that way, then lower functions will find it.")
(DECLARE (SPECVARS LABEL1 LABEL2))
(SETQ FILEX (OR (STREAMP FILEX)
(INFILEP FILEX)
(FINDFILE FILEX NIL DIRECTORIES)
(ERROR "FILE NOT FOUND" FILEX)))
(SETQ FILEY (OR (STREAMP FILEY)
(INFILEP FILEY)
(FINDFILE FILEY NIL DIRECTORIES)
(ERROR "FILE NOT FOUND" FILEY)))
(CL:UNLESS (LISPSOURCEFILEP FILEX)
(ERROR FILEX " is not a Medley source file"))
(CL:UNLESS (LISPSOURCEFILEP FILEY)
(ERROR FILEX " is not a Medley source file"))
(SETQ FILE1 (OR (STREAMP FILE1)
(INFILEP FILE1)
(FINDFILE FILE1 NIL DIRECTORIES)
(ERROR "FILE NOT FOUND" FILE1)))
(SETQ FILE2 (OR (STREAMP FILE2)
(INFILEP FILE2)
(FINDFILE FILE2 NIL DIRECTORIES)
(ERROR "FILE NOT FOUND" FILE2)))
(CL:UNLESS (LISPSOURCEFILEP FILE1)
(ERROR FILE1 " is not a Medley source file"))
(CL:UNLESS LABEL1
(SETQ LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILE1)))
(CL:UNLESS LABEL2
(SETQ LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILE2)))
(CL:UNLESS (LISPSOURCEFILEP FILE2)
(ERROR FILE1 " is not a Medley source file"))
(CL:UNLESS TITLE
[SETQ TITLE (CONCAT "COMPARESOURCES of " (OR LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL
'BODY FILEX))
" and "
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY])
(SETQ TITLE (CONCAT "COMPARESOURCES of " LABEL1 " and " LABEL2)))
(LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T (FONTPROP DEFAULTFONT 'HEIGHT]
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
(GETPROMPTWINDOW WINDOW T)
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
(COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
(COMPARESOURCES FILE1 FILE2 '(T 2WINDOWS)
DW? WINDOW IGNORECOMMENTS LABEL1 LABEL2)
(OPENW WINDOW)
WINDOW])
@@ -679,16 +682,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 (1864 25616 (COMPARESOURCES 1874 . 8001) (\CS.COMPARE.MASTERS 8003 . 15415) (
\CS.COMPARE.TYPES 15417 . 18683) (\CS.EXAMINE 18685 . 21863) (\CS.FIXFNS 21865 . 23367) (
\CS.SORT.DECLARES 23369 . 23712) (\CS.SORT.DECLARE1 23714 . 25134) (\CS.FILTER.GARBAGE 25136 . 25614))
(25617 30153 (\CS.ISFNFORM 25627 . 25895) (\CS.COMPARE.FNS 25897 . 26139) (\CS.FNSID 26141 . 26285) (
\CS.ISVARFORM 26287 . 26392) (\CS.COMPARE.VARS 26394 . 27056) (\CS.ISMACROFORM 27058 . 27196) (
\CS.ISRECFORM 27198 . 27526) (\CS.REC.NAME 27528 . 27847) (\CS.ISCOURIERFORM 27849 . 27949) (
\CS.ISTEMPLATEFORM 27951 . 28049) (\CS.COMPARE.TEMPLATES 28051 . 28416) (\CS.ISPROPFORM 28418 . 28573)
(\CS.PROP.NAME 28575 . 28720) (\CS.COMPARE.PROPS 28722 . 28879) (\CS.ISADDVARFORM 28881 . 28974) (
\CS.COMPARE.ADDVARS 28976 . 29141) (\CS.ISFPKGCOMFORM 29143 . 29350) (\CS.COMPARE.FPKGCOMS 29352 .
29559) (\CS.COMPARE.DEFINE-FILE-INFO 29561 . 30151)) (30154 36218 (CSOBJ.CREATE 30164 . 30577) (
CSOBJ.DISPLAYFN 30579 . 31332) (CSOBJ.IMAGEBOXFN 31334 . 33495) (CSOBJ.BUTTONEVENTINFN 33497 . 35968)
(CSOBJ.COPYBUTTONEVENTINFN 35970 . 36216)) (37099 39228 (CSBROWSER 37109 . 39226)))))
(FILEMAP (NIL (1751 25612 (COMPARESOURCES 1761 . 7888) (\CS.COMPARE.MASTERS 7890 . 15411) (
\CS.COMPARE.TYPES 15413 . 18679) (\CS.EXAMINE 18681 . 21859) (\CS.FIXFNS 21861 . 23363) (
\CS.SORT.DECLARES 23365 . 23708) (\CS.SORT.DECLARE1 23710 . 25130) (\CS.FILTER.GARBAGE 25132 . 25610))
(25613 30149 (\CS.ISFNFORM 25623 . 25891) (\CS.COMPARE.FNS 25893 . 26135) (\CS.FNSID 26137 . 26281) (
\CS.ISVARFORM 26283 . 26388) (\CS.COMPARE.VARS 26390 . 27052) (\CS.ISMACROFORM 27054 . 27192) (
\CS.ISRECFORM 27194 . 27522) (\CS.REC.NAME 27524 . 27843) (\CS.ISCOURIERFORM 27845 . 27945) (
\CS.ISTEMPLATEFORM 27947 . 28045) (\CS.COMPARE.TEMPLATES 28047 . 28412) (\CS.ISPROPFORM 28414 . 28569)
(\CS.PROP.NAME 28571 . 28716) (\CS.COMPARE.PROPS 28718 . 28875) (\CS.ISADDVARFORM 28877 . 28970) (
\CS.COMPARE.ADDVARS 28972 . 29137) (\CS.ISFPKGCOMFORM 29139 . 29346) (\CS.COMPARE.FPKGCOMS 29348 .
29555) (\CS.COMPARE.DEFINE-FILE-INFO 29557 . 30147)) (30150 36214 (CSOBJ.CREATE 30160 . 30573) (
CSOBJ.DISPLAYFN 30575 . 31328) (CSOBJ.IMAGEBOXFN 31330 . 33491) (CSOBJ.BUTTONEVENTINFN 33493 . 35964)
(CSOBJ.COPYBUTTONEVENTINFN 35966 . 36212)) (37095 39236 (CSBROWSER 37105 . 39234)))))
STOP

BIN
lispusers/COMPARESOURCES.LCOM
View File

Binary file not shown.

BIN
lispusers/COMPARETEXT.LCOM
View File

Binary file not shown.

146
lispusers/EXAMINEDEFS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 9-Jul-2022 11:05:08" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>EXAMINEDEFS.;40 12957
(FILECREATED "13-Oct-2023 11:18:04" {WMEDLEY}<lispusers>EXAMINEDEFS.;48 14244
:CHANGES-TO (FNS EXAMINEDEFS)
:EDIT-BY rmk
:PREVIOUS-DATE "24-Jun-2022 18:52:03"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>EXAMINEDEFS.;39)
:CHANGES-TO (FNS EXAMINEDEFS TEDITDEF)
:PREVIOUS-DATE "19-Jul-2023 13:59:26" {WMEDLEY}<lispusers>EXAMINEDEFS.;44)
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
@@ -19,49 +19,66 @@
(DEFINEQ
(EXAMINEDEFS
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 9-Jul-2022 11:04 by rmk")
(* ; "Edited 24-Jun-2022 18:51 by rmk")
(* ; "Edited 23-Jun-2022 17:58 by rmk")
(* ; "Edited 25-Feb-2022 15:01 by rmk")
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 13-Oct-2023 11:11 by rmk")
(* ; "Edited 18-May-2023 22:35 by rmk")
(* ; "Edited 21-Apr-2023 14:42 by rmk")
(* ;; "This provides for side-by-side examination of separate but presumably related expressions. The (LISTP) expressions can be provided directly as SOURCE1 and SOURCE2 or, if NAME is given the copies of the definitions of NAME as TYPE on the two sources are examined.")
(* ;; "This provides for side-by-side examination of separate but presumably related expressions. The (LISTP) expressions can be provided directly as the definitions SOURCE1 and SOURCE2 or, if NAME is given the copies of the definitions of NAME as TYPE on the two sources are examined. If both SOURCE1 and SOURCE2 are NIL, then SOURCE1 is the existing file defintions, NIL is the existing in-memory definition")
(* ;; "")
(* ;; "Examination is in side-by-side attached SEDIT windows if SEDIT is the EDITMODE. You can use SEDIT operations to zoom in on the location of any changes, deleting common stuff for example. But you are always working on a copy, so that changes are safe and ephemeral. This is an examination, not an edit.")
(CL:UNLESS NAME
(CL:UNLESS (LISTP SOURCE1)
(ERROR SOURCE1 " cannot be examined"))
(CL:UNLESS (LISTP SOURCE2)
(ERROR SOURCE2 " cannot be examined")))
(CL:UNLESS TYPE
(SETQ TYPE 'FNS))
(if NAME
then (CL:UNLESS [OR SOURCE1 SOURCE2 (SETQ SOURCE2 (CAR (WHEREIS NAME
(OR TYPE '(FNS FUNCTIONS))
T]
(ERROR (CONCAT "Can't find " NAME " definitions to examine")))
else (CL:UNLESS (LISTP SOURCE1)
(ERROR SOURCE1 " cannot be examined"))
(CL:UNLESS (LISTP SOURCE2)
(ERROR SOURCE2 " cannot be examined")))
(* ;; "TITLE1 and TITLE2 are optional strings that will be used to construct the titles of the SEDIT windows. We would like to know where GETDEF got the definition so we can use that, but there isn't an interface that provides that information (extended WHEREIS?)")
(LET (DEF1 DEF2)
(SETQ DEF1 (IF (LISTP SOURCE1)
THEN
(* ;; "Copy to simulate READONLY")
(* ;; "")
(SETQ DEF1 (COPY SOURCE1))
ELSEIF (GETDEF NAME TYPE SOURCE1)
ELSE (ERROR NAME " not found on " SOURCE1)))
(SETQ DEF2 (IF (LISTP SOURCE2)
THEN (COPY SOURCE2)
ELSEIF (GETDEF NAME TYPE SOURCE2)
ELSE (ERROR NAME " not found on " SOURCE2)))
(* ;; "If SOURCE1 and SOURCE2 are both NIL, SOURCE1 defaults to the current (in memory) definition, SOURCE2 defaults to the definition on the current file.")
(LET (DEF1 DEF2)
(if (SETQ DEF1 (LISTP SOURCE1))
elseif TYPE
then (NEQ (SETQ DEF1 (GETDEF NAME TYPE SOURCE1 'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
elseif (NEQ (SETQ DEF1 (GETDEF NAME (SETQ TYPE 'FNS)
SOURCE1
'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
elseif (NEQ (SETQ DEF1 (GETDEF NAME (SETQ TYPE 'FUNCTIONS)
SOURCE1
'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
else (ERROR NAME (CONCAT "not found on " SOURCE1)))
(if (SETQ DEF2 (LISTP SOURCE2))
elseif (NEQ (SETQ DEF2 (GETDEF NAME TYPE SOURCE2 'NOERROR))
(FILEPKGTYPE TYPE 'NULLDEF))
else (ERROR NAME (CONCAT "not found on " SOURCE2)))
(CL:UNLESS TITLE1
(SETQ TITLE1 (CL:IF (AND SOURCE1 (ILEQ (COUNT SOURCE1)
5))
SOURCE1
"File 1")))
(SETQ TITLE1 (OR (AND (OR (LISTP SOURCE1)
(NULL SOURCE1))
'Current)
(AND (MEMB (U-CASE SOURCE1)
'(PROP SAVED))
'Saved)
(FINDFILE SOURCE1)
SOURCE1)))
(CL:UNLESS TITLE2
(SETQ TITLE2 (CL:IF (AND SOURCE2 (ILEQ (COUNT SOURCE2)
5))
SOURCE2
"File 2")))
(SETQ TITLE2 (OR (AND (OR (LISTP SOURCE2)
(NULL SOURCE2))
'Current)
(AND (MEMB (U-CASE SOURCE2)
'(PROP SAVED))
'Saved)
(FINDFILE SOURCE2)
SOURCE2)))
(SELECTQ (EDITMODE)
(SEDIT:SEDIT
(* ;;
@@ -80,7 +97,9 @@
 "Crude suggestions for height, width, position. Suggest shorter window for smaller structures")
(SELECTQ EXAMINEWITH
(SEDIT (CL:UNLESS (REGIONP REGION)
(SEDIT (SETQ DEF1 (COPY DEF1)) (* ; "Copy to simulate read-only")
(SETQ DEF2 (COPY DEF2))
(CL:UNLESS (REGIONP REGION)
(SETQ REGION (GETREGION)))
[LET (R1 R2 HALFWIDTH W1 W2)
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH)
@@ -139,15 +158,14 @@
(CONCAT "Compare sources of " NAME
" as " TYPE)
TEXTWIDTH TEXTHEIGHT))
(WINDOWPROP CTWINDOW 'EXAMINEDEFS
(LIST NAME TYPE SOURCE1 SOURCE2 TITLE1
TITLE2)))])
(WINDOWPROP CTWINDOW 'EXAMINEDEFS KEY))])
(SHOULDNT)))
(PROGN (EDITE DEF1)
(EDITE DEF2])
(EXAMINEFILES
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 1-Feb-2022 23:15 by rmk")
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 19-Jul-2023 13:48 by rmk")
(* ; "Edited 1-Feb-2022 23:15 by rmk")
(* ; "Edited 25-Jan-2022 10:08 by rmk")
(* ; "Edited 2-Jan-2022 23:15 by rmk")
(* ; "Edited 30-Dec-2021 21:49 by rmk")
@@ -156,23 +174,26 @@
(CL:UNLESS REGION
(SETQ REGION (GETREGION)))
(LIST (AND FILE1 (TEDIT-SEE FILE1 (RELCREATEREGION `(,REGION 0.5 -1)
REGION
'RIGHT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE1))
(AND FILE2 (TEDIT-SEE FILE2 (RELCREATEREGION `(,REGION 0.5 1)
REGION
'LEFT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE2])
(LIST (AND (INFILEP FILE1)
(TEDIT-SEE FILE1 (RELCREATEREGION `(,REGION 0.5 -1)
REGION
'RIGHT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE1))
(AND (INFILEP FILE2)
(TEDIT-SEE FILE2 (RELCREATEREGION `(,REGION 0.5 1)
REGION
'LEFT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE2])
(TEDITDEF
[LAMBDA (NAME DEF TYPE READERENVIRONMENT WIDTH) (* ; "Edited 23-Jun-2022 17:27 by rmk")
[LAMBDA (NAME DEF TYPE READERENVIRONMENT WIDTH) (* ; "Edited 13-Oct-2023 00:23 by rmk")
(* ; "Edited 23-Jun-2022 17:27 by rmk")
(* ; "Edited 28-Jan-2022 23:36 by rmk")
(* ; "Edited 12-Jan-2022 17:27 by rmk")
(LET ((TSTREAM (OPENTEXTSTREAM)))
@@ -182,11 +203,14 @@
TSTREAM))
TSTREAM))
(SELECTQ (CAR DEF)
([LAMBDA NLAMBDA OPENLAMBDA]
(PRINTOUT TSTREAM .FONT BOLDFONT .P2 NAME T .FONT DEFAULTFONT 2)
(PRINTDEF DEF 2 T NIL NIL TSTREAM))
(DEFINEQ (SETQ DEF (CADR DEF))
(PRINTOUT TSTREAM .FONT BOLDFONT .P2 NAME T .FONT DEFAULTFONT 2)
(PRINTDEF (CADR DEF)
2 T NIL NIL TSTREAM))
((DEFMACRO DEFUN) (* ; "Has args after name")
((DEFMACRO DEFUN DEFMACRO CL:DEFUN) (* ; "Has args after name")
(PRINTOUT TSTREAM "(" .P2 (CAR DEF)
" " .FONT BOLDFONT .P2 (CADR DEF)
.FONT DEFAULTFONT " " .P2 (CADDR DEF)
@@ -216,6 +240,6 @@
(FILESLOAD (SYSLOAD)
COMPARETEXT)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (671 12815 (EXAMINEDEFS 681 . 9537) (EXAMINEFILES 9539 . 10934) (TEDITDEF 10936 . 12813)
))))
(FILEMAP (NIL (618 14102 (EXAMINEDEFS 628 . 10448) (EXAMINEFILES 10450 . 11932) (TEDITDEF 11934 .
14100)))))
STOP

BIN
lispusers/EXAMINEDEFS.LCOM
View File

Binary file not shown.

118
lispusers/comparetext
View File

@@ -1,13 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Jun-2022 22:50:45" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>COMPARETEXT.;124 48226
(FILECREATED "18-Oct-2023 17:45:46" {WMEDLEY}<lispusers>COMPARETEXT.;131 48661
:CHANGES-TO (FNS IMCOMPARE.LEFTBUTTONFN COMPARETEXT.TEXTOBJ COMPARETEXT IMCOMPARE.CHUNKS
IMCOMPARE.DISPLAYGRAPH COMPARETEXT.WINDOW)
:EDIT-BY rmk
:PREVIOUS-DATE "20-May-2022 16:35:56"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>COMPARETEXT.;118)
:CHANGES-TO (FNS IMCOMPARE.COLLECT.HASH.CHUNKS IMCOMPARE.HASH)
:PREVIOUS-DATE " 2-Nov-2022 10:08:52" {WMEDLEY}<lispusers>COMPARETEXT.;130)
(* ; "
@@ -17,7 +16,7 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(PRETTYCOMPRINT COMPARETEXTCOMS)
(RPAQQ COMPARETEXTCOMS
((FNS COMPARETEXT COMPARETEXT.WINDOW COMPARETEXT.TEXTOBJ COMPARETEXT.SETSEL CHUNKNODELABEL
((FNS COMPARETEXT COMPARETEXT.WINDOW COMPARETEXT.TSTREAM COMPARETEXT.SETSEL CHUNKNODELABEL
IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS IMCOMPARE.DISPLAYGRAPH
IMCOMPARE.HASH IMCOMPARE.MERGE.CONNECTED.CHUNKS IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
IMCOMPARE.SHOW.DIST IMCOMPARE.UPDATE.SYMBOL.TABLE)
@@ -119,23 +118,25 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(GETPROMPTWINDOW WINDOW)
WINDOW])
(COMPARETEXT.TEXTOBJ
[LAMBDA (NODE WINDOW INCOL1) (* ; "Edited 23-Jun-2022 17:20 by rmk")
(COMPARETEXT.TSTREAM
[LAMBDA (NODE WINDOW INCOL1) (* ; "Edited 2-Nov-2022 00:11 by rmk")
(* ; "Edited 23-Jun-2022 17:20 by rmk")
(* ; "Edited 18-Feb-2022 17:05 by rmk")
(* ; "Edited 30-Jan-2022 09:03 by rmk")
(* ; "Edited 28-Jan-2022 22:37 by rmk")
(* ;; "Returns the text object for the chunk column in the graphwindow WINDOW, on the left if INCOL1. If the windows are automatic, they are lined up under the middle of WINDOW.")
(* ;; "Returns the text stream for the chunk column in the graphwindow WINDOW, on the left if INCOL1. If the windows are automatic, they are lined up under the middle of WINDOW.")
(DECLARE (USEDFREE COMPARETEXT.AUTOTEDIT))
(LET (TEXTOBJ TSTREAM TWINDOW REGION REGIONARGS TEXTWIDTH TEXTHEIGHT (GRAPH (WINDOWPROP
WINDOW
'GRAPH))
(NODEID (FETCH (GRAPHNODE NODEID) OF NODE)))
(CL:UNLESS [AND [SETQ TEXTOBJ (WINDOWPROP WINDOW (CL:IF INCOL1
'COL1TEXTOBJ
'COL2TEXTOBJ)]
(OPENWP (WFROMDS (TEXTSTREAM TEXTOBJ]
(LET [TWINDOW REGION REGIONARGS TEXTWIDTH TEXTHEIGHT (GRAPH (WINDOWPROP WINDOW 'GRAPH))
(NODEID (FETCH (GRAPHNODE NODEID) OF NODE))
(TSTREAM (WINDOWPROP WINDOW (CL:IF INCOL1
'COL1TSTREAM
'COL2TSTREAM)]
(CL:UNLESS (AND TSTREAM (OPENWP (WFROMDS TSTREAM)))
(* ;; "First time, we have the graph but we don't yet have the TEDIT stream and window")
(SETQ TEXTWIDTH (OR (GRAPHERPROP GRAPH 'TEXTWIDTH)
700))
(SETQ TEXTHEIGHT (OR (GRAPHERPROP GRAPH 'TEXTHEIGHT)
@@ -152,39 +153,40 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(SETQ REGION (CL:IF COMPARETEXT.AUTOTEDIT
(RELCREATEREGION REGIONARGS)
(RELGETREGION REGIONARGS)))
(* ;; "If the CAR is a FIXP, this is a chunk node. Otherwise, it is one of the two file-name column headers.")
[SETQ TSTREAM (TEXTSTREAM (TEDIT (CL:IF (FIXP (CAR NODEID))
(FETCH (IMCOMPARE.CHUNK FILENAME) of NODEID)
NODEID)
REGION NIL `(READONLY T LEAVETTY T]
(SETQ TWINDOW (WFROMDS TSTREAM))
(SETQ TEXTOBJ (TEXTOBJ TSTREAM))
(WINDOWPROP WINDOW (CL:IF INCOL1
'COL1TEXTOBJ
'COL2TEXTOBJ)
TEXTOBJ)
'COL1TSTREAM
'COL2TSTREAM)
TSTREAM)
[WINDOWPROP TWINDOW 'TITLE (CL:IF INCOL1
(CADR (GRAPHERPROP GRAPH 'FILELABELS))
(CADDR (GRAPHERPROP GRAPH 'FILELABELS)))]
(MOVEWITH TWINDOW WINDOW)
(CLOSEWITH TWINDOW WINDOW))
TEXTOBJ])
TSTREAM])
(COMPARETEXT.SETSEL
[LAMBDA (TEXTOBJ NODE) (* ; "Edited 25-Dec-2021 10:52 by rmk")
(* ;; "25 so that we normalize with a little bit of context")
[LAMBDA (TSTREAM NODE) (* ; "Edited 2-Nov-2022 10:07 by rmk")
(* ; "Edited 25-Dec-2021 10:52 by rmk")
(LET* ((CHUNK (FETCH (GRAPHNODE NODEID) OF NODE))
(FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)))
(TEDIT.SETSEL TEXTOBJ (IMAX 1 (IDIFFERENCE FILEPTR 25))
(* ;; "The first selection just makes sure that at least 25 characters before the chunk will be on the screen. The second causes only the characters of the actual chunk to be underlined and shown. ")
(TEDIT.SETSEL TSTREAM (IMAX 1 (IDIFFERENCE FILEPTR 25))
0
'LEFT)
(TEDIT.NORMALIZECARET TEXTOBJ)
(TEDIT.SETSEL TEXTOBJ FILEPTR (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)
(TEDIT.NORMALIZECARET TSTREAM)
(TEDIT.SETSEL TSTREAM FILEPTR (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)
'LEFT)
(TEDIT.NORMALIZECARET TEXTOBJ)
(AND NIL (TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))
'PROCESS])
(TEDIT.NORMALIZECARET TSTREAM])
(CHUNKNODELABEL
[LAMBDA (CHUNK MIN.LENGTH EXTENDER) (* ; "Edited 25-Dec-2021 11:56 by rmk")
@@ -293,7 +295,8 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
TITLE TEXTWIDTH TEXTHEIGHT])
(IMCOMPARE.COLLECT.HASH.CHUNKS
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 20-Jan-2022 23:09 by rmk")
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 18-Oct-2023 17:45 by rmk")
(* ; "Edited 20-Jan-2022 23:09 by rmk")
(* ; "Edited 24-Dec-2021 22:30 by rmk")
(* ; "Edited 13-Dec-2021 16:32 by rmk")
(* ; "Edited 23-Dec-98 16:54 by rmk:")
@@ -305,7 +308,8 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(RESETLST
(BIND (FILENAME _ (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK))
STREAM ENDPOS FIRST [RESETSAVE (SETQ STREAM (OPENSTREAM FILENAME 'INPUT 'OLD))
STREAM ENDPOS FIRST [RESETSAVE [SETQ STREAM (OPENSTREAM FILENAME 'INPUT 'OLD
'((ENDOFSTREAMOP NILL]
'(PROGN (CLOSEF? OLDVALUE]
(CL:WHEN (\TEDIT.FORMATTEDP1 STREAM)
(* ;
@@ -457,9 +461,10 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
T NIL])
(IMCOMPARE.HASH
[LAMBDA (STREAM HASH.TYPE ENDPOS) (* ; "Edited 19-Dec-2021 09:07 by rmk")
(* ; "Edited 15-Dec-2021 15:58 by rmk")
(* ; "Edited 13-Dec-2021 16:35 by rmk")
[LAMBDA (STREAM HASH.TYPE ENDPOS) (* ; "Edited 18-Oct-2023 17:44 by rmk")
(* ; "Edited 19-Dec-2021 09:07 by rmk")
(* ; "Edited 15-Dec-2021 15:58 by rmk")
(* ; "Edited 13-Dec-2021 16:35 by rmk")
(* ; "Edited 23-Dec-98 16:58 by rmk:")
(* ;; "IMCOMPARE.HASH automatically stops before reading char number EOF.PTR.")
@@ -483,7 +488,8 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
 "Paragraph chunks end with two consecutive EOL's.")
(BIND EOLSEEN WHILE (IGREATERP NBYTES 0)
DO (SELCHARQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
(EOL (CL:WHEN EOLSEEN (RETURN))
((EOL NIL)
(CL:WHEN EOLSEEN (RETURN))
(SETQ EOLSEEN T) (* ; "Skip the NIL SETQ below")
(GO $$ITERATE))
((SPACE TAB))
@@ -635,6 +641,8 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(IMCOMPARE.LEFTBUTTONFN
[LAMBDA (NODE WINDOW)
(* ;; "Edited 1-Nov-2022 22:29 by rmk")
(* ;; "Edited 23-Jun-2022 22:50 by rmk: Turn off previous selection before turning on new one")
(* ;; "Edited 25-Dec-2021 23:29 by rmk")
@@ -647,14 +655,14 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(LET ([INCOL1 (EQ (GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
'COL1X)
(FETCH (POSITION XCOORD) OF (FETCH (GRAPHNODE NODEPOSITION) OF NODE]
TEXTOBJ)
TSTREAM)
(* ;; "Turn off any previous selection")
(CL:WHEN (SETQ TEXTOBJ (WINDOWPROP WINDOW 'COL1TEXTOBJ))
(TEDIT.SHOWSEL (TEXTSTREAM TEXTOBJ)))
(CL:WHEN (SETQ TEXTOBJ (WINDOWPROP WINDOW 'COL2TEXTOBJ))
(TEDIT.SHOWSEL (TEXTSTREAM TEXTOBJ)))
(CL:WHEN (SETQ TSTREAM (WINDOWPROP WINDOW 'COL1TSTREAM))
(TEDIT.SHOWSEL TSTREAM))
(CL:WHEN (SETQ TSTREAM (WINDOWPROP WINDOW 'COL2TSTREAM))
(TEDIT.SHOWSEL TSTREAM))
(IF (FIXP (CAR (fetch (GRAPHNODE NODEID) of NODE)))
THEN (IMCOMPARE.BOXNODE WINDOW NODE (FOR N (YPOS _ (FETCH YCOORD
OF (FETCH NODEPOSITION
@@ -669,17 +677,17 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(* ;;
 "We won't match the other label node because it has a unique ypos")
(COMPARETEXT.SETSEL (COMPARETEXT.TEXTOBJ
(COMPARETEXT.SETSEL (COMPARETEXT.TSTREAM
N WINDOW (NOT INCOL1)
)
N)
(RETURN N)))
(COMPARETEXT.SETSEL (COMPARETEXT.TEXTOBJ NODE WINDOW INCOL1)
(COMPARETEXT.SETSEL (COMPARETEXT.TSTREAM NODE WINDOW INCOL1)
NODE)
ELSE
(* ;; "The column header, set up the file window with no selection.")
(COMPARETEXT.TEXTOBJ NODE WINDOW INCOL1))))])
(COMPARETEXT.TSTREAM NODE WINDOW INCOL1))))])
(IMCOMPARE.MIDDLEBUTTONFN
[LAMBDA (NODE WINDOW) (* ; "Edited 27-Dec-2021 11:59 by rmk")
@@ -776,12 +784,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
)
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1473 40549 (COMPARETEXT 1483 . 3123) (COMPARETEXT.WINDOW 3125 . 6923) (
COMPARETEXT.TEXTOBJ 6925 . 10067) (COMPARETEXT.SETSEL 10069 . 10859) (CHUNKNODELABEL 10861 . 11982) (
IMCOMPARE.BOXNODE 11984 . 12960) (IMCOMPARE.CHUNKS 12962 . 17570) (IMCOMPARE.COLLECT.HASH.CHUNKS 17572
. 20489) (IMCOMPARE.DISPLAYGRAPH 20491 . 28570) (IMCOMPARE.HASH 28572 . 32759) (
IMCOMPARE.MERGE.CONNECTED.CHUNKS 32761 . 36257) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 36259 . 38214) (
IMCOMPARE.SHOW.DIST 38216 . 38662) (IMCOMPARE.UPDATE.SYMBOL.TABLE 38664 . 40547)) (40550 47004 (
IMCOMPARE.LEFTBUTTONFN 40560 . 43434) (IMCOMPARE.MIDDLEBUTTONFN 43436 . 46552) (IMCOMPARE.COPYBUTTONFN
46554 . 47002)) (47057 47748 (TAIL1 47067 . 47421) (TAIL2 47423 . 47746)))))
(FILEMAP (NIL (1318 40954 (COMPARETEXT 1328 . 2968) (COMPARETEXT.WINDOW 2970 . 6768) (
COMPARETEXT.TSTREAM 6770 . 9991) (COMPARETEXT.SETSEL 9993 . 10898) (CHUNKNODELABEL 10900 . 12021) (
IMCOMPARE.BOXNODE 12023 . 12999) (IMCOMPARE.CHUNKS 13001 . 17609) (IMCOMPARE.COLLECT.HASH.CHUNKS 17611
. 20723) (IMCOMPARE.DISPLAYGRAPH 20725 . 28804) (IMCOMPARE.HASH 28806 . 33164) (
IMCOMPARE.MERGE.CONNECTED.CHUNKS 33166 . 36662) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 36664 . 38619) (
IMCOMPARE.SHOW.DIST 38621 . 39067) (IMCOMPARE.UPDATE.SYMBOL.TABLE 39069 . 40952)) (40955 47439 (
IMCOMPARE.LEFTBUTTONFN 40965 . 43869) (IMCOMPARE.MIDDLEBUTTONFN 43871 . 46987) (IMCOMPARE.COPYBUTTONFN
46989 . 47437)) (47492 48183 (TAIL1 47502 . 47856) (TAIL2 47858 . 48181)))))
STOP