github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-26 20:31:53 +00:00
Code Issues Projects Releases Wiki Activity

Rmk19: Updates and remaining components for managing comparisons and interactions between git and Medley (#658)

Browse Source 
* PSEUDOHOSTS: Overlay a file system at the end of a path in another file system

New package, please look through it.

* REGIONMANAGER:  added RELCREATEPOSITION, allow for arguments to be spread

If the WIDTH argument looks like a list of arguments, the arguments are spread out.  Means that a relative region can be passed through intermediate functions.

* EXAMINEDEFS:  More control over regions and windows

Examination windows are returned so that callers can manipulate them

* TEDIT-PF-SEE:  tf respects reader environment and bold faces of DEFUN and DEFMACRO names

* COMPAREDIRECTORIES:  refactored for more flexibility and easier maintenance

Also, based on SPY, made more internal operations work on streams that are located and created once, rather than on file

Added CDMERGE to merge CDVALUES for different subdirectories, to permit scrolling of all differences in a single browser window

* COMPARESOURCES:  Region for CS browser is passed through, window is returned

Also tried to eliminate mismatching of simple edit timestamps

* COMPARETEXT: Files can be input streams, region is passed in, window is returned

* COMPAREDIRECTORIES again:  Fixed a promptwindow bug

* GITFNS:  New package for comparing and copying back and forth from My Medley to the git clone
This commit is contained in:
rmkaplan
2022-01-27 22:32:49 -08:00
committed by GitHub
parent ab8e97ff7b
commit b791bff070
22 changed files with 2509 additions and 589 deletions
Download Patch File Download Diff File Expand all files Collapse all files

722
lispusers/COMPAREDIRECTORIES
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-Dec-2021 18:22:13" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;116 100755
(FILECREATED "27-Jan-2022 17:47:36" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;160 112621
:CHANGES-TO (FNS CD-MENUFN)
:CHANGES-TO (FNS CD.COMMANDSELECTEDFN)
:PREVIOUS-DATE "25-Dec-2021 12:59:47"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;114)
:PREVIOUS-DATE "26-Jan-2022 15:33:55"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;159)
(* ; "
@@ -19,11 +19,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(
(* ;; "Compare the contents of two directories.")
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME
CD.INSURECDVALUE CD.UPDATEWIDTHS)
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS CDENTRIES.SELECT
COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME CD.INSURECDVALUE CD.UPDATEWIDTHS)
(FNS CDFILES CDFILES.MATCH CDFILES.PATS)
(FNS CDPRINT CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS CDTEDIT)
(FNS CDMAP CDENTRY CDSUBSET)
(FNS CDPRINT CDPRINT.HEADER CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS
CDTEDIT)
(FNS CDMAP CDENTRY CDSUBSET CDMERGE CDMERGE.COMMON)
(FNS BINCOMP EOLTYPE EOLTYPE.SHOW)
(RECORDS CDVALUE CDENTRY CDINFO CDMAXNCHARS)
@@ -63,13 +64,10 @@ 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 23-Dec-2021 18:59 by rmk")
(* ; "Edited 19-Dec-2021 20:07 by rmk")
(* ; "Edited 30-Nov-2021 13:51 by rmk:")
(* ; "Edited 23-Nov-2021 12:57 by rmk:")
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
(* ; "Edited 7-Jan-2021 23:21 by rmk:")
FIXDIRECTORYDATES) (* ; "Edited 26-Jan-2022 13:33 by rmk")
(* ; "Edited 4-Jan-2022 12:09 by rmk")
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
(* ; "Edited 7-Jan-2021 23:21 by rmk:")
(* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.")
@@ -96,8 +94,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 COMPAREDATE DEPTH1 DEPTH2 CDVALUE)
[SETQ COMPAREDATE (INTERSECTION SELECT '(< > =]
(PROG (INFOS1 INFOS2 CANDIDATES CDENTRIES DEPTH1 DEPTH2 CDVALUE (DATE (DATE)))
(* ;; "DIRECTORYNAME here to get unrelativized specifications for header.")
@@ -117,8 +114,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(PRINTOUT T "Fixing directory dates" T)
(FIX-DIRECTORY-DATES DIR1)
(FIX-DIRECTORY-DATES DIR2))
(PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE)
" selecting " SELECT " ... ")
(CDPRINT.HEADER DIR1 DIR2 SELECT DATE T)
(PRINTOUT T " ... ")
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 INCLUDEDFILES EXCLUDEDFILES
ALLVERSIONS DEPTH1)
USEDIRECTORYDATE DIR1))
@@ -128,7 +125,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(SETQ CDVALUE (CREATE CDVALUE
CDDIR1 _ DIR1
CDDIR2 _ DIR2
CDCOMPAREDATE _ (DATE)
CDCOMPAREDATE _ DATE
CDSELECT _ SELECT))
(CL:UNLESS (OR INFOS2 INFOS1)
(RETURN CDVALUE))
@@ -166,58 +163,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(* ;; "Do the SELECT filtering and insert the date relation.")
[SETQ CDENTRIES
(for C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP in CANDIDATES
eachtime (SETQ MATCHNAME (pop C))
(SETQ INFO1 (pop C))
(SETQ INFO2 (pop C))
(if (AND INFO1 INFO2)
then (SETQ IDATE1 (IDATE (fetch DATE of INFO1)))
(SETQ IDATE2 (IDATE (fetch DATE of INFO2)))
(SETQ DATEREL (if (IGREATERP IDATE1 IDATE2)
then '>
elseif (ILESSP IDATE1 IDATE2)
then '<
else '=))
else
(* ;; "Just for printing--no comparison")
(SETQ DATEREL '*))
when (if (AND INFO1 INFO2)
then (CL:WHEN (OR (NULL COMPAREDATE)
(SELECTQ DATEREL
(> (MEMB '> SELECT))
(< (MEMB '< SELECT))
(= (MEMB '= SELECT))
(SHOULDNT)))
(SETQ BINCOMP (BINCOMP (fetch (CDINFO FULLNAME) OF INFO1)
(fetch (CDINFO FULLNAME) OF INFO2)
T
(fetch (CDINFO EOL) OF INFO1)
(fetch (CDINFO EOL) OF INFO2)))
(* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.")
[NOT (AND (MEMB '~= SELECT)
BINCOMP
(EQ (fetch (CDINFO EOL) OF INFO1)
(fetch (CDINFO EOL) OF INFO2])
elseif INFO1
then
(* ;; "OK if INFO2 is missing?")
(MEMB '*- SELECT)
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]
(SETQ CDENTRIES (CDENTRIES.SELECT CANDIDATES SELECT))
(PRINTOUT T (LENGTH CDENTRIES)
" entries" T)
(REPLACE CDENTRIES OF CDVALUE WITH CDENTRIES)
@@ -227,37 +173,118 @@ 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 23-Dec-2021 18:59 by rmk")
[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:")
(* ;; "Value is a list of CDINFOS with the match-name consed on to the front")
(FOR FULLNAME TYPE LDATE (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
(FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
COLLECT
(* ;; "GDATE/IDATE in case Y2K")
(SETQ LDATE (OR (FILEDATE FULLNAME T)
(FILEDATE FULLNAME))) (* ;
(* ;
 "Is it a Lisp file? Get it's internal filecreated date. ")
(CONS (MATCHNAME FULLNAME STARTPOS)
(CREATE CDINFO
FULLNAME _ FULLNAME
DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE
THEN (GETFILEINFO FULLNAME 'CREATIONDATE)
ELSEIF (OR LDATE (GETFILEINFO FULLNAME
'CREATIONDATE]
LENGTH _ (GETFILEINFO FULLNAME 'LENGTH)
AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR)
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE FULLNAME LDATE)
EOL _ (EOLTYPE FULLNAME])
(SETQ STREAM (OPENSTREAM FULLNAME 'INPUT)) (* ;
 "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)
(CREATE CDINFO
FULLNAME _ FULLNAME
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
THEN (GETFILEINFO STREAM 'CREATIONDATE)
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
LDATE)))
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
AUTHOR _ (GETFILEINFO STREAM 'AUTHOR)
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE STREAM LDATE)
EOL _ (EOLTYPE STREAM)))
(CLOSEF? STREAM])
(CDENTRIES.SELECT
[LAMBDA (CANDIDATES SELECT) (* ; "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))
(if (AND INFO1 INFO2)
then (SETQ IDATE1 (IDATE (fetch DATE of INFO1)))
(SETQ IDATE2 (IDATE (fetch DATE of INFO2)))
(SETQ DATEREL (if (IGREATERP IDATE1 IDATE2)
then '>
elseif (ILESSP IDATE1 IDATE2)
then '<
else '=))
else
(* ;; "Just for printing--no comparison")
(SETQ DATEREL '*))
when (if (AND INFO1 INFO2)
then (CL:WHEN (OR (NULL COMPAREDATE)
(SELECTQ DATEREL
(> (MEMB '> COMPAREDATE))
(< (MEMB '< COMPAREDATE))
(= (MEMB '= COMPAREDATE))
(SHOULDNT)))
(SETQ BINCOMP (BINCOMP (fetch (CDINFO FULLNAME) OF INFO1)
(fetch (CDINFO FULLNAME) OF INFO2)
T
(fetch (CDINFO EOL) OF INFO1)
(fetch (CDINFO EOL) OF INFO2)))
(CL:WHEN (EQ T BINCOMP)
(* ;; "Byte-equivalent files with different dates. Presumably the earlier date is more accurate, move back the date of the later file and make DATEREL be =. Perhaps we should do this even if there is only an EOL difference (BINCOMP non-NIL).;; Byte-equivalent files with different dates. Presumably the earlier date is more accurate, move back the date of the earlier file and make DATEREL be =. Perhaps we should do this even if there is only an EOL difference (BINCOMP non-NIL). ")
(* ;; "We do this even if FIXDIRECTORYDATES is false, that addresses a property of individual Lisp source files.")
(SELECTQ DATEREL
(> (SETFILEINFO (FETCH (CDINFO FULLNAME) OF INFO1)
'CREATIONDATE
(REPLACE (CDINFO DATE) OF INFO1 WITH (FETCH (CDINFO DATE)
OF INFO2))))
(< (SETFILEINFO (FETCH (CDINFO FULLNAME) OF INFO2)
'CREATIONDATE
(REPLACE (CDINFO DATE) OF INFO2 WITH (FETCH (CDINFO DATE)
OF INFO1))))
NIL)
(SETQ DATEREL '=))
(* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.")
[NOT (AND (MEMB '~= SELECT)
BINCOMP
(EQ (fetch (CDINFO EOL) OF INFO1)
(fetch (CDINFO EOL) OF INFO2])
elseif INFO1
then
(* ;; "OK if INFO2 is missing?")
(MEMB '*- SELECT)
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])
(COMPAREDIRECTORIES.INFOS.TYPE
[LAMBDA (FULLNAME LDATE) (* ; "Edited 12-Dec-2021 22:50 by rmk")
(IF (OR LDATE (FILEDATE FULLNAME T)
(FILEDATE FULLNAME))
[LAMBDA (FULLNAME LDATE) (* ; "Edited 4-Jan-2022 13:10 by rmk")
(* ; "Edited 12-Dec-2021 22:50 by rmk")
(IF LDATE
THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION)
*COMPILED-EXTENSIONS*)
'COMPILED
@@ -318,9 +345,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(DEFINEQ
(CDFILES
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 23-Dec-2021 22:49 by rmk")
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "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")
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
(* ;; "Returns a list of fullnames for files that satisfy the criteria. We generate all candidates that match INCLUDEDFILES but not EXCLUDEDFILES in DIR.")
@@ -338,7 +368,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(* ;; "EXCLUDEDFILES is a filepattern with * meaning everything, COM means *.LCOM and *.DFASL")
[SETQ EXCLUDEDFILES `(.DS_Store
[SETQ EXCLUDEDFILES `(*>.DS_Store
,@(MKLIST EXCLUDEDFILES]
(CL:UNLESS (EQMEMB '.* INCLUDEDFILES) (* ;
 "Excluded dot files unless specifically asked for")
@@ -372,9 +402,14 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CL:UNLESS (OR (EQ SD '*)
(EQ SD (CAR P)))
(SETQ SD NIL)) FINALLY (CL:WHEN (EQ SD '*)
(SETQ SD ""))
(SETQ SD ""))
(* ;;
 "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 "<" TOPDIR ">"
(OR SD ""))
'NAME N 'EXTENSION E 'VERSION
(CL:IF ALLVERSIONS
'*
@@ -387,48 +422,52 @@ 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)))
IN (DIRECTORY ENUMPAT) EACHTIME (CL:WHEN (DIRECTORYNAMEP FULLNAME)
(* ; "Skip directories")
(GO $$ITERATE))
(SETQ UNPACK (UNPACKFILENAME FULLNAME))
(SETQ NAME (LISTGET UNPACK 'NAME))
(SETQ EXT (LISTGET UNPACK 'EXTENSION))
(SETQ SUBDIR (SUBATOM (LISTGET UNPACK 'DIRECTORY)
STARTPOS))
(CL:UNLESS NAME
(CL:WHEN EXT (* ; ".XY")
(SETQ NAME (PACK* "." EXT))
(SETQ EXT NIL)))
(SETQ THISDEPTH (FOR I (CNT _ 1) FROM 1
DO (SELCHARQ (NTHCHARCODE SUBDIR I)
((> /)
(ADD CNT 1))
(NIL (RETURN CNT))
NIL)))
IN (DIRECTORY ENUMPAT NIL NIL (CL:IF ALLVERSIONS
"*"
""))
EACHTIME (SETQ UNPACK (UNPACKFILENAME FULLNAME))
(SETQ NAME (LISTGET UNPACK 'NAME))
(SETQ EXT (LISTGET UNPACK 'EXTENSION))
(CL:UNLESS NAME
(CL:WHEN EXT (* ; ".XY")
(SETQ NAME (PACK* "." EXT))
(SETQ EXT NIL)))
(CL:UNLESS (OR NAME EXT) (* ; "Must have been a directory")
(GO $$ITERATE))
(SETQ SUBDIR (SUBATOM (LISTGET UNPACK 'DIRECTORY)
STARTPOS))
(SETQ THISDEPTH (FOR I (CNT _ 1) FROM 1 DO (SELCHARQ (NTHCHARCODE SUBDIR I)
((> /)
(ADD CNT 1))
(NIL (RETURN CNT))
NIL)))
WHEN (OR (NULL INCLUDES)
(CDFILES.MATCH SUBDIR NAME EXT THISDEPTH INCLUDES))
UNLESS (CDFILES.MATCH SUBDIR NAME EXT THISDEPTH EXCLUDES) COLLECT FULLNAME])
(CDFILES.MATCH
[LAMBDA (SUBDIR NAME EXT THISDEPTH PATTERNS) (* ; "Edited 23-Dec-2021 21:47 by rmk")
[LAMBDA (SUBDIR NAME EXT THISDEPTH PATTERNS) (* ; "Edited 26-Jan-2022 15:33 by rmk")
(* ; "Edited 23-Dec-2021 21:47 by rmk")
(* ;; "True if the components of the fullname match at least one of the patterns")
(THEREIS P IN PATTERNS SUCHTHAT (AND [OR (STRING.EQUAL NAME (CAR P))
(THEREIS P IN PATTERNS SUCHTHAT (AND [OR (STRING.EQUAL NAME (CAR P)
FILEDIRCASEARRAY)
(EQ '* (CAR P))
(AND (EQ (CHARCODE %.)
(CHCON1 (CAR P)))
(EQ (EQ (CHARCODE %.)
(CHCON1 NAME)))
(EQ (CHARCODE %.)
(CHCON1 NAME))
(OR (STRING.EQUAL NAME (SUBATOM (CAR P)
2))
(EQ (CHARCODE *1)
(EQ (CHARCODE *)
(NTHCHARCODE (CAR P)
2]
(OR (STRING.EQUAL EXT (CADR P))
(EQ '* (CADR P)))
(OR (STRING.EQUAL SUBDIR (CADDR P))
(NULL (CADDR P)))
(NULL (CADDR P))
(EQ '* (CADDR P)))
(ILEQ THISDEPTH (CADDDR P])
(CDFILES.PATS
@@ -479,9 +518,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(DEFINEQ
(CDPRINT
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "Edited 19-Dec-2021 20:10 by rmk")
(* ; "Edited 30-Nov-2021 20:59 by rmk:")
(* ; "Edited 13-Oct-2020 08:38 by rmk:")
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "Edited 26-Jan-2022 13:43 by rmk")
(* ; "Edited 19-Dec-2021 20:10 by rmk")
(* ; "Edited 30-Nov-2021 20:59 by rmk:")
(* ; "Edited 13-Oct-2020 08:38 by rmk:")
(* ;; "Typically CDVALUE will have a provdenance header. If not, we fake one up, at least for the directories and today's date.")
@@ -502,11 +542,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
'(PROGN (CLOSEF? OLDVALUE])
(LINELENGTH 1000 STREAM) (* ; "Don't wrap")
(CL:WHEN (FETCH (CDVALUE CDDIR1) OF CDVALUE)
(PRINTOUT STREAM "Comparing " (FETCH (CDVALUE CDDIR1) OF CDVALUE)
6 "vs. " (FETCH (CDVALUE CDDIR2) OF CDVALUE)
T "as of " (FETCH (CDVALUE CDCOMPAREDATE) OF CDVALUE))
(CL:WHEN (FETCH (CDVALUE CDSELECT) OF CDVALUE)
(PRINTOUT STREAM " selecting " (FETCH (CDVALUE CDSELECT) OF CDVALUE)))
(CDPRINT.HEADER CDVALUE STREAM)
(PRINTOUT STREAM -2 (LENGTH (fetch CDENTRIES of CDVALUE))
" entries" T T))
(if (fetch CDENTRIES of CDVALUE)
@@ -517,6 +553,27 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
else (PRINTOUT T "CDVALUE is empty" T))
(AND STREAM (CLOSEF? STREAM))))])
(CDPRINT.HEADER
[LAMBDA (DIR1 DIR2 SELECT DATE STREAM) (* ; "Edited 26-Jan-2022 13:36 by rmk")
(CL:WHEN (LISTP DIR1)
(* ;; "A CDVALUE")
(CL:UNLESS STREAM (SETQ STREAM DIR2))
(SETQ DIR2 (FETCH CDDIR2 OF DIR1))
(SETQ SELECT (FETCH CDSELECT OF DIR1))
(SETQ DATE (FETCH CDCOMPAREDATE OF DIR1))
(SETQ DIR1 (FETCH CDDIR1 OF DIR1)))
(CL:WHEN DIR1
(PRINTOUT STREAM "Comparing ")
(PRINTOUT STREAM DIR1 %# (CL:WHEN (IGREATERP (IPLUS (NCHARS DIR1)
(NCHARS DIR2))
70)
(TAB 5))
" vs. " DIR2)
(PRINTOUT STREAM T 3 "as of " DATE)
(CL:WHEN SELECT (PRINTOUT STREAM " selecting " SELECT)))])
(CDPRINT.LINE
[LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2)
(* ; "Edited 22-Nov-2021 22:38 by rmk:")
@@ -752,6 +809,89 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(SETQ INFO2 (FETCH INFO2 OF CDE))
(SETQ EQUIV (FETCH EQUIV OF CDE))
WHEN (APPLY* FN CDE) COLLECT CDE])
(CDMERGE
[LAMBDA (CDVALUES) (* ; "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.")
(IF (CDR CDVALUES)
THEN
[LET
(CDSELECTS)
(* ;; "Group by selects")
(FOR CDV TMP IN CDVALUES
DO (PUSH [CDR (OR (SASSOC (FETCH CDSELECT OF CDV)
CDSELECTS)
(CAR (PUSH CDSELECTS (CONS (FETCH CDSELECT OF CDV]
CDV))
(* ;; "For each group, find the longest common directory prefixes")
(FOR CDS IDATE DIR1 DIR2 MERGEDENTRIES IN CDSELECTS
COLLECT (SETQ DIR1 (FETCH CDDIR1 OF (CADR CDS)))
(SETQ DIR2 (FETCH CDDIR2 OF (CADR CDS)))
[SETQ IDATE (IDATE (FETCH CDCOMPAREDATE OF (CADR CDS]
(* ;; "Calculate the common directory prefixes and latest date")
[FOR CDV IN (CDDR CDS) DO (SETQ DIR1 (CDMERGE.COMMON DIR1 (FETCH CDDIR1
OF CDV)))
(SETQ DIR2 (CDMERGE.COMMON DIR2 (FETCH CDDIR2
OF CDV)))
(CL:WHEN (IGREATERP IDATE (IDATE (FETCH CDCOMPAREDATE
OF CDV)))
(SETQ IDATE (IDATE (FETCH CDCOMPAREDATE OF CDV))))]
(* ;;
 "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)
JOIN (FOR CDE IN (FETCH CDENTRIES OF CDV)
COLLECT (CREATE CDENTRY
USING CDE MATCHNAME _
(IF (FETCH INFO1 OF CDE)
THEN (MATCHNAME (FETCH (CDINFO FULLNAME)
OF (FETCH INFO1
OF CDE))
NC1)
ELSE (MATCHNAME (FETCH (CDINFO FULLNAME)
OF (FETCH INFO2
OF CDE))
NC2]
T))
(CD.UPDATEWIDTHS (CREATE CDVALUE
CDDIR1 _ DIR1
CDDIR2 _ DIR2
CDCOMPAREDATE _ (GDATE IDATE)
CDSELECT _ (CAR CDS)
CDENTRIES _ MERGEDENTRIES]
ELSE CDVALUES])
(CDMERGE.COMMON
[LAMBDA (DIRX DIRY) (* ; "Edited 24-Jan-2022 16:40 by rmk")
(* ;;
 "Returns the longest common prefix of DIRX and DIRY, collapsing brackets, slashes, and case")
(FOR I CX CY (LASTDIRPOS _ 1) FROM 1 EACHTIME (SETQ CX (NTHCHARCODE DIRX I))
(SETQ CY (NTHCHARCODE DIRY I))
(CL:WHEN (MEMB CX (CHARCODE (< > /)))
(SETQ CX (CHARCODE /)))
(CL:WHEN (MEMB CY (CHARCODE (< > /)))
(SETQ CY (CHARCODE /)))
(CL:WHEN (AND (EQ CX (CHARCODE /))
(EQ CY (CHARCODE /)))
(SETQ LASTDIRPOS I))
UNLESS [AND CX CY (OR (EQ CX CY)
(EQ (L-CASECODE CX)
(L-CASECODE CY] DO (RETURN (CL:IF (EQ I 1)
""
(SUBSTRING DIRX 1 LASTDIRPOS))])
)
(DEFINEQ
@@ -827,40 +967,51 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
FINALLY (RETURN (OR EOLDIFF T]))])
(EOLTYPE
[LAMBDA (FILE SHOWCONTEXT) (* ; "Edited 21-Feb-2021 20:34 by rmk:")
[LAMBDA (FILE SHOWCONTEXT)
(* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")
(* ;; "Edited 4-Jan-2022 15:10 by rmk: Allow FILE to be an already open stream")
(* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.")
(* ;; "Edited 21-Feb-2021 20:34 by rmk:")
(* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")
(* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.")
(SELECTQ SHOWCONTEXT
(NIL)
(T (SETQ SHOWCONTEXT 100))
(CL:UNLESS (FIXP SHOWCONTEXT)
(ERROR "SHOWCONTEXT must be an integer" SHOWCONTEXT)))
(CL:WITH-OPEN-FILE
(STREAM FILE :DIRECTION :INPUT)
(SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
(BIND EOLTYPE
DO (SELCHARQ (OR (\BIN STREAM)
(RETURN EOLTYPE))
(CR (IF (EQ (CHARCODE LF)
(RESETLST
(LET (STREAM)
[IF (GETSTREAM FILE 'INPUT T)
THEN (SETQ STREAM FILE)
[RESETSAVE NIL `(PROGN (SETFILEPTR ,STREAM ,(GETFILEPTR STREAM))
(STREAMPROP ,STREAM 'ENDOFSTREAMOP
',(STREAMPROP STREAM 'ENDOFSTREAMOP]
(SETFILEPTR STREAM 0)
ELSE (RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTREAM FILE 'INPUT]
(SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
(BIND EOLTYPE
DO (SELCHARQ (OR (\BIN STREAM)
(RETURN EOLTYPE))
(CR (IF (EQ (CHARCODE LF)
(\PEEKBIN STREAM T))
THEN (\BIN STREAM)
(IF (MEMB EOLTYPE '(LF CR))
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE
'LF STREAM)
(RETURN NIL))
ELSE (SETQ EOLTYPE 'CRLF))
ELSEIF (MEMB EOLTYPE '(LF CRLF))
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM)
THEN (\BIN STREAM)
(IF (MEMB EOLTYPE '(LF CR))
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE
'LF STREAM)
(RETURN NIL))
ELSE (SETQ EOLTYPE 'CRLF))
ELSEIF (MEMB EOLTYPE '(LF CRLF))
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM)
(RETURN NIL))
ELSE (SETQ EOLTYPE 'CR)))
(LF (IF (MEMB EOLTYPE '(CR CRLF))
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM)
ELSE (SETQ EOLTYPE 'CR)))
(LF (IF (MEMB EOLTYPE '(CR CRLF))
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM)
(RETURN NIL))
ELSE (SETQ EOLTYPE 'LF)))
NIL])
ELSE (SETQ EOLTYPE 'LF)))
NIL))))])
(EOLTYPE.SHOW
[LAMBDA (SHOWCONTEXT OLDTYPE NEWTYPE STREAM) (* ; "Edited 21-Feb-2021 20:20 by rmk:")
@@ -1435,18 +1586,16 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
(CDBROWSER
[LAMBDA (CDVALUE TITLE COLHEADINGS BROWSERPROPS SEPARATEDIRECTIONS MENUITEMS)
(* ; "Edited 25-Dec-2021 12:50 by rmk")
(* ; "Edited 16-Dec-2021 11:51 by rmk")
(* ; "Edited 14-Dec-2021 21:41 by rmk")
(* ; "Edited 10-Dec-2021 21:38 by rmk")
(* ; "Edited 30-Nov-2021 15:03 by rmk:")
(* ; "Edited 29-Nov-2021 14:18 by rmk:")
(* ;; "Edited 25-Jan-2022 13:05 by rmk: a table browser for the differences in CDVALUE.")
(* ;; "Creates a table browser for the differences in CDVALUE.")
(SETQ MENUITEMS (IF MENUITEMS
THEN (FOR I IN MENUITEMS COLLECT (OR (LISTP I)
(SASSOC I CDTABLEBROWSER.MENUITEMS)
(AND (STREQUAL I "")
"")
(ERROR "UNKNOWN CDBROWSER MENU ITEM" I))
)
ELSE CDTABLEBROWSER.MENUITEMS))
@@ -1466,8 +1615,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
DEFAULTFONT]
[SETQ REGION (GETREGION (PLUS TB.LEFT.MARGIN ITEMWIDTH (TIMES 2 WBorder)
MENUWIDTH)
(TIMES [IMIN 15 (IMAX (IPLUS 4 (LENGTH STRINGS))
(ADD1 (LENGTH MENUITEMS]
(TIMES (IMAX (IMIN 15 (LENGTH STRINGS))
(ADD1 (LENGTH MENUITEMS)))
(FONTPROP DEFAULTFONT 'HEIGHT]
(* ;; "Promptwindow seems to do its own thing, even if under construction. So we preshrink the main window.")
@@ -1476,8 +1625,13 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
OF REGION)
(FONTPROP DEFAULTFONT
'HEIGHT]
(SETQ WINDOW (CREATEW REGION (OR TITLE "Compare directories")
(SETQ WINDOW (CREATEW REGION (OR TITLE (CONCAT "Compare directories " (LENGTH
STRINGS)
" files"))
NIL T))
[WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W)
(FOR W INSIDE (WINDOWPROP W 'SUBWINDOWS)
DO (CLOSEW (WFROMDS W]
(WINDOWPROP WINDOW 'UNDERCONSTRUCTION T)
(* ;; "TABLEBROWSER is odd: USERDATA is a single recognized property. But it allows for other unrecognized properties in the list, it pushes them on to a list USERPROPS...and then throws it away. So here I'm using USERDATA to hold the directory lengths so they can be stripped off for display. It may actually be better to have a field name in CDVALUE for all of the shared stuff in front of the entries, and keep it all.")
@@ -1610,105 +1764,153 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
'DON'T])
(CD.COMMANDSELECTEDFN
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 25-Dec-2021 11:20 by rmk")
(* ; "Edited 16-Dec-2021 13:45 by rmk")
(* ; "Edited 13-Dec-2021 17:13 by rmk")
(* ; "Edited 9-Dec-2021 21:36 by rmk")
(* ; "Edited 8-Dec-2021 11:27 by rmk")
(* ; "Edited 5-Dec-2021 13:28 by rmk")
(* ; "Edited 3-Dec-2021 00:21 by rmk:")
(* ; "Edited 29-Nov-2021 23:08 by rmk:")
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 27-Jan-2022 17:46 by rmk")
(* ; "Edited 10-Jan-2022 22:51 by rmk")
(* ; "Edited 25-Dec-2021 11:20 by rmk")
(* ; "Edited 12-Jan-87 12:57 by bvm:")
(* ;; "Cobbled from FB.COMMANDSELECTEDFN. But here we assume that the menu item is of the form (display-string FN . EXTRAS), we peel out the FN to apply, leave the rest alone.")
(DECLARE (SPECVARS MENUITEM MENU KEY))
(RESETLST
[LET* [(WINDOW (WINDOWPROP (WFROMMENU MENU)
'MAINWINDOW))
(PROMPTWINDOW (GETPROMPTWINDOW WINDOW))
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
(USERDATA (TB.USERDATA CDBROWSER))
(CDVALUE (LISTGET USERDATA 'CDVALUE))
(FN (CADR (LISTP MENUITEM]
(DECLARE (SPECVARS WINDOW PROMPTWINDOW CDVALUE USERDATA))
(GIVE.TTY.PROCESS PROMPTWINDOW)
(TTYDISPLAYSTREAM PROMPTWINDOW) (* ; "Pwindow")
(IF (EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
THEN (FLASHWINDOW PROMPTWINDOW)
(PRIN3 "Please make a selection" T)
ELSE (TB.MAP.SELECTED.ITEMS CDBROWSER
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
(FILE1 (FETCH (CDINFO FULLNAME)
(FETCH (CDENTRY INFO1) OF CDENTRY)))
(FILE2 (FETCH (CDINFO FULLNAME)
(FETCH (CDENTRY INFO2) OF CDENTRY)))
(TYPE (FETCH (CDINFO TYPE) OF (FETCH (CDENTRY INFO1)
OF CDENTRY)))
(LABELS (APPLY* (OR (LISTGET USERDATA 'LABELFN)
(FUNCTION NILL))
FILE1 FILE2 USERDATA))
(LABEL1 (OR (CAR LABELS)
FILE1))
(LABEL2 (OR (CADR LABELS)
FILE2)))
(DECLARE (SPECVARS . T))
(CL:UNLESS (STREQUAL MENUITEM "") (* ; "For blank lines")
(RESETLST
[LET* [(WINDOW (WINDOWPROP (WFROMMENU MENU)
'MAINWINDOW))
(PWINDOW (GETPROMPTWINDOW WINDOW))
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
(USERDATA (TB.USERDATA CDBROWSER))
(CDVALUE (LISTGET USERDATA 'CDVALUE))
(FN (CADR (LISTP MENUITEM]
(DECLARE (SPECVARS WINDOW PWINDOW CDVALUE USERDATA))
(GIVE.TTY.PROCESS PWINDOW)
(TTYDISPLAYSTREAM PWINDOW) (* ; "Pwindow")
(COND
((EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
(FLASHWINDOW PWINDOW)
(PRIN3 "Please make a selection" T))
(T (TB.MAP.SELECTED.ITEMS
CDBROWSER
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
(FILE1 (FETCH (CDINFO FULLNAME)
(FETCH (CDENTRY INFO1) OF CDENTRY)))
(FILE2 (FETCH (CDINFO FULLNAME)
(FETCH (CDENTRY INFO2) OF CDENTRY)))
(TYPE (FETCH (CDINFO TYPE) OF (FETCH (CDENTRY INFO1)
OF CDENTRY)))
(LABELS (APPLY* (OR (LISTGET USERDATA 'LABELFN)
(FUNCTION NILL))
FILE1 FILE2 USERDATA))
(LABEL1 (OR (CAR LABELS)
FILE1))
(LABEL2 (OR (CADR LABELS)
FILE2)))
(DECLARE (SPECVARS . T))
(* ;; "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])])
(CLEARW T)
(CL:FUNCALL FN TBITEM MENUITEM CDBROWSER KEY]
(FUNCTION NILL]))])
(CD-MENUFN
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 30-Dec-2021 18:21 by rmk")
(* ; "Edited 20-Dec-2021 09:56 by rmk")
(* ; "Edited 16-Dec-2021 13:30 by rmk")
(* ; "Edited 13-Dec-2021 22:11 by rmk")
(* ; "Edited 10-Dec-2021 21:42 by rmk")
(* ; "Edited 9-Dec-2021 21:24 by rmk")
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY)
(* ;; "Edited 25-Jan-2022 10:19 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.")
(* ;; "MENUITEM is of the form (display-atom <this function> . extrainfo). The selector for the selectq is either the CAR of the extrainfo or the display atom.")
(SELECTQ (OR (CADDR MENUITEM)
(CAR MENUITEM))
(Compare (IF (AND FILE1 FILE2)
THEN (SELECTQ TYPE
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2))
(COMPILED (PRIN3 "Cannot compare compiled files" T))
((TEXT TEDIT)
(* ;;
(LET
(SUBWINDOWS)
(CL:WHEN (MEMB (OR (CADDR MENUITEM)
(CAR MENUITEM))
'(Compare See% right See% both See% left))
(FOR W IN (WINDOWPROP WINDOW 'SUBWINDOWS) WHEN (OPENWP W) DO (CLOSEW W)))
(SELECTQ (OR (CADDR MENUITEM)
(CAR MENUITEM))
(Compare (IF (AND FILE1 FILE2)
THEN [SETQ SUBWINDOWS
(SELECTQ TYPE
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2
(RELCREATEREGION
[FIXR (TIMES 0.75 (FETCH (REGION WIDTH)
OF (WINDOWPROP WINDOW
'REGION]
200
'LEFT
'TOP
`(,WINDOW 0.125)
(IPLUS (FETCH (REGION BOTTOM)
OF (WINDOWPROP WINDOW 'REGION))
20)
T)))
(COMPILED (FLASHWINDOW T)
(PRIN3 "Cannot compare compiled files" T))
((TEXT TEDIT)
(* ;;
 "Works for TEDIT, but doesn't detect image object differences")
(COMPARETEXT FILE1 FILE2 'LINE NIL (LIST LABEL1 LABEL2)))
(PROGN (PRIN3 "Unable to compare, showing both" T)
(TEDIT-SEE-VERSIONS FILE1 FILE2 LABEL1 LABEL2)))
ELSE (PRIN3 "Only one file" T)))
(See% left (IF FILE1
THEN (TEDIT-SEE FILE1 NIL NIL (CONCAT "SEE window for " LABEL1))
ELSE (FLASHWINDOW T)
(PRIN3 "No file to print" T)))
(See% right (IF FILE2
THEN (TEDIT-SEE FILE2 NIL NIL (CONCAT "SEE window for " LABEL2))
(COMPARETEXT FILE1 FILE2 'LINE
(RELCREATEPOSITION `(,WINDOW 0.5)
(IPLUS (FETCH (REGION BOTTOM)
OF (WINDOWPROP WINDOW 'REGION))
20))
(LIST LABEL1 LABEL2)))
(PROGN (FLASHWINDOW T)
(PRIN3 "Unable to compare, showing both" T)
(TEDIT-SEE-VERSIONS FILE1 FILE2 LABEL1 LABEL2]
ELSE (FLASHWINDOW T)
(PRIN3 "Only one file" T)))
(See% left (IF FILE1
THEN (SETQ SUBWINDOWS (TEDIT-SEE FILE1
(RELCREATEREGION
700 700 'RIGHT 'TOP `(,WINDOW 0.5)
(IPLUS (FETCH (REGION BOTTOM)
OF (WINDOWPROP WINDOW 'REGION))
-1)
T)
NIL
(CONCAT "SEE window for " LABEL1)))
ELSE (FLASHWINDOW T)
(PRIN3 "No file to print" T)))
(See% both (IF (AND FILE1 FILE2)
THEN (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2)
ELSE (PRIN3 "Only one file" T)))
(Copy% -> (LET [(DEST (COPYFILE FILE1 (PACKFILENAME 'VERSION NIL FILE2]
(PRIN3 (CL:IF DEST
(CONCAT "Copied to " DEST)
(CONCAT FILE2 " could not be copied"))
T)))
(Copy% <- (LET [(DEST (COPYFILE FILE2 (PACKFILENAME 'VERSION NIL FILE1]
(PRIN3 (CL:IF DEST
(CONCAT "Copied to " DEST)
(CONCAT FILE1 " could not be copied"))
T)))
(SHOULDNT])
(See% right (IF FILE2
THEN (SETQ SUBWINDOWS (TEDIT-SEE FILE2
(RELCREATEREGION
700 700 'LEFT 'TOP `(,WINDOW 0.5)
(IPLUS (FETCH (REGION BOTTOM)
OF (WINDOWPROP WINDOW 'REGION))
-1)
T)
NIL
(CONCAT "SEE window for " LABEL2)))
ELSE (FLASHWINDOW T)
(PRIN3 "No file to print" T)))
(See% both (IF (AND FILE1 FILE2)
THEN (SETQ SUBWINDOWS (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2
(RELCREATEREGION
1400 700 'LEFT 'TOP `(,WINDOW 0.5 -701)
(IPLUS (FETCH (REGION BOTTOM)
OF (WINDOWPROP WINDOW 'REGION))
-1)
T)))
ELSE (FLASHWINDOW T)
(PRIN3 "Only one file" T)))
(Copy% -> (LET [(DEST (COPYFILE FILE1 (PACKFILENAME 'VERSION NIL FILE2]
(PRIN3 (CL:IF DEST
(CONCAT "Copied to " DEST)
(PROGN (FLASHWINDOW T)
(CONCAT FILE2 " could not be copied")))
T)))
(Copy% <- (LET [(DEST (COPYFILE FILE2 (PACKFILENAME 'VERSION NIL FILE1]
(PRIN3 (CL:IF DEST
(CONCAT "Copied to " DEST)
(PROGN (FLASHWINDOW T)
(CONCAT FILE1 " could not be copied")))
T)))
(SHOULDNT))
(FOR W INSIDE SUBWINDOWS DO (WINDOWADDPROP WINDOW 'SUBWINDOWS (WFROMDS W])
)
(RPAQQ CDTABLEBROWSER.MENUITEMS ((Compare CD-MENUFN)
@@ -1723,21 +1925,23 @@ 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 (2418 17067 (COMPAREDIRECTORIES 2428 . 12186) (COMPAREDIRECTORIES.INFOS 12188 . 13867) (
COMPAREDIRECTORIES.INFOS.TYPE 13869 . 14451) (MATCHNAME 14453 . 14983) (CD.INSURECDVALUE 14985 . 16599
) (CD.UPDATEWIDTHS 16601 . 17065)) (17068 26728 (CDFILES 17078 . 23061) (CDFILES.MATCH 23063 . 24449)
(CDFILES.PATS 24451 . 26726)) (26729 41174 (CDPRINT 26739 . 29343) (CDPRINT.LINE 29345 . 31901) (
CDPRINT.MAXWIDTHS 31903 . 36018) (CDPRINT.COLHEADERS 36020 . 36658) (CDPRINT.COLUMNS 36660 . 40539) (
CDTEDIT 40541 . 41172)) (41175 44371 (CDMAP 41185 . 42617) (CDENTRY 42619 . 42928) (CDSUBSET 42930 .
44369)) (44372 51313 (BINCOMP 44382 . 48671) (EOLTYPE 48673 . 50638) (EOLTYPE.SHOW 50640 . 51311)) (
51841 65048 (FIND-UNCOMPILED-FILES 51851 . 55494) (FIND-UNSOURCED-FILES 55496 . 58305) (
FIND-SOURCE-FILES 58307 . 60011) (FIND-COMPILED-FILES 60013 . 62091) (FIND-UNLOADED-FILES 62093 .
62837) (FIND-LOADED-FILES 62839 . 63393) (FIND-MULTICOMPILED-FILES 63395 . 65046)) (65049 73251 (
CREATED-AS 65059 . 69856) (SOURCE-FOR-COMPILED-P 69858 . 72556) (COMPILE-SOURCE-DATE-DIFF 72558 .
73249)) (73252 83558 (FIX-DIRECTORY-DATES 73262 . 76255) (FIX-EQUIV-DATES 76257 . 77782) (
COPY-COMPARED-FILES 77784 . 79605) (COPY-MISSING-FILES 79607 . 81764) (COMPILED-ON-SAME-SOURCE 81766
. 83556)) (83752 91440 (CDBROWSER 83762 . 88335) (CDBROWSER.STRINGS 88337 . 91438)) (91602 92874 (
CD.TABLEITEM 91612 . 91832) (CD.TABLEITEM.PRINTFN 91834 . 92033) (CD.TABLEITEM.COPYFN 92035 . 92629) (
CDTABLEBROWSER.HEADING.REPAINTFN 92631 . 92872)) (92875 100220 (CDTABLEBROWSER.WHENSELECTEDFN 92885 .
93353) (CD.COMMANDSELECTEDFN 93355 . 97161) (CD-MENUFN 97163 . 100218)))))
(FILEMAP (NIL (2497 19012 (COMPAREDIRECTORIES 2507 . 8956) (COMPAREDIRECTORIES.INFOS 8958 . 11078) (
CDENTRIES.SELECT 11080 . 15766) (COMPAREDIRECTORIES.INFOS.TYPE 15768 . 16396) (MATCHNAME 16398 . 16928
) (CD.INSURECDVALUE 16930 . 18544) (CD.UPDATEWIDTHS 18546 . 19010)) (19013 29285 (CDFILES 19023 .
25379) (CDFILES.MATCH 25381 . 27006) (CDFILES.PATS 27008 . 29283)) (29286 44371 (CDPRINT 29296 . 31641
) (CDPRINT.HEADER 31643 . 32540) (CDPRINT.LINE 32542 . 35098) (CDPRINT.MAXWIDTHS 35100 . 39215) (
CDPRINT.COLHEADERS 39217 . 39855) (CDPRINT.COLUMNS 39857 . 43736) (CDTEDIT 43738 . 44369)) (44372
52741 (CDMAP 44382 . 45814) (CDENTRY 45816 . 46125) (CDSUBSET 46127 . 47566) (CDMERGE 47568 . 51422) (
CDMERGE.COMMON 51424 . 52739)) (52742 60280 (BINCOMP 52752 . 57041) (EOLTYPE 57043 . 59605) (
EOLTYPE.SHOW 59607 . 60278)) (60808 74015 (FIND-UNCOMPILED-FILES 60818 . 64461) (FIND-UNSOURCED-FILES
64463 . 67272) (FIND-SOURCE-FILES 67274 . 68978) (FIND-COMPILED-FILES 68980 . 71058) (
FIND-UNLOADED-FILES 71060 . 71804) (FIND-LOADED-FILES 71806 . 72360) (FIND-MULTICOMPILED-FILES 72362
. 74013)) (74016 82218 (CREATED-AS 74026 . 78823) (SOURCE-FOR-COMPILED-P 78825 . 81523) (
COMPILE-SOURCE-DATE-DIFF 81525 . 82216)) (82219 92525 (FIX-DIRECTORY-DATES 82229 . 85222) (
FIX-EQUIV-DATES 85224 . 86749) (COPY-COMPARED-FILES 86751 . 88572) (COPY-MISSING-FILES 88574 . 90731)
(COMPILED-ON-SAME-SOURCE 90733 . 92523)) (92719 100458 (CDBROWSER 92729 . 97353) (CDBROWSER.STRINGS
97355 . 100456)) (100620 101892 (CD.TABLEITEM 100630 . 100850) (CD.TABLEITEM.PRINTFN 100852 . 101051)
(CD.TABLEITEM.COPYFN 101053 . 101647) (CDTABLEBROWSER.HEADING.REPAINTFN 101649 . 101890)) (101893
112086 (CDTABLEBROWSER.WHENSELECTEDFN 101903 . 102371) (CD.COMMANDSELECTEDFN 102373 . 105764) (
CD-MENUFN 105766 . 112084)))))
STOP

BIN
lispusers/COMPAREDIRECTORIES.LCOM
View File

Binary file not shown.

13
lispusers/COMPAREDIRECTORIES.TEDIT
View File

File diff suppressed because one or more lines are too long

161
lispusers/COMPARESOURCES
View File

@@ -1,13 +1,10 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Jan-2022 08:40:38" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;106 42666
(FILECREATED "25-Jan-2022 16:05:14" {MM}<lispusers>COMPARESOURCES.;115 41781
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN CSOBJ.COPYBUTTONEVENTINFN)
(VARS COMPARESOURCESCOMS)
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN)
:PREVIOUS-DATE "27-Dec-2021 11:56:48"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;105)
:PREVIOUS-DATE "24-Jan-2022 23:12:17" {MM}<lispusers>COMPARESOURCES.;113)
(* ; "
@@ -143,15 +140,17 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
'SAME])
(\CS.COMPARE.MASTERS
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 19-Dec-2021 21:05 by rmk")
(* ; "Edited 9-Dec-2021 23:26 by rmk")
(* ; "Edited 4-Dec-2021 10:00 by rmk")
(* ; "Edited 2-Dec-2021 14:25 by rmk:")
(* ; "Edited 27-Nov-2021 12:31 by rmk:")
[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:")
(* ; "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)) (* ;
 "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))
@@ -555,50 +554,52 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
ELSE (ADD LINELENGTH (CHARWIDTH C FONT])
(CSOBJ.BUTTONEVENTINFN
[LAMBDA (OBJ WINDOW) (* ; "Edited 26-Dec-2021 16:28 by rmk")
(* ; "Edited 24-Dec-2021 14:09 by rmk")
(* ; "Edited 20-Dec-2021 11:01 by rmk")
(* ; "Edited 12-Dec-2021 21:30 by rmk")
(* ; "Edited 10-Dec-2021 10:21 by rmk")
(* ; "Edited 7-Dec-2021 17:49 by rmk")
(* ; "Edited 4-Dec-2021 20:05 by rmk")
[LAMBDA (OBJ WINDOW) (* ; "Edited 25-Jan-2022 16:04 by rmk")
(* ; "Edited 23-Jan-2022 18:11 by rmk")
(LET
[(COMPAREDATA (IMAGEOBJPROP OBJ 'COMPAREDATA]
(CL:WHEN (AND COMPAREDATA (MOUSESTATE LEFT)
(UNTILMOUSESTATE (NOT LEFT)))
[LET ((NAME (POP COMPAREDATA))
(TYPE (POP COMPAREDATA))
(DEF1 (POP COMPAREDATA))
(DEF2 (POP COMPAREDATA))
(TITLE1 (POP COMPAREDATA))
(TITLE2 (CAR COMPAREDATA)))
(LET
((NAME (POP COMPAREDATA))
(TYPE (POP COMPAREDATA))
(DEF1 (POP COMPAREDATA))
(DEF2 (POP COMPAREDATA))
(TITLE1 (POP COMPAREDATA))
(TITLE2 (CAR COMPAREDATA)))
(* ;; "Move the cursor to just slightly below the current object, so that the edit windows are well aligned. We have to figure out the bottom of the current object, in screen coordinates.")
(* ;; "Move the cursor to just slightly below the current object, so that the edit windows are well aligned. We have to figure out the bottom of the current object, in screen coordinates.")
[LET ((OBJREGION (OBJ.FIND.REGION WINDOW OBJ)))
(\CURSORPOSITION (IPLUS 20 LASTMOUSEX)
(IPLUS (IDIFFERENCE (FETCH (REGION BOTTOM) OF (OBJ.FIND.REGION WINDOW OBJ))
(FETCH (REGION HEIGHT)
OBJREGION))
(FETCH (REGION TOP) OF (WINDOWREGION WINDOW]
(IF (IMAGEOBJPROP OBJ 'ONLYONE)
THEN [SEDIT:SEDIT
(OR DEF1 DEF2)
`(:REGION ,(RELGETREGION 600 (CL:IF (ILESSP (COUNT (OR DEF1 DEF2))
100)
150
400)
'LEFT
'TOP NIL NIL T]
ELSE (* ; "Spread the arguments")
(EXAMINEDEFS NAME TYPE DEF1 DEF2 TITLE1 TITLE2
(RELGETREGION 800 (CL:IF (ILESSP (IMAX (COUNT DEF1)
(COUNT DEF2))
100)
150
400)
'LEFT
'TOP NIL NIL T])])
[LET ((OBJREGION (OBJ.FIND.REGION WINDOW OBJ)))
(\CURSORPOSITION (IPLUS 20 LASTMOUSEX)
(IPLUS (IDIFFERENCE (FETCH (REGION BOTTOM) OF OBJREGION)
(FETCH (REGION HEIGHT) OF OBJREGION))
(FETCH (REGION TOP) OF (WINDOWREGION WINDOW]
(LET
[EWINDOW (RELPOS (RELCREATEPOSITION `(,WINDOW 0.5)
`(,WINDOW 0 -2]
(CL:WHEN [WINDOWP (SETQ EWINDOW (WINDOWPROP WINDOW 'EXAMINEWINDOW]
(CLOSEW EWINDOW))
(SETQ EWINDOW
(IF (IMAGEOBJPROP OBJ 'ONLYONE)
THEN
[SEDIT:GET-WINDOW
(SEDIT:SEDIT (OR DEF1 DEF2)
`(:REGION ,(RELCREATEREGION 600 (CL:IF (ILESSP (COUNT (OR DEF1 DEF2))
100)
150
400)
(CL:IF DEF1
'RIGHT
'LEFT)
'TOP RELPOS NIL T]
ELSE (* ; "Spread the arguments")
(EXAMINEDEFS NAME TYPE DEF1 DEF2 TITLE1 TITLE2 RELPOS)))
(WINDOWPROP WINDOW 'EXAMINEWINDOW EWINDOW)
(WINDOWADDPROP WINDOW 'CLOSEFN [FUNCTION (LAMBDA (W)
(CLOSEW (WINDOWPROP W 'EXAMINEWINDOW]
T)
EWINDOW)))])
(CSOBJ.COPYBUTTONEVENTINFN
[LAMBDA (OBJ WINDOW REGION) (* ; "Edited 3-Jan-2022 08:36 by rmk")
@@ -625,14 +626,14 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
(DEFINEQ
(CSBROWSER
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION) (* ; "Edited 26-Dec-2021 21:06 by rmk")
(* ; "Edited 24-Dec-2021 22:48 by rmk")
(* ; "Edited 20-Dec-2021 09:55 by rmk")
(* ; "Edited 16-Dec-2021 12:38 by rmk")
(* ; "Edited 10-Dec-2021 12:03 by rmk")
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION)
(* ;; "Edited 24-Jan-2022 23:11 by rmk: EXAMINE is non-NIL, we run the compare twice. Once to get the TEDIT up as a kind of table of contents, and the second time to run through all of the SEDIT windows.")
(* ;; "If EXAMINE is non-NIL, we run the compare twice. Once to get the TEDIT up as a kind of table of contents, and the second time to run through all of the SEDIT windows.")
(* ;; "Returns browser window")
(* ;; "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))
@@ -651,24 +652,24 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
" and "
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY]
(SELECTQ COMPARESOURCES-BROWSER-TYPE
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL NIL TITLE NIL T (FONTPROP
DEFAULTFONT
'HEIGHT]
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T
(FONTPROP DEFAULTFONT 'HEIGHT]
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
(GETPROMPTWINDOW WINDOW T)
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
(PROG1 (COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
DW? WINDOW)
(OPENW WINDOW))))
(TEDIT [LET ((TSTREAM (OPENTEXTSTREAM)))
(COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
DW? WINDOW)
(OPENW WINDOW)
WINDOW))
(TEDIT (LET ((TSTREAM (OPENTEXTSTREAM)))
(DSPFONT DEFAULTFONT TSTREAM)
(PROG1 (COMPARESOURCES FILEX FILEY EXAMINE DW? TSTREAM)
[TEDIT TSTREAM NIL NIL `(READONLY T WINDOWTYPE COMPARESOURCES-TEDIT
TITLE ,TITLE]
(CL:WHEN NIL
EXAMINE
(COMPARESOURCES FILEX FILEY EXAMINE DW? (OPENSTREAM '{NULL}
'OUTPUT))))])
(COMPARESOURCES FILEX FILEY EXAMINE DW? TSTREAM)
[TEDIT TSTREAM REGION NIL `(READONLY T WINDOWTYPE COMPARESOURCES-TEDIT TITLE
,TITLE]
(CL:WHEN NIL
EXAMINE
(COMPARESOURCES FILEX FILEY EXAMINE DW? (OPENSTREAM '{NULL} 'OUTPUT)))
(WFROMDS TSTREAM)))
(HELP])
)
@@ -689,16 +690,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 (1920 27703 (COMPARESOURCES 1930 . 8443) (\CS.COMPARE.MASTERS 8445 . 16581) (
\CS.COMPARE.TYPES 16583 . 19721) (\CS.EXAMINE 19723 . 23950) (\CS.FIXFNS 23952 . 25454) (
\CS.SORT.DECLARES 25456 . 25799) (\CS.SORT.DECLARE1 25801 . 27221) (\CS.FILTER.GARBAGE 27223 . 27701))
(27704 31684 (\CS.ISFNFORM 27714 . 27982) (\CS.COMPARE.FNS 27984 . 28226) (\CS.FNSID 28228 . 28372) (
\CS.ISVARFORM 28374 . 28479) (\CS.COMPARE.VARS 28481 . 29143) (\CS.ISMACROFORM 29145 . 29283) (
\CS.ISRECFORM 29285 . 29378) (\CS.ISCOURIERFORM 29380 . 29480) (\CS.ISTEMPLATEFORM 29482 . 29580) (
\CS.COMPARE.TEMPLATES 29582 . 29947) (\CS.ISPROPFORM 29949 . 30104) (\CS.PROP.NAME 30106 . 30251) (
\CS.COMPARE.PROPS 30253 . 30410) (\CS.ISADDVARFORM 30412 . 30505) (\CS.COMPARE.ADDVARS 30507 . 30672)
(\CS.ISFPKGCOMFORM 30674 . 30881) (\CS.COMPARE.FPKGCOMS 30883 . 31090) (\CS.COMPARE.DEFINE-FILE-INFO
31092 . 31682)) (31685 38243 (CSOBJ.CREATE 31695 . 32108) (CSOBJ.DISPLAYFN 32110 . 32863) (
CSOBJ.IMAGEBOXFN 32865 . 35026) (CSOBJ.BUTTONEVENTINFN 35028 . 37993) (CSOBJ.COPYBUTTONEVENTINFN 37995
. 38241)) (39107 42184 (CSBROWSER 39117 . 42182)))))
(FILEMAP (NIL (1768 27559 (COMPARESOURCES 1778 . 8291) (\CS.COMPARE.MASTERS 8293 . 16437) (
\CS.COMPARE.TYPES 16439 . 19577) (\CS.EXAMINE 19579 . 23806) (\CS.FIXFNS 23808 . 25310) (
\CS.SORT.DECLARES 25312 . 25655) (\CS.SORT.DECLARE1 25657 . 27077) (\CS.FILTER.GARBAGE 27079 . 27557))
(27560 31540 (\CS.ISFNFORM 27570 . 27838) (\CS.COMPARE.FNS 27840 . 28082) (\CS.FNSID 28084 . 28228) (
\CS.ISVARFORM 28230 . 28335) (\CS.COMPARE.VARS 28337 . 28999) (\CS.ISMACROFORM 29001 . 29139) (
\CS.ISRECFORM 29141 . 29234) (\CS.ISCOURIERFORM 29236 . 29336) (\CS.ISTEMPLATEFORM 29338 . 29436) (
\CS.COMPARE.TEMPLATES 29438 . 29803) (\CS.ISPROPFORM 29805 . 29960) (\CS.PROP.NAME 29962 . 30107) (
\CS.COMPARE.PROPS 30109 . 30266) (\CS.ISADDVARFORM 30268 . 30361) (\CS.COMPARE.ADDVARS 30363 . 30528)
(\CS.ISFPKGCOMFORM 30530 . 30737) (\CS.COMPARE.FPKGCOMS 30739 . 30946) (\CS.COMPARE.DEFINE-FILE-INFO
30948 . 31538)) (31541 37731 (CSOBJ.CREATE 31551 . 31964) (CSOBJ.DISPLAYFN 31966 . 32719) (
CSOBJ.IMAGEBOXFN 32721 . 34882) (CSOBJ.BUTTONEVENTINFN 34884 . 37481) (CSOBJ.COPYBUTTONEVENTINFN 37483
. 37729)) (38595 41299 (CSBROWSER 38605 . 41297)))))
STOP

BIN
lispusers/COMPARESOURCES.LCOM
View File

Binary file not shown.

BIN
lispusers/COMPARETEXT.LCOM
View File

Binary file not shown.

BIN
lispusers/COMPARETEXT.TEDIT
View File

Binary file not shown.

169
lispusers/EXAMINEDEFS
View File

@@ -1,22 +1,28 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Jan-2022 23:15:58" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;19 6871
(FILECREATED "25-Jan-2022 10:20:31" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;31 11252
:CHANGES-TO (FNS EXAMINEFILES)
:PREVIOUS-DATE "30-Dec-2021 21:49:58"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;18)
:PREVIOUS-DATE "23-Jan-2022 17:41:43"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;30)
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEFILES)
(INITVARS (EXAMINEDEFS-PROCESS-LIST))))
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEFILES TEDITDEF)
(INITVARS (EXAMINEDEFS-PROCESS-LIST)
(EXAMINEWITH 'COMPARETEXT))
(FILES (SYSLOAD)
COMPARETEXT)))
(DEFINEQ
(EXAMINEDEFS
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 24-Dec-2021 22:39 by rmk")
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 23-Jan-2022 17:40 by rmk")
(* ; "Edited 18-Jan-2022 22:40 by rmk")
(* ; "Edited 12-Jan-2022 17:29 by rmk")
(* ; "Edited 24-Dec-2021 22:39 by rmk")
(* ; "Edited 20-Dec-2021 11:06 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.")
@@ -30,6 +36,8 @@
(ERROR SOURCE1 " cannot be examined"))
(CL:UNLESS (LISTP SOURCE2)
(ERROR SOURCE2 " cannot be examined")))
(CL:UNLESS TYPE
(SETQ TYPE 'FNS))
(* ;; "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?)")
@@ -68,65 +76,124 @@
(* ;;
 "Crude suggestions for height, width, position. Suggest shorter window for smaller structures")
(CL:UNLESS (REGIONP REGION)
(SETQ REGION (GETREGION)))
(LET (W1 W2 HALFWIDTH)
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH) OF REGION)
2))
[SETQ W1
(SEDIT:GET-WINDOW (SEDIT:SEDIT DEF1
`(:NAME ,(CONCAT NAME " from " TITLE1)
:REGION
,(CREATE REGION
USING REGION WIDTH _ HALFWIDTH)
:DONT-KEEP-WINDOW-REGION T]
[SETQ W2
(SEDIT:GET-WINDOW
(SEDIT:SEDIT DEF2
`(:NAME ,(CONCAT NAME " from " TITLE2)
:REGION
,(CREATE REGION USING REGION LEFT _
(IPLUS (FETCH (REGION LEFT)
OF REGION)
HALFWIDTH)
WIDTH _ HALFWIDTH)
:DONT-KEEP-WINDOW-REGION T]
(SELECTQ EXAMINEWITH
(SEDIT (CL:UNLESS (REGIONP REGION)
(SETQ REGION (GETREGION)))
[LET (R1 R2 HALFWIDTH W1 W2)
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH)
OF REGION)
2))
(SETQ R1 (CREATE REGION USING REGION WIDTH _ HALFWIDTH))
(SETQ R2 (CREATE REGION USING REGION LEFT _
(IPLUS (FETCH (REGION LEFT)
OF REGION)
HALFWIDTH)
WIDTH _ HALFWIDTH))
[SETQ W1
(SEDIT:GET-WINDOW (SEDIT:SEDIT
DEF1
`(:NAME ,(CONCAT NAME " from " TITLE1)
:REGION
,(CREATE REGION
USING REGION WIDTH _
HALFWIDTH)
R1 :DONT-KEEP-WINDOW-REGION T]
[SETQ W2
(SEDIT:GET-WINDOW (SEDIT:SEDIT
DEF2
`(:NAME ,(CONCAT NAME " from " TITLE2)
:REGION
,R2 :DONT-KEEP-WINDOW-REGION T]
(ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
(MODERNWINDOW W2)
(* ;;
(* ;;
 "So we can kill the processes on the next call, if they still exist after the windows are closed.")
[PUSH EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP W1 'PROCESS))
(CONS W2 (WINDOWPROP W2 'PROCESS]
(ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
(MODERNWINDOW W2)))
(PUSH EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP
W1
'PROCESS))
(CONS W2 (WINDOWPROP W2 'PROCESS])
(COMPARETEXT [LET (COMPARETEXT.ALLCHUNKS CTWINDOW
(KEY (LIST NAME TYPE SOURCE1 SOURCE2 TITLE1
TITLE2)))
(DECLARE (SPECVARS COMPARETEXT.ALLCHUNKS))
(* ; "Reuse an existing CT graph window")
(OR [FIND W IN (OPENWINDOWS)
SUCHTHAT (EQUAL KEY (WINDOWPROP W
'EXAMINEDEFS]
(PROG1 (SETQ CTWINDOW
(COMPARETEXT (TEDITDEF NAME DEF1 TYPE)
(TEDITDEF NAME DEF2 TYPE)
'LINE REGION (LIST TITLE1 TITLE2)
(CONCAT "Compare sources of " NAME
" as " TYPE)))
(WINDOWPROP CTWINDOW 'EXAMINEDEFS
(LIST NAME TYPE SOURCE1 SOURCE2 TITLE1
TITLE2)))])
(SHOULDNT)))
(PROGN (EDITE DEF1)
(EDITE DEF2])
(EXAMINEFILES
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 2-Jan-2022 23:15 by rmk")
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 25-Jan-2022 10:08 by rmk")
(* ; "Edited 2-Jan-2022 23:15 by rmk")
(* ; "Edited 30-Dec-2021 21:49 by rmk")
(* ;; "We get a region, then split it in half. Should we attach or at least co-move and co-close the 2 windows?")
(CL:UNLESS REGION
(SETQ REGION (GETREGION)))
(TEDIT-SEE FILE1 (RELCREATEREGION `(,REGION 0.5 -1)
REGION
'RIGHT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE1)
(TEDIT-SEE FILE2 (RELCREATEREGION `(,REGION 0.5 1)
REGION
'LEFT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE2])
(LIST (TEDIT-SEE FILE1 (RELCREATEREGION `(,REGION 0.5 -1)
REGION
'RIGHT
'TOP
`(,REGION 0.5)
(FETCH (REGION TOP) OF REGION))
NIL TITLE1)
(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) (* ; "Edited 12-Jan-2022 17:27 by rmk")
(LET ((TSTREAM (OPENTEXTSTREAM)))
(DSPFONT DEFAULTFONT TSTREAM)
(CL:WHEN (EQ (CAR DEF)
'DEFINEQ)
(SETQ DEF (CADR DEF)))
(IF (EQ NAME (CAR DEF))
THEN (DSPFONT BOLDFONT TSTREAM)
(PRINT NAME TSTREAM)
(DSPFONT DEFAULTFONT TSTREAM)
(SETQ DEF (CADR DEF))
(PRINTDEF DEF 3 T NIL NIL TSTREAM)
ELSEIF (EQ NAME (CADR DEF))
THEN
(* ;; "Presumably a DEFUN. Print the CAR, boldface the cadr")
(PRINTOUT TSTREAM "(" .P2 (CAR DEF)
" " .FONT BOLDFONT .P2 (CADR DEF)
.FONT DEFAULTFONT " " .P2 (CADDR DEF)
T 3)
(PRINTDEF (CDDDR DEF)
3 T T NIL TSTREAM)
(PRIN3 ")" TSTREAM)
ELSE (PRINTDEF DEF 3 NIL NIL NIL TSTREAM))
TSTREAM])
)
(RPAQ? EXAMINEDEFS-PROCESS-LIST )
(RPAQ? EXAMINEWITH 'COMPARETEXT)
(FILESLOAD (SYSLOAD)
COMPARETEXT)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (510 6809 (EXAMINEDEFS 520 . 5811) (EXAMINEFILES 5813 . 6807)))))
(FILEMAP (NIL (662 11110 (EXAMINEDEFS 672 . 8791) (EXAMINEFILES 8793 . 9988) (TEDITDEF 9990 . 11108)))
))
STOP

BIN
lispusers/EXAMINEDEFS.LCOM
View File

Binary file not shown.

BIN
lispusers/EXAMINEDEFS.TEDIT
View File

Binary file not shown.

1143
lispusers/GITFNS Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
lispusers/GITFNS.LCOM Normal file
View File

Binary file not shown.

BIN
lispusers/GITFNS.TEDIT Normal file
View File

Binary file not shown.

438
lispusers/PSEUDOHOSTS Normal file
View File

@@ -0,0 +1,438 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Jan-2022 12:35:16" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;119 22617
:CHANGES-TO (VARS PSEUDOHOSTSCOMS)
:PREVIOUS-DATE "26-Jan-2022 23:33:17"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;118)
(PRETTYCOMPRINT PSEUDOHOSTSCOMS)
(RPAQQ PSEUDOHOSTSCOMS
[
(* ;; "Public entries")
(FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEFILENAME)
(* ;; "Internals")
(FNS EXPAND.PH CONTRACT.PH SLASHIT UNSLASHIT)
(FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH
OPENP.PH UNREGISTERFILE.PH REGISTERFILE.PH GENERATEFILES.PH GETFILEINFO.PH
SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH RENAMEFILE.PH)
(P (PSEUDOHOST 'LI LOGINHOST/DIR))
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE)
(MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL)
(P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE)
(LOAD 'EXPORTS.ALL))])
(* ;; "Public entries")
(DEFINEQ
(PSEUDOHOST
[LAMBDA (HOST PREFIX) (* ; "Edited 25-Jan-2022 09:58 by rmk")
(* ; "Edited 23-Jan-2022 20:43 by rmk")
(* ; "Edited 18-Jan-2022 13:08 by rmk")
(CL:WHEN (AND (LISTP HOST)
(NULL PREFIX))
(SETQ PREFIX (CADR HOST))
(SETQ HOST (CAR HOST)))
(SETQ HOST (U-CASE (MKATOM HOST)))
(IF PREFIX
THEN (CL:UNLESS (FILENAMEFIELD PREFIX 'HOST)
(SETQ PREFIX (UNSLASHIT (PACKFILENAME 'HOST 'DSK 'BODY PREFIX))))
(CL:UNLESS (MEMB (NTHCHARCODE PREFIX -1)
(CHARCODE (> / <)))
(SETQ PREFIX (CONCAT PREFIX (IF (STRPOS "/" PREFIX)
THEN "/"
ELSE ">"))))
[LET (PREVIOUS TARGETHOST TARGETDEVICE)
(CL:WHEN (SETQ PREVIOUS (PSEUDOHOSTP HOST))(* ;
 "Redefining: first clear out the previous one")
(PSEUDOHOST HOST NIL))
[SETQ TARGETHOST (U-CASE (FILENAMEFIELD PREFIX 'HOST]
(* ;; "We know about the directory separators for these particular devices. Maybe there should be separate list of slash-hosts somewhere that we can use.")
(SELECTQ TARGETHOST
((DSK CORE)
(SETQ PREFIX (UNSLASHIT PREFIX)))
(UNIX (SETQ PREFIX (SLASHIT PREFIX)))
NIL)
(SETQ TARGETDEVICE (OR (\GETDEVICEFROMHOSTNAME TARGETHOST)
(ERROR "UNKNOWN TARGET HOST" TARGETHOST)))
(* ;; "Save the last directory marker to pack on if needed.")
(\DEFINEDEVICE HOST (CREATE FDEV
USING TARGETDEVICE DEVICENAME _ HOST FDEV1 _ TARGETDEVICE
FDEV2 _ (CONS PREFIX (CL:IF (EQ (CHARCODE /)
(NTHCHARCODE PREFIX -1
))
'/
'<))
OPENFILE _ (FUNCTION OPENFILE.PH)
GETFILENAME _ (FUNCTION GETFILENAME.PH)
DIRECTORYNAMEP _ (FUNCTION DIRECTORYNAMEP.PH)
CLOSEFILE _ (FUNCTION CLOSEFILE.PH)
REOPENFILE _ (FUNCTION REOPENFILE.PH)
DELETEFILE _ (FUNCTION DELETEFILE.PH)
OPENP _ (FUNCTION OPENP.PH)
UNREGISTERFILE _ (FUNCTION UNREGISTERFILE.PH)
REGISTERFILE _ (FUNCTION REGISTERFILE.PH)
GENERATEFILES _ (FUNCTION GENERATEFILES.PH)
GETFILEINFO _ (FUNCTION GETFILEINFO.PH)
SETFILEINFO _ (FUNCTION SETFILEINFO.PH)
RENAMEFILE _ (FUNCTION RENAMEFILE.PH]
ELSEIF (PSEUDOHOSTP HOST)
THEN (UNINTERRUPTABLY
(* ;; "\DEFINEDEVICE removes the name-mapping but doesn't remove the device. Maybe that's on purpose for other devices, but not here.")
(SETQ \FILEDEVICES (DREMOVE (\GETDEVICEFROMNAME HOST \FILEDEVICES)
\FILEDEVICES))
(\DEFINEDEVICE HOST NIL))
ELSE (ERROR HOST "is not a pseudohost"))
HOST])
(PSEUDOHOSTP
[LAMBDA (HOST) (* ; "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)))])
(PSEUDOHOSTS
[LAMBDA NIL (* ; "Edited 17-Jan-2022 18:15 by rmk")
(FOR DEV IN \FILEDEVICES WHEN (TYPE? FDEV (FETCH (PHDEVICE TARGETDEV) OF DEV))
COLLECT (LIST (FETCH (FDEV DEVICENAME) OF DEV)
(FETCH (PHDEVICE PREFIX) OF DEV])
(TARGETHOST
[LAMBDA (HOST) (* ; "Edited 22-Jan-2022 09:00 by rmk")
(CL:WHEN (PSEUDOHOSTP HOST)
(FETCH (FDEV DEVICENAME) OF (FETCH (PHDEVICE TARGETDEV) OF (\GETDEVICEFROMNAME HOST))))])
(TRUEFILENAME
[LAMBDA (FILE) (* ; "Edited 26-Jan-2022 23:33 by rmk")
(* ; "Edited 25-Jan-2022 08:47 by rmk")
(LET (FILENAME DEVICE)
(IF (STREAMP FILE)
THEN (SETQ FILENAME (FETCH (STREAM FULLFILENAME) OF FILE))
(SETQ DEVICE (FETCH (STREAM DEVICE) OF FILE))
ELSE (SETQ FILENAME (\ADD.CONNECTED.DIR FILE))
(SETQ DEVICE (\GETDEVICEFROMNAME FILENAME)))
(CL:IF (TYPE? PHDEVICE DEVICE)
(EXPAND.PH FILENAME DEVICE)
FILENAME)])
)
(* ;; "Internals")
(DEFINEQ
(EXPAND.PH
[LAMBDA (FILENAME PHDEV)
(* ;; "Edited 26-Jan-2022 11:06 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
(* ;; "Assumes that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
(IF (TYPE? STREAM FILENAME)
THEN (CL:UNLESS PHDEV
(SETQ PHDEV (FETCH (STREAM DEVICE) OF FILENAME)))
(SETQ FILENAME (FETCH (STREAM FULLNAME) OF FILENAME))
ELSEIF (NOT (TYPE? FDEV PHDEV))
THEN (SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
(LET (SUFFIX SUFFIXPOS)
(CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME))
(SETQ SUFFIX (SUBSTRING FILENAME (ADD1 SUFFIXPOS)))
(CL:WHEN (FMEMB (CHCON1 SUFFIX)
(CHARCODE (< > /)))
(SETQ SUFFIX (SUBSTRING SUFFIX 2)))
(CONCAT (FETCH (PHDEVICE PREFIX) OF PHDEV)
SUFFIX))])
(CONTRACT.PH
[LAMBDA (NAME PHDEV) (* ; "Edited 25-Jan-2022 09:44 by rmk")
(* ; "Edited 20-Jan-2022 20:04 by rmk")
(* ; "Edited 18-Jan-2022 22:54 by rmk")
(* ; "Edited 16-Jan-2022 19:57 by rmk")
(* ; "Edited 14-Jan-2022 00:03 by rmk")
(CL:UNLESS (TYPE? FDEV PHDEV)
(SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
(CL:WHEN NAME
(LET* [(PREFIX (FETCH (PHDEVICE PREFIX) OF PHDEV))
(CONNECTOR (FETCH (PHDEVICE CONNECTOR) OF PHDEV))
(SUFFIX (SUBSTRING NAME (ADD1 (NCHARS PREFIX]
(IF (STRPOS PREFIX NAME 1 NIL T NIL FILEDIRCASEARRAY)
THEN (CL:WHEN (STRPOS ">" SUFFIX 1 NIL NIL NIL FILEDIRCASEARRAY)
(* ;; "Must be a subdirectory. (CDR INFO) tells us whether to use / or > depending on what the prefix has")
[SETQ SUFFIX (CONCAT CONNECTOR (IF (EQ CONNECTOR '/)
THEN (SLASHIT SUFFIX)
ELSE (UNSLASHIT SUFFIX])
(PACK* '{ (FETCH (FDEV DEVICENAME) OF PHDEV)
"}"
(OR SUFFIX ""))
ELSE
(* ;; "If the target's NAME didn't begin with the prefix, then the caller must have jumped outside the pseudo root. So just return the NAME")
NAME)))])
(SLASHIT
[LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:08 by rmk")
(* ; "Edited 3-Jan-2022 11:44 by rmk")
(* ; "Edited 22-Dec-2021 20:18 by rmk")
(* ; "Edited 2-Nov-2021 22:54 by rmk:")
(LET [LASTDIRPOS SLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
0]
[SETQ SLASHED (CONCATCODES (FOR I C FROM DIRPOS WHILE (SETQ C (NTHCHARCODE X I))
COLLECT (SELCHARQ C
((< >)
(SETQ LASTDIRPOS I)
(CHARCODE /))
(/ (SETQ LASTDIRPOS I)
C)
C]
(CL:WHEN (AND LCASEDIRS LASTDIRPOS)
(SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
(SETQ SLASHED (CONCAT (L-CASE (SUBSTRING SLASHED 1 LASTDIRPOS))
(OR (SUBSTRING SLASHED (ADD1 LASTDIRPOS))
""))))
(CL:IF (EQ DIRPOS 1)
SLASHED
(CONCAT (SUBSTRING X 1 (SUB1 DIRPOS))
SLASHED))])
(UNSLASHIT
[LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:09 by rmk")
(* ; "Edited 22-Dec-2021 20:18 by rmk")
(* ; "Edited 21-Nov-2021 23:00 by rmk:")
(* ;; "Tricky to get the first one right.")
(LET [LASTDIRPOS UNSLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
0]
[SETQ UNSLASHED
(CONCATCODES (FOR I C LASTC FROM DIRPOS WHILE (SETQ C (NTHCHARCODE X I))
COLLECT (PROG1 (SELCHARQ C
(/ (SETQ LASTDIRPOS I)
(IF (AND LASTC (NEQ LASTC (CHARCODE })))
THEN (CHARCODE >)
ELSE (CHARCODE <)))
((< >)
(SETQ LASTDIRPOS I)
C)
C)
(SETQ LASTC C]
(CL:WHEN (AND LCASEDIRS LASTDIRPOS)
(SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
(SETQ UNSLASHED (CONCAT (L-CASE (SUBSTRING UNSLASHED 1 LASTDIRPOS))
(OR (SUBSTRING UNSLASHED (ADD1 LASTDIRPOS))
""))))
(CL:IF (EQ DIRPOS 1)
UNSLASHED
(CONCAT (SUBSTRING X 1 (SUB1 DIRPOS))
UNSLASHED))])
)
(DEFINEQ
(OPENFILE.PH
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING) (* ; "Edited 25-Jan-2022 08:45 by rmk")
(* ; "Edited 18-Jan-2022 10:29 by rmk")
(LET ((STREAM (PSEUDOHOST.TARGETVAL OPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING)
FDEV)))
(CHANGE (FETCH (STREAM FULLFILENAME) OF STREAM)
(CONTRACT.PH DATUM FDEV))
(REPLACE (STREAM DEVICE) OF STREAM WITH FDEV)
STREAM])
(GETFILENAME.PH
[LAMBDA (NAME RECOG FDEV) (* ; "Edited 25-Jan-2022 22:56 by rmk")
(* ; "Edited 16-Jan-2022 20:27 by rmk")
(PSEUDOHOST.NAME GETFILENAME (NAME RECOG FDEV])
(DIRECTORYNAMEP.PH
[LAMBDA (DIRSPEC DEV CREATE?) (* ; "Edited 25-Jan-2022 22:56 by rmk")
(* ; "Edited 18-Jan-2022 11:32 by rmk")
(* ;; "{FOO} by itself is always a legitimate directory--you should be able to connect to it when you are starting up")
 (* ; "Edited 16-Jan-2022 20:35 by rmk")
(OR (EQ (CHARCODE })
(NTHCHARCODE DIRSPEC -1))
(PSEUDOHOST.NAME DIRECTORYNAMEP (DIRSPEC DEV CREATE?)
DEV])
(CLOSEFILE.PH
[LAMBDA (STREAM ABORTFLG) (* ; "Edited 16-Jan-2022 15:38 by rmk")
(APPLY* (FETCH (FDEV CLOSEFILE) OF (FETCH (PHDEVICE TARGETDEV) OF (FETCH (STREAM DEVICE)
OF STREAM)))
STREAM ABORTFLG])
(REOPENFILE.PH
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 25-Jan-2022 12:50 by rmk")
(* ; "Edited 18-Jan-2022 11:41 by rmk")
(LET ((STREAM (PSEUDOHOST.TARGETVAL REOPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)
FDEV)))
(CHANGE (FETCH (STREAM FULLFILENAME) OF STREAM)
(CONTRACT.PH DATUM FDEV))
(REPLACE (STREAM DEVICE) OF STREAM WITH FDEV)
STREAM])
(DELETEFILE.PH
[LAMBDA (FILENAME DEV) (* ; "Edited 25-Jan-2022 22:56 by rmk")
(* ; "Edited 18-Jan-2022 10:23 by rmk")
(PSEUDOHOST.NAME DELETEFILE (FILENAME DEV])
(OPENP.PH
[LAMBDA (FILENAME ACCESS DEVICE) (* ; "Edited 18-Jan-2022 10:29 by rmk")
(PSEUDOHOST.TARGETVAL OPENP (FILENAME ACCESS DEVICE])
(UNREGISTERFILE.PH
[LAMBDA (DEVICE STREAM) (* ; "Edited 16-Jan-2022 16:47 by rmk")
(APPLY* (FETCH (FDEV UNREGISTERFILE) OF (FETCH (PHDEVICE TARGETDEV) OF DEVICE))
(FETCH (PHDEVICE TARGETDEV) OF DEVICE)
STREAM])
(REGISTERFILE.PH
[LAMBDA (DEVICE STREAM) (* ; "Edited 16-Jan-2022 16:46 by rmk")
(APPLY* (FETCH (FDEV REGISTERFILE) OF (FETCH (PHDEVICE TARGETDEV) OF DEVICE))
(FETCH (PHDEVICE TARGETDEV) OF DEVICE)
STREAM])
(GENERATEFILES.PH
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 17-Jan-2022 20:46 by rmk")
(* ;; "FDEV is the pseudohost. We will generate from the target directory using its GENFILESTATE, but fiddle the output so that it looks like it is coming from the pseudo host.")
(LET ((TARGETGENOBJ (APPLY* (FETCH (FDEV GENERATEFILES) OF (FETCH (PHDEVICE TARGETDEV)
OF FDEV))
(FETCH (PHDEVICE TARGETDEV) OF FDEV)
(EXPAND.PH PATTERN FDEV)
DESIREDPROPS OPTIONS)))
(* ;; "The TARGETGENOBJ contains the targets functions as well as its GENFILESTATE. We need the ph FDEV to contract the generated names")
(CREATE FILEGENOBJ
NEXTFILEFN _ (FUNCTION NEXTFILEFN.PH)
FILEINFOFN _ (FUNCTION FILEINFOFN.PH)
GENFILESTATE _ (LIST FDEV TARGETGENOBJ])
(GETFILEINFO.PH
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 25-Jan-2022 12:43 by rmk")
(* ; "Edited 17-Jan-2022 18:21 by rmk")
(PSEUDOHOST.TARGETVAL GETFILEINFO (STREAM ATTRIBUTE DEVICE])
(SETFILEINFO.PH
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 25-Jan-2022 12:37 by rmk")
(PSEUDOHOST.TARGETVAL SETFILEINFO (STREAM ATTRIBUTE VALUE DEVICE])
(NEXTFILEFN.PH
[LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 17-Jan-2022 21:27 by rmk")
(LET* ((TARGETGENOBJ (CADR GENFILESTATE))
(TARGETGENFILESTATE (FETCH GENFILESTATE OF TARGETGENOBJ))
(FILENAME (APPLY* (FETCH NEXTFILEFN OF TARGETGENOBJ)
TARGETGENFILESTATE NAMEONLY)))
(CL:WHEN FILENAME
(CL:UNLESS NAMEONLY
(SETQ FILENAME (CONTRACT.PH FILENAME (CAR GENFILESTATE)))))
FILENAME])
(FILEINFOFN.PH
[LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 17-Jan-2022 20:52 by rmk")
(APPLY* (FETCH FILEINFOFN OF (CADR GENFILESTATE))
(FETCH GENFILESTATE OF (CADR GENFILESTATE))
ATTRIBUTE])
(RENAMEFILE.PH
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 18-Jan-2022 09:52 by rmk")
(LET ((OLDTARGETDEV (FETCH (PHDEVICE TARGETDEV) OF OLD-DEVICE))
(NEWTARGETDEV (FETCH (PHDEVICE TARGETDEV) OF NEW-DEVICE))
(NEWTARGETNAME NEW-NAME)
RESULT)
(CL:WHEN (TYPE? FDEV NEWTARGETDEV) (* ; "NEW-DEVICE is a pseudo host")
(SETQ NEWTARGETNAME (EXPAND.PH NEW-NAME NEW-DEVICE)))
(SETQ RESULT (APPLY* (FETCH (FDEV RENAMEFILE) OF OLDTARGETDEV)
OLDTARGETDEV
(EXPAND.PH OLD-NAME OLD-DEVICE)
(OR NEWTARGETDEV NEW-DEVICE)
NEWTARGETNAME))
(CL:WHEN (AND RESULT (NEQ NEWTARGETDEV NEW-DEVICE))
(SETQ RESULT (CONTRACT.PH RESULT NEW-DEVICE)))
RESULT])
)
(PSEUDOHOST 'LI LOGINHOST/DIR)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(ACCESSFNS PHDEVICE [(PREFIX (CAR (FETCH (FDEV FDEV2) OF DATUM)))
(TARGETDEV (FETCH (FDEV FDEV1) OF DATUM)
(REPLACE (FDEV FDEV1) OF DATUM WITH NEWVALUE))
(CONNECTOR (CDR (FETCH (FDEV FDEV2) OF DATUM]
(TYPE? (FETCH (PHDEVICE PREFIX) OF DATUM)))
(RECORD PHGENFILESTATE (PHDEVICE . TARGETGENFILESTATE))
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS PSEUDOHOST.NAME MACRO
[TAIL (LET [(OPNAME (CAR TAIL))
(ARGS (CADR TAIL))
(DEV (OR (CADDR TAIL)
(CAR (LAST (CADR TAIL]
(* ;;
 "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately")
`(CONTRACT.PH [APPLY* (FETCH (FDEV ,OPNAME) OF (FETCH (PHDEVICE TARGETDEV)
OF ,DEV))
(EXPAND.PH ,(CAR ARGS)
,DEV)
,@(SUBST `(FETCH (PHDEVICE TARGETDEV) OF ,DEV)
DEV
(CDR ARGS]
,DEV])
(PUTPROPS PSEUDOHOST.TARGETVAL MACRO
[TAIL (LET [(OPNAME (CAR TAIL))
(ARGS (CADR TAIL))
(DEV (OR (CADDR TAIL)
(CAR (LAST (CADR TAIL]
(* ;; "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately. Unlike PSEUDOHOST.OP, this returns the target value, doesn't assume it is a name to be contracted.")
`(APPLY* (FETCH (FDEV ,OPNAME) OF (FETCH (PHDEVICE TARGETDEV)
OF ,DEV))
(EXPAND.PH ,(CAR ARGS)
,DEV)
,@(SUBST `(FETCH (PHDEVICE TARGETDEV) OF ,DEV)
DEV
(CDR ARGS])
)
(CL:UNLESS (GETP 'EXPORTS.ALL 'FILE)
(LOAD 'EXPORTS.ALL))
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1205 7096 (PSEUDOHOST 1215 . 5418) (PSEUDOHOSTP 5420 . 5770) (PSEUDOHOSTS 5772 . 6129)
(TARGETHOST 6131 . 6405) (TRUEFILENAME 6407 . 7094)) (7124 13330 (EXPAND.PH 7134 . 8189) (CONTRACT.PH
8191 . 10010) (SLASHIT 10012 . 11580) (UNSLASHIT 11582 . 13328)) (13331 20121 (OPENFILE.PH 13341 .
13902) (GETFILENAME.PH 13904 . 14193) (DIRECTORYNAMEP.PH 14195 . 14819) (CLOSEFILE.PH 14821 . 15175) (
REOPENFILE.PH 15177 . 15742) (DELETEFILE.PH 15744 . 16028) (OPENP.PH 16030 . 16206) (UNREGISTERFILE.PH
16208 . 16513) (REGISTERFILE.PH 16515 . 16816) (GENERATEFILES.PH 16818 . 17858) (GETFILEINFO.PH 17860
. 18162) (SETFILEINFO.PH 18164 . 18363) (NEXTFILEFN.PH 18365 . 18907) (FILEINFOFN.PH 18909 . 19180) (
RENAMEFILE.PH 19182 . 20119)))))
STOP

BIN
lispusers/PSEUDOHOSTS.LCOM Normal file
View File

Binary file not shown.

BIN
lispusers/PSEUDOHOSTS.TEDIT Normal file
View File

Binary file not shown.

206
lispusers/REGIONMANAGER
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Jan-2022 16:01:26" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;99 31663
(FILECREATED "27-Jan-2022 13:24:29" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;106 34264
:CHANGES-TO (FNS SET-TYPED-REGIONS \RELCREATEREGION.REF \RELCREATEREGION.SIZE)
:CHANGES-TO (FNS RELCREATEREGION \RELCREATEREGION.SIZE RELGETREGION)
:PREVIOUS-DATE " 1-Jan-2022 23:14:42"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;95)
:PREVIOUS-DATE "25-Jan-2022 15:38:10"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;105)
(PRETTYCOMPRINT REGIONMANAGERCOMS)
@@ -30,7 +30,7 @@
(* ;; "Relative regions")
(COMS (FNS RELCREATEREGION RELGETREGION)
(COMS (FNS RELCREATEREGION RELGETREGION RELCREATEPOSITION)
(FNS \RELCREATEREGION.REF \RELCREATEREGION.SIZE))
(* ;; "Composite application construction")
@@ -250,7 +250,11 @@
(DEFINEQ
(RELCREATEREGION
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) (* ; "Edited 30-Dec-2021 20:54 by rmk")
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) (* ; "Edited 27-Jan-2022 13:23 by rmk")
(* ; "Edited 25-Jan-2022 15:29 by rmk")
(* ; "Edited 23-Jan-2022 21:18 by rmk")
(* ; "Edited 12-Jan-2022 17:50 by rmk")
(* ; "Edited 30-Dec-2021 20:54 by rmk")
(* ; "Edited 27-Dec-2021 15:54 by rmk")
(* ;; "The region is oriented so that he REFX and REFY are at the corner named by CORNERX/Y. ")
@@ -274,99 +278,129 @@
(* ;; "")
(* ;; "Resolve the width and height, if based on a region or window ")
(* ;; "The arguments can be given as a list to be spread out, so that region relative region specifications can be passed through intermediate functions. The test here is not very tight, if it is incorrect the recursive call will fail.")
(SETQ WIDTH (\RELCREATEREGION.SIZE WIDTH 'X))
(SETQ HEIGHT (\RELCREATEREGION.SIZE HEIGHT 'Y))
(IF (AND (LISTP WIDTH)
(NOT (REGIONP WIDTH))
(NULL HEIGHT)
(IGREATERP (LENGTH WIDTH)
3))
THEN
(* ;; "If less than 3, presumably a relative width")
(* ;; "Resolve the corner")
(APPLY (FUNCTION RELCREATEREGION)
WIDTH)
ELSE
(* ;; "Resolve the width and height, if based on a region or window ")
(CL:UNLESS CORNERX
(SETQ CORNERX 'LEFT))
(CL:UNLESS CORNERY
(SETQ CORNERY 'BOTTOM))
(CL:WHEN (AND (LISTP CORNERX)
(NULL CORNERY))
(SETQ CORNERY (CADR CORNERX))
(SETQ CORNERX (CAR CORNERX)))
(SETQ WIDTH (\RELCREATEREGION.SIZE WIDTH 'X))
(SETQ HEIGHT (\RELCREATEREGION.SIZE HEIGHT 'Y))
(* ;; "Resolve the reference point")
(* ;; "Resolve the corner")
[IF (AND (POSITIONP REFX)
(NULL REFY))
THEN (SETQ REFY (FETCH (POSITION YCOORD) OF REFX))
(SETQ REFX (FETCH (POSITION XCOORD) OF REFX))
ELSE (GETMOUSESTATE)
(SETQ REFX (\RELCREATEREGION.REF REFX 'X))
(SETQ REFY (\RELCREATEREGION.REF REFY 'Y]
(CL:UNLESS CORNERX
(SETQ CORNERX 'LEFT))
(CL:UNLESS CORNERY
(SETQ CORNERY 'BOTTOM))
(CL:WHEN (AND (LISTP CORNERX)
(NULL CORNERY))
(SETQ CORNERY (CADR CORNERX))
(SETQ CORNERX (CAR CORNERX)))
(* ;; "Align the new-region corner with the reference point")
(* ;; "Resolve the reference point")
(LET* ((LEFT REFX)
(BOTTOM REFY)
(RIGHT (IPLUS LEFT WIDTH))
(TOP (IPLUS BOTTOM HEIGHT)))
(CL:WHEN (EQ 'RIGHT CORNERX)
(SETQ RIGHT LEFT)
(SETQ LEFT (IDIFFERENCE LEFT WIDTH)))
(CL:WHEN (EQ 'TOP CORNERY)
(SETQ TOP BOTTOM)
(SETQ BOTTOM (IDIFFERENCE BOTTOM HEIGHT)))
(CL:WHEN ONSCREEN (* ; "Keep the region on the screen. ")
(CL:WHEN (ILESSP LEFT 0)
(ADD WIDTH LEFT)
(SETQ LEFT 0))
(CL:WHEN (ILESSP BOTTOM 0)
(ADD HEIGHT BOTTOM)
(SETQ BOTTOM 0))
(CL:WHEN (IGREATERP RIGHT SCREENWIDTH)
(ADD WIDTH (IDIFFERENCE SCREENWIDTH RIGHT)))
(CL:WHEN (IGREATERP TOP SCREENHEIGHT)
(ADD HEIGHT (IDIFFERENCE SCREENHEIGHT TOP))))
(CREATEREGION LEFT BOTTOM WIDTH HEIGHT])
[IF (AND (POSITIONP REFX)
(NULL REFY))
THEN (SETQ REFY (FETCH (POSITION YCOORD) OF REFX))
(SETQ REFX (FETCH (POSITION XCOORD) OF REFX))
ELSE (GETMOUSESTATE)
(SETQ REFX (\RELCREATEREGION.REF REFX 'X))
(SETQ REFY (\RELCREATEREGION.REF REFY 'Y]
(* ;; "Align the new-region corner with the reference point")
(LET* ((LEFT REFX)
(BOTTOM REFY)
(RIGHT (IPLUS LEFT WIDTH))
(TOP (IPLUS BOTTOM HEIGHT)))
(CL:WHEN (EQ 'RIGHT CORNERX)
(SETQ RIGHT LEFT)
(SETQ LEFT (IDIFFERENCE LEFT WIDTH)))
(CL:WHEN (EQ 'TOP CORNERY)
(SETQ TOP BOTTOM)
(SETQ BOTTOM (IDIFFERENCE BOTTOM HEIGHT)))
(CL:WHEN ONSCREEN (* ; "Keep the region on the screen. Not clear whether we should keep the width and height and just move the left and bottom. Here we allow some shrinkage")
(CL:WHEN (ILESSP LEFT 0)
(ADD WIDTH (IMIN 100 LEFT))
(SETQ LEFT 0))
(CL:WHEN (ILESSP BOTTOM 0)
(ADD HEIGHT (IMIN 100 BOTTOM))
(SETQ BOTTOM 0))
(CL:WHEN (IGREATERP RIGHT SCREENWIDTH)
(ADD WIDTH (IDIFFERENCE SCREENWIDTH RIGHT)))
(CL:WHEN (IGREATERP TOP SCREENHEIGHT)
(ADD HEIGHT (IDIFFERENCE SCREENHEIGHT TOP))))
(CREATEREGION LEFT BOTTOM WIDTH HEIGHT])
(RELGETREGION
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY MINSIZE) (* ; "Edited 28-Dec-2021 23:13 by rmk")
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY MINSIZE) (* ; "Edited 27-Jan-2022 13:24 by rmk")
(* ; "Edited 25-Jan-2022 15:30 by rmk")
(* ; "Edited 23-Jan-2022 21:20 by rmk")
(* ; "Edited 28-Dec-2021 23:13 by rmk")
(* ; "Edited 10-Dec-2021 10:15 by rmk")
(* ;; "Prompts for a relative region as created by RELCREATEREGION. Initially the anchored corner is fixed and the cursor is moved to the diagonally opposite corner. If MINSIZE, the WIDTH and HEIGHT are taken to be the minimums that are acceptable, modulo the fact that the opposite corner is guaranteed to be visibleand, the size of the ghost region can only grow. If not MINSIZE, we also allow the user to shrink the ghost region.")
(CL:WHEN (AND (LISTP CORNERX)
(NULL CORNERY))
(SETQ CORNERY (CADR CORNERX))
(SETQ CORNERX (CAR CORNERX)))
(CL:UNLESS CORNERX
(SETQ CORNERX 'LEFT))
(CL:UNLESS CORNERY
(SETQ CORNERY 'BOTTOM))
(LET* ((REGION (OR (REGIONP WIDTH)
(RELCREATEREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY T)))
(BASEX (FETCH (REGION LEFT) OF REGION))
(BASEY (FETCH (REGION BOTTOM) OF REGION))
(RWIDTH (FETCH (REGION WIDTH) OF REGION))
(RHEIGHT (FETCH (REGION HEIGHT) OF REGION))
(OPPX (IPLUS BASEX RWIDTH))
(OPPY (IPLUS BASEY RHEIGHT)))
(COND
((AND (LISTP WIDTH)
(NOT (REGIONP WIDTH))
(NULL HEIGHT)
(IGREATERP (LENGTH WIDTH)
3))
(APPLY (FUNCTION RELGETREGION)
WIDTH))
(T (CL:WHEN (AND (LISTP CORNERX)
(NULL CORNERY))
(SETQ CORNERY (CADR CORNERX))
(SETQ CORNERX (CAR CORNERX)))
(CL:UNLESS CORNERX
(SETQ CORNERX 'LEFT))
(CL:UNLESS CORNERY
(SETQ CORNERY 'BOTTOM))
(LET* ((REGION (OR (REGIONP WIDTH)
(RELCREATEREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY T)))
(BASEX (FETCH (REGION LEFT) OF REGION))
(BASEY (FETCH (REGION BOTTOM) OF REGION))
(RWIDTH (FETCH (REGION WIDTH) OF REGION))
(RHEIGHT (FETCH (REGION HEIGHT) OF REGION))
(OPPX (IPLUS BASEX RWIDTH))
(OPPY (IPLUS BASEY RHEIGHT)))
(* ;; "Default parameters assume the anchor is (LEFT BOTTOM)")
(* ;; "Default parameters assume the anchor is (LEFT BOTTOM)")
(CL:WHEN (EQ 'RIGHT CORNERX)
(SWAP BASEX OPPX))
(CL:WHEN (EQ 'TOP CORNERY)
(SWAP BASEY OPPY))
(\CURSORPOSITION OPPX OPPY)
(CL:UNLESS MINSIZE (* ; "No minimum size constraint")
(SETQ RWIDTH NIL)
(SETQ RHEIGHT NIL))
(GETREGION RWIDTH RHEIGHT REGION NIL NIL (LIST BASEX BASEY OPPX OPPY])
(CL:WHEN (EQ 'RIGHT CORNERX)
(SWAP BASEX OPPX))
(CL:WHEN (EQ 'TOP CORNERY)
(SWAP BASEY OPPY))
(\CURSORPOSITION OPPX OPPY)
(CL:UNLESS MINSIZE (* ; "No minimum size constraint")
(SETQ RWIDTH NIL)
(SETQ RHEIGHT NIL))
(GETREGION RWIDTH RHEIGHT REGION NIL NIL (LIST BASEX BASEY OPPX OPPY])
(RELCREATEPOSITION
[LAMBDA (REFX REFY) (* ; "Edited 23-Jan-2022 17:08 by rmk")
(CREATEPOSITION (\RELCREATEREGION.REF REFX 'X)
(\RELCREATEREGION.REF REFY 'Y])
)
(DEFINEQ
(\RELCREATEREGION.REF
[LAMBDA (REF WHICH) (* ; "Edited 2-Jan-2022 11:01 by rmk")
[LAMBDA (REF WHICH) (* ; "Edited 23-Jan-2022 20:20 by rmk")
(* ; "Edited 2-Jan-2022 11:01 by rmk")
(* ;; "REF can be NIL, an absolute screen position, the atom SCREEN, or a list of (anchor fraction adjustment) where anchor can be a region, window, or the atom SCREEN, fraction can be a number or atoms LEFT/RIGHT/BOTTOM/TOP as apropriate.")
(* ; "Edited 30-Dec-2021 17:49 by rmk")
 (* ; "Edited 30-Dec-2021 17:49 by rmk")
(LET (ANCHOR VAL SIZE FRACTION SPEC (BASE 0))
(* ;; "Would be nice if the screen had a region")
@@ -386,7 +420,8 @@
ELSEIF [AND (LISTP REF)
(SETQ ANCHOR (OR (REGIONP (CAR REF))
(AND (WINDOWP (CAR REF))
(WINDOWREGION (CAR REF)))
(WINDOWPROP (CAR REF)
'REGION))
(AND (EQ (CAR REF)
'SCREEN)
'SCREEN]
@@ -417,7 +452,7 @@
ELSE (\ILLEGAL.ARG REF])
(\RELCREATEREGION.SIZE
[LAMBDA (PARAM WHICH) (* ; "Edited 2-Jan-2022 11:00 by rmk")
[LAMBDA (PARAM WHICH) (* ; "Edited 2-Jan-2022 11:00 by rmk")
(* ; "Edited 30-Dec-2021 17:51 by rmk")
(* ;;
@@ -591,8 +626,9 @@
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1602 3789 (SET-TYPED-REGIONS 1612 . 3787)) (3790 10791 (RM-CREATEW 3800 . 6307) (
RM-CLOSEW 6309 . 7710) (RM-GETREGION 7712 . 10298) (CLOSE-TYPED-W 10300 . 10789)) (11707 16778 (
RELCREATEREGION 11717 . 14876) (RELGETREGION 14878 . 16776)) (16779 21898 (\RELCREATEREGION.REF 16789
. 19646) (\RELCREATEREGION.SIZE 19648 . 21896)) (21951 31293 (RM-ATTACHWINDOW 21961 . 31291)))))
(FILEMAP (NIL (1612 3799 (SET-TYPED-REGIONS 1622 . 3797)) (3800 10801 (RM-CREATEW 3810 . 6317) (
RM-CLOSEW 6319 . 7720) (RM-GETREGION 7722 . 10308) (CLOSE-TYPED-W 10310 . 10799)) (11717 19196 (
RELCREATEREGION 11727 . 16350) (RELGETREGION 16352 . 18959) (RELCREATEPOSITION 18961 . 19194)) (19197
24499 (\RELCREATEREGION.REF 19207 . 22239) (\RELCREATEREGION.SIZE 22241 . 24497)) (24552 33894 (
RM-ATTACHWINDOW 24562 . 33892)))))
STOP

BIN
lispusers/REGIONMANAGER.LCOM
View File

Binary file not shown.

6
lispusers/REGIONMANAGER.TEDIT
View File

@@ -37,10 +37,12 @@ NIL: LASTMOUSEX/LASTMOUSEY
(RELCREATEREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) [Function]
RELCREATEREGION creates a region of dimensions WIDTH and HEIGHT. One of its corners is identified by CORNERX and CORNERY and that corner will be aligned with a reference screen-point determined by REFX and REFY. If ONSCREEN, the WIDTH or HEIGHT will be adjusted with respect to that alignment so that the resulting region is entirely within the screen.
WIDTH and HEIGHT can be given as absolute (natural) numbers) or specified relative to the WIDTH and HEIGHT of another region or of the screen. The possibilities are interpreted as follows:
natural number: the number of screen points
list of the form (anchor fraction adjustment), where anchor is a region, window, or the atom SCREEN. The corres-ponding dimension of the anchor is mutiplied by fraction and adjustment is added to the result. For example, specifying (<window> .5 -1) results in a WIDTH that is one point smaller than half the width of window's region. Fraction and adjustment default to 1 and 0 respectively.
region/window/SCREEN: equivalent to (region/window/SCREEN 1 0).
CORNERX can be LEFT, RIGHT, or NIL=LEFT, CORNERY can be BOTTOM, TOP, or NIL=BOTTOM. If LEFT/TOP are specified, for example, the region will be splayed down and to the right of the reference point. If RIGHT/BOTTOM, then up and to the left.
CORNERX can be LEFT, RIGHT, or NIL=LEFT, CORNERY can be BOTTOM, TOP, or NIL=BOTTOM. If LEFT/TOP are specified, for example, the region will be splayed down and to the right of the reference point. If RIGHT/BOTTOM, then up and to the left.
The reference-point arguments REFX and REFY are interpreted as follows:
NIL: LASTMOUSEX/LASTMOUSEY
natural number: an absolute screen coordinate
(anchor fraction adjustment) or just region/window/SCREEN: the quantity determined relative to the size of anchor (as above) is added to the anchors left/bottom produce the REFX/REFY coordinate. In this case, fractions specified as LEFT/BOTTOM/NIL are interpreted as 0 and RIGHT/TOP are interpreted as 1. For example, a specification (<window> .4 -2) for REFY will produce a coordinate 2 points below the level that is 40% of the distance between the bottom and top of the window's region.
For convenience, if REFX is a position and REFY is NIL, then the XCOORD and YCOORD of REFX are taken as absolute values for REFX and REFY.
@@ -56,4 +58,4 @@ TIMESROMAN$TERMINALMODERN MODERN
An alternative approach is to construct the central window first, giving it the entire constellation region, and then to have ATTACHWINDOW reshape that window to accomodate the satellite windows as they are attached in sequence. This leads to the same final configuration, but there is no need for separate calculations to pre-adjust the region of the central window.
REGIONMANAGER provides an overlay veneer for ATTACHWINDOW that implements this strategy. If the new argument TAKEFROMCENTRAL is true, then the region of the WINDOWTOATTACH will be substracted from the region of the existing central window according to the EDGE parameter of the attachment.
(ATTACHWINDOW WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION TAKEFROMCENTRAL) [Function]
This behavior is also triggered if the UNDERCONSTRUCTION property of the central window is true. Thus, a constellation can be set up by creating all of the satellites and the central window, marking the central window as under construction, and then doing the sequence of attachments. The property can be reset to NIL when the construction is complete, so the central window does not shrink if other other attachments (e.g. expanded menus) by later user actions.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ4ÈÈ4ÈÈ4ÈÈ. $È. È.È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEADTERMINALÿüTERMINALÿü
This behavior is also triggered if the UNDERCONSTRUCTION property of the central window is true. Thus, a constellation can be set up by creating all of the satellites and the central window, marking the central window as under construction, and then doing the sequence of attachments. The property can be reset to NIL when the construction is complete, so the central window does not shrink if other other attachments (e.g. expanded menus) by later user actions.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4ÈÈ4ÈÈ4ÈÈ4ÈÈ. $È. È.È4ÈÈ.È.ŠŠ8.ŠŠ8JÈÈ PAGEHEADING RUNNINGHEADTERMINALÿüTERMINALÿü

43
lispusers/TEDIT-PF-SEE
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Jan-2022 22:03:27" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104 6489
(FILECREATED "12-Jan-2022 13:16:00" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;110 7695
:CHANGES-TO (VARS TEDIT-PF-SEECOMS)
:CHANGES-TO (FNS PF-TEDIT)
:PREVIOUS-DATE "30-Dec-2021 23:17:58"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;103)
:PREVIOUS-DATE " 2-Jan-2022 22:03:27"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104)
(PRETTYCOMPRINT TEDIT-PF-SEECOMS)
@@ -22,7 +22,8 @@
(DEFINEQ
(PF-TEDIT
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 30-Dec-2021 23:17 by rmk")
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 12-Jan-2022 13:15 by rmk")
(* ; "Edited 30-Dec-2021 23:17 by rmk")
(* ;; "PF* to a read-only TEDIT window. First argument is the function name, second if given is the input file.")
@@ -76,13 +77,27 @@
THEN (SETFILEPTR ISTREAM (POP LOC))
(SETQ EXPR (WITH-READER-ENVIRONMENT ENV (READ ISTREAM))
)
(IF (EQ FN (CAR EXPR))
THEN (DSPFONT BOLDFONT TSTREAM)
(PRINT FN TSTREAM)
(DSPFONT DEFAULTFONT TSTREAM)
(SETQ EXPR (CADR EXPR))
(PRINTDEF EXPR 3 NIL NIL NIL TSTREAM)
ELSE (PRINTDEF EXPR NIL NIL NIL NIL TSTREAM))
(WITH-READER-ENVIRONMENT ENV
(IF (EQ FN (CAR EXPR))
THEN (DSPFONT BOLDFONT TSTREAM)
(PRINT FN TSTREAM)
(DSPFONT DEFAULTFONT TSTREAM)
(SETQ EXPR (CADR EXPR))
(PRINTDEF EXPR 3 T NIL NIL TSTREAM)
ELSEIF (EQ FN (CADR EXPR))
THEN
(* ;;
 "Presumably a DEFUN. Print the CAR, boldface the cadr")
(PRINTOUT TSTREAM "(" .P2 (CAR EXPR)
" " .FONT BOLDFONT .P2 (CADR EXPR)
.FONT DEFAULTFONT " " .P2
(CADDR EXPR)
T 3)
(PRINTDEF (CDDDR EXPR)
3 T T NIL TSTREAM)
(PRIN3 ")" TSTREAM)
ELSE (PRINTDEF EXPR 3 NIL NIL NIL TSTREAM)))
ELSE (PFCOPYBYTES ISTREAM TSTREAM (POP LOC)
(POP LOC)))
(TERPRI TSTREAM)
@@ -127,5 +142,5 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (956 6010 (PF-TEDIT 966 . 6008)))))
(FILEMAP (NIL (947 7216 (PF-TEDIT 957 . 7214)))))
STOP

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

Binary file not shown.

197
lispusers/comparetext
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "30-Dec-2021 21:22:01" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;100 48929
(FILECREATED "27-Jan-2022 13:20:38" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;109 49971
:CHANGES-TO (FNS COMPARETEXT.TEXTOBJ)
:PREVIOUS-DATE "27-Dec-2021 15:56:54"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;98)
:PREVIOUS-DATE "23-Jan-2022 20:22:06"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;108)
(* ; "
@@ -33,11 +33,9 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(DEFINEQ
(COMPARETEXT
[LAMBDA (FILE1 FILE2 HASH.TYPE REGION FILELABELS) (* ; "Edited 22-Dec-2021 23:49 by rmk")
(* ; "Edited 15-Dec-2021 16:23 by rmk")
(* ; "Edited 13-Dec-2021 12:21 by rmk")
(* ; "Edited 8-Nov-2021 08:44 by rmk:")
(* mjs " 8-Jan-84 21:06")
[LAMBDA (FILE1 FILE2 HASH.TYPE REGION FILELABELS TITLE) (* ; "Edited 12-Jan-2022 16:32 by rmk")
(* ; "Edited 8-Nov-2021 08:44 by rmk")
(* ; "Edited 8-Jan-84 21:06 by mjs")
(* ;; "Compares the two files, and produces a graph showing their corresponding chunks. The courseness of the 'chunking' is determined by HASH.TYPE, which may be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. The file difference graph is displayed at REGION. If REGION = NIL, the user is asked to specify a region. If REGION = T, a standard region is used.")
@@ -45,8 +43,10 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
((PARA LINE WORD))
(NIL (SETQ HASH.TYPE 'PARA))
(ERROR (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)))
(LET ((FULLFILE1 (FINDFILE FILE1 T))
(FULLFILE2 (FINDFILE FILE2 T)))
(LET [(FULLFILE1 (OR (GETSTREAM FILE1 'INPUT T)
(FINDFILE FILE1 T)))
(FULLFILE2 (OR (GETSTREAM FILE2 'INPUT T)
(FINDFILE FILE2 T]
(CL:UNLESS (AND FULLFILE1 FULLFILE2)
(ERROR "Can't find both files" (LIST FILE1 FILE2)))
(IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK
@@ -55,17 +55,22 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(create IMCOMPARE.CHUNK
FILENAME _ FULLFILE2
FILEPTR _ 0)
HASH.TYPE NIL FILELABELS])
HASH.TYPE REGION FILELABELS TITLE])
(COMPARETEXT.WINDOW
[LAMBDA (GRAPH REGION) (* ; "Edited 27-Dec-2021 13:47 by rmk")
(* ; "Edited 25-Dec-2021 11:40 by rmk")
[LAMBDA (GRAPH REGION TITLE) (* ; "Edited 23-Jan-2022 18:18 by rmk")
(* ; "Edited 12-Jan-2022 10:06 by rmk")
(* ; "Edited 22-Dec-2021 15:51 by rmk")
(* ;; "Set up the graph WINDOW. If REGION isn't provided we prompt with a region that is wide enough for the graph and high enough for at least an initial segment.")
(LET [WINDOW GRAPHREGION GWIDTH (FILEPREFIX (CAR (GRAPHERPROP GRAPH 'FILELABELS]
[SETQ REGION
(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 HEIGHT (IMIN 200 (IPLUS (FETCH (REGION HEIGHT) OF GRAPHREGION)
(ITIMES 2 (FONTHEIGHT DEFAULTFONT]
(SETQ REGION
(if (EQ REGION T)
then (create REGION
LEFT _ 25
@@ -73,35 +78,38 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
WIDTH _ 500
HEIGHT _ 150)
elseif (REGIONP REGION)
else (CLRPROMPT)
(printout PROMPTWINDOW "Please specify a region for the comparison graph" T)
(SETQ GRAPHREGION (GRAPHREGION GRAPH))
(SETQ GWIDTH (FETCH (REGION WIDTH) OF GRAPHREGION))
elseif (POSITIONP REGION)
THEN
(* ;;
 "This is a reference position providing the horizontal midpoint of the graph region and the top")
(RELCREATEREGION WIDTH HEIGHT 'LEFT 'TOP (IDIFFERENCE (FETCH (POSITION XCOORD)
OF REGION)
(IQUOTIENT WIDTH 2))
(FETCH (POSITION YCOORD) OF REGION))
ELSE (CLEARW (GETPROMPTWINDOW WINDOW))
(printout (GETPROMPTWINDOW WINDOW)
"Please specify a region for the comparison graph" T)
(* ;; "I don't know why the graphregion doesn't include the last line")
(SETQ REGION (RELGETREGION (IPLUS (TIMES 2 WBorder)
GWIDTH)
[IMIN 200 (IPLUS (FETCH (REGION HEIGHT) OF GRAPHREGION)
(ITIMES 2 (FONTHEIGHT DEFAULTFONT]
'RIGHT
'TOP]
[SETQ WINDOW (CREATEW REGION (CONCAT "Compare text" (CL:IF FILEPREFIX
(CONCAT " of " FILEPREFIX)
"")
" showing "
(CL:IF (GRAPHERPROP GRAPH 'ALLCHUNKS)
"all"
"only different")
" chunks, hashed by "
(SELECTQ (GRAPHERPROP GRAPH 'HASH.TYPE)
(PARA "paragraph")
(LINE "line")
(WORD "word")
(SHOULDNT]
(RELCREATEREGION WIDTH HEIGHT 'RIGHT 'TOP REGION)))
[SETQ WINDOW (CREATEW REGION (OR TITLE (CONCAT "Compare text" (CL:IF FILEPREFIX
(CONCAT " of " FILEPREFIX)
"")
" showing "
(CL:IF (GRAPHERPROP GRAPH 'ALLCHUNKS)
"all"
"only different")
" chunks, hashed by "
(SELECTQ (GRAPHERPROP GRAPH 'HASH.TYPE)
(PARA "paragraph")
(LINE "line")
(WORD "word")
(SHOULDNT]
(GETPROMPTWINDOW WINDOW)
(CL:WHEN (EQ GWIDTH (FETCH (REGION WIDTH) OF (WINDOWREGION WINDOW)))
(WINDOWPROP WINDOW 'MAXSIZE (CONS GWIDTH MAX.SMALLP)))
(CL:WHEN (EQ WIDTH (FETCH (REGION WIDTH) OF (WINDOWREGION WINDOW)))
(WINDOWPROP WINDOW 'MAXSIZE (CONS WIDTH MAX.SMALLP)))
(GETPROMPTWINDOW WINDOW)
[WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W)
(LET (TOBJ TWINDOW)
@@ -122,41 +130,37 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
WINDOW])
(COMPARETEXT.TEXTOBJ
[LAMBDA (NODE WINDOW INCOL1) (* ; "Edited 30-Dec-2021 21:21 by rmk")
[LAMBDA (NODE WINDOW INCOL1) (* ; "Edited 27-Jan-2022 13:14 by rmk")
(* ; "Edited 23-Jan-2022 16:51 by rmk")
(* ; "Edited 20-Jan-2022 22:29 by rmk")
(* ; "Edited 19-Jan-2022 08:52 by rmk")
(* ; "Edited 30-Dec-2021 21:21 by rmk")
(* ; "Edited 27-Dec-2021 15:56 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.")
(DECLARE (USEDFREE COMPARETEXT.AUTOTEDIT))
(LET (TEXTOBJ TSTREAM TWINDOW REGION (NODEID (FETCH (GRAPHNODE NODEID) OF NODE)))
(LET (TEXTOBJ TSTREAM TWINDOW REGION REGIONARGS (NODEID (FETCH (GRAPHNODE NODEID) OF NODE)))
(CL:UNLESS [AND [SETQ TEXTOBJ (WINDOWPROP WINDOW (CL:IF INCOL1
'COL1TEXTOBJ
'COL2TEXTOBJ)]
(OPENWP (WFROMDS (TEXTSTREAM TEXTOBJ]
(SETQ REGION (RELCREATEREGION 475 600 (CL:IF INCOL1
'RIGHT
'LEFT)
'TOP
(CL:IF INCOL1
`(,WINDOW 0.5 -1)
`(,WINDOW 0.5 1))
`(,WINDOW BOTTOM -2)
T))
(SETQ REGIONARGS (LIST 700 600 (CL:IF INCOL1
'RIGHT
'LEFT)
'TOP
`(,WINDOW 0.5 ,(CL:IF INCOL1
-1
1))
`(,WINDOW BOTTOM -2)
T))
(SETQ REGION (CL:IF COMPARETEXT.AUTOTEDIT
(RELCREATEREGION REGIONARGS)
(RELGETREGION REGIONARGS)))
[SETQ TSTREAM (TEXTSTREAM (TEDIT (CL:IF (FIXP (CAR NODEID))
(FETCH (IMCOMPARE.CHUNK FILENAME) of NODEID)
NODEID)
(IF COMPARETEXT.AUTOTEDIT
THEN
(* ;;
 "Just use it as created, don't prompt for adjustments")
REGION
ELSE (RELGETREGION REGION NIL (CL:IF INCOL1
'RIGHT
'LEFT)
'TOP))
NIL
`(READONLY T LEAVETTY T]
REGION NIL `(READONLY T LEAVETTY T]
(SETQ TWINDOW (WFROMDS TSTREAM))
(SETQ TEXTOBJ (TEXTOBJ TSTREAM))
(WINDOWPROP WINDOW (CL:IF INCOL1
@@ -173,20 +177,24 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
WINDOWPOSITION
W)))
TOBJ TW)
(CL:WHEN (SETQ TOBJ (WINDOWPROP
W
'COL1TEXTOBJ))
(MOVEW (SETQ TW (WFROMDS (TEXTSTREAM
TOBJ)))
(PTPLUS DELTA (WINDOWPOSITION
TW))))
(CL:WHEN (SETQ TOBJ (WINDOWPROP
W
'COL2TEXTOBJ))
(MOVEW (SETQ TW (WFROMDS (TEXTSTREAM
TOBJ)))
(PTPLUS DELTA (WINDOWPOSITION
TW))))
(CL:WHEN [AND (SETQ TOBJ
(WINDOWPROP W
'COL1TEXTOBJ))
(SETQ TW
(WFROMDS (TEXTSTREAM
TOBJ]
(MOVEW TW (PTPLUS DELTA (
WINDOWPOSITION
TW))))
(CL:WHEN [AND (SETQ TOBJ
(WINDOWPROP W
'COL2TEXTOBJ))
(SETQ TW
(WFROMDS (TEXTSTREAM
TOBJ]
(MOVEW TW (PTPLUS DELTA (
WINDOWPOSITION
TW))))
NIL])
TEXTOBJ])
@@ -246,7 +254,7 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(WINDOWPROP WINDOW 'LASTNODES (LIST NODE1 NODE2])
(IMCOMPARE.CHUNKS
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION FILELABELS) (* ; "Edited 25-Dec-2021 13:02 by rmk")
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION FILELABELS TITLE) (* ; "Edited 12-Jan-2022 10:06 by rmk")
(* ; "Edited 23-Dec-2021 00:02 by rmk")
(* ; "Edited 8-Sep-1984 00:06 by rmk")
@@ -302,11 +310,13 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(* ;; "The file comparison is complete. Format and display the file difference graph")
(IMCOMPARE.DISPLAYGRAPH CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS])
(IMCOMPARE.DISPLAYGRAPH CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS
TITLE])
(IMCOMPARE.COLLECT.HASH.CHUNKS
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 24-Dec-2021 22:30 by rmk")
(* ; "Edited 13-Dec-2021 16:32 by rmk")
[LAMBDA (CHUNK HASH.TYPE) (* ; "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:")
(* mjs " 8-Jan-84 20:57")
@@ -338,11 +348,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH)
of CHUNK)))
WHILE (SETQ CHUNK (IMCOMPARE.HASH STREAM HASH.TYPE ENDPOS))
COLLECT (REPLACE FILENAME OF CHUNK WITH FILENAME)
COLLECT (REPLACE (IMCOMPARE.CHUNK FILENAME) OF CHUNK WITH FILENAME)
CHUNK))])
(IMCOMPARE.DISPLAYGRAPH
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS)
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS TITLE)
(* ; "Edited 12-Jan-2022 09:58 by rmk")
(* ; "Edited 27-Dec-2021 11:58 by rmk")
(* ; "Edited 23-Dec-2021 00:14 by rmk")
(* mjs "11-Jul-85 09:10")
@@ -459,7 +470,7 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
COL1X
,COL1X COL2X ,COL2X ALLCHUNKS
,COMPARETEXT.ALLCHUNKS]
(SHOWGRAPH GRAPH (COMPARETEXT.WINDOW GRAPH REGION)
(SHOWGRAPH GRAPH (COMPARETEXT.WINDOW GRAPH REGION TITLE)
(FUNCTION IMCOMPARE.LEFTBUTTONFN)
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
T NIL])
@@ -770,12 +781,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
)
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1344 41549 (COMPARETEXT 1354 . 2933) (COMPARETEXT.WINDOW 2935 . 7132) (
COMPARETEXT.TEXTOBJ 7134 . 12023) (COMPARETEXT.SETSEL 12025 . 12815) (CHUNKNODELABEL 12817 . 13938) (
IMCOMPARE.BOXNODE 13940 . 14707) (IMCOMPARE.CHUNKS 14709 . 19062) (IMCOMPARE.COLLECT.HASH.CHUNKS 19064
. 21842) (IMCOMPARE.DISPLAYGRAPH 21844 . 29570) (IMCOMPARE.HASH 29572 . 33759) (
IMCOMPARE.MERGE.CONNECTED.CHUNKS 33761 . 37257) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 37259 . 39214) (
IMCOMPARE.SHOW.DIST 39216 . 39662) (IMCOMPARE.UPDATE.SYMBOL.TABLE 39664 . 41547)) (41550 47707 (
IMCOMPARE.LEFTBUTTONFN 41560 . 44137) (IMCOMPARE.MIDDLEBUTTONFN 44139 . 47255) (IMCOMPARE.COPYBUTTONFN
47257 . 47705)) (47760 48451 (TAIL1 47770 . 48124) (TAIL2 48126 . 48449)))))
(FILEMAP (NIL (1345 42591 (COMPARETEXT 1355 . 2855) (COMPARETEXT.WINDOW 2857 . 7675) (
COMPARETEXT.TEXTOBJ 7677 . 12786) (COMPARETEXT.SETSEL 12788 . 13578) (CHUNKNODELABEL 13580 . 14701) (
IMCOMPARE.BOXNODE 14703 . 15470) (IMCOMPARE.CHUNKS 15472 . 19848) (IMCOMPARE.COLLECT.HASH.CHUNKS 19850
. 22767) (IMCOMPARE.DISPLAYGRAPH 22769 . 30612) (IMCOMPARE.HASH 30614 . 34801) (
IMCOMPARE.MERGE.CONNECTED.CHUNKS 34803 . 38299) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 38301 . 40256) (
IMCOMPARE.SHOW.DIST 40258 . 40704) (IMCOMPARE.UPDATE.SYMBOL.TABLE 40706 . 42589)) (42592 48749 (
IMCOMPARE.LEFTBUTTONFN 42602 . 45179) (IMCOMPARE.MIDDLEBUTTONFN 45181 . 48297) (IMCOMPARE.COPYBUTTONFN
48299 . 48747)) (48802 49493 (TAIL1 48812 . 49166) (TAIL2 49168 . 49491)))))
STOP