Compare commits
18 Commits
medley-220
...
medley-220
| Author | SHA1 | Date | |
|---|---|---|---|
|
c5eb54a3dc | ||
|
|
3c7fb08932 | ||
|
f262c98f53 | ||
|
|
9c8d9df1ac | ||
|
|
894ecd6d0c | ||
|
|
7eb0f28db4 | ||
|
d3d2534eb1 | ||
|
|
b9994581d4 | ||
|
|
ff29872150 | ||
|
cb122f4c58 | ||
|
|
205de6fd1b | ||
|
|
45b4edf040 | ||
|
|
51d9e995e1 | ||
|
|
4910ea5660 | ||
|
|
59f71f04c2 | ||
|
|
107ea72a67 | ||
|
|
48ebc675a7 | ||
|
|
d2ce98d131 |
@@ -1,12 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "12-Mar-2022 12:46:25"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>internal>MEDLEY-UTILS.;2| 12734
|
||||
(FILECREATED "31-May-2022 09:37:37" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;3| 12695
|
||||
|
||||
:CHANGES-TO (FNS MAKE-WHEREIS-HASH)
|
||||
:CHANGES-TO (FNS HCFILES)
|
||||
|
||||
:PREVIOUS-DATE "20-Feb-2022 12:59:27"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>internal>MEDLEY-UTILS.;1|)
|
||||
:PREVIOUS-DATE "12-Mar-2022 12:46:25" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;1|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
@@ -161,58 +159,65 @@
|
||||
(DEFINEQ
|
||||
|
||||
(HCFILES
|
||||
(LAMBDA (TFILE PREFIX DEST REDOFLG TOPDIRLEN) (* \; "Edited 20-Feb-2022 12:16 by larry")
|
||||
(LAMBDA (TFILE DEST REDOFLG TOPDIRLEN) (* \; "Edited 31-May-2022 09:31 by larry")
|
||||
(* \; "Edited 20-Feb-2022 12:16 by larry")
|
||||
(* \; "Edited 21-Aug-2021 20:56 by larry")
|
||||
(DECLARE (SPECVARS TFILE))
|
||||
(|if| (NULL TFILE)
|
||||
|then| (SETQ TFILE MEDLEYDIR))
|
||||
(COND
|
||||
((NULL TFILE)
|
||||
(HCFILES MEDLEYDIR))
|
||||
((DIRECTORYNAMEP TFILE)
|
||||
|
||||
(* |;;| "canonicalize")
|
||||
|
||||
(SETQ TFILE (DIRECTORYNAME TFILE))
|
||||
(OR TOPDIRLEN (SETQ TOPDIRLEN (IPLUS 1 (CL:LENGTH (MKSTRING (FILENAMEFIELD TFILE 'DIRECTORY))
|
||||
))))
|
||||
(OR DEST (SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T)))
|
||||
(OR TOPDIRLEN (SETQ TOPDIRLEN (CL:LENGTH (FILENAMEFIELD.STRING TFILE 'DIRECTORY))))
|
||||
(CL:UNLESS DEST
|
||||
(|ShellCommand| (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR")
|
||||
"/tmp/psfiles/"))
|
||||
(SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T)))
|
||||
|
||||
(* |;;| "first deal with files in this directory")
|
||||
|
||||
(|for| X |in| (|if| (EQ REDOFLG 'REV)
|
||||
|then| (REVERSE (DIRECTORY (CONCAT TFILE "*.TED*;")))
|
||||
|else| (DIRECTORY (CONCAT TFILE "*.TED*;")))
|
||||
|do| (HCFILES X PREFIX DEST REDOFLG TOPDIRLEN))
|
||||
(|for| X |in| (DIRECTORY (CONCAT TFILE "*.TED*;")) |do| (HCFILES X DEST REDOFLG TOPDIRLEN))
|
||||
|
||||
(* |;;| " then deal with subdirs ")
|
||||
|
||||
(|for| X |in| (|if| (EQ REDOFLG 'REV)
|
||||
|then| (REVERSE (DIRECTORY (CONCAT TFILE "*")))
|
||||
|else| (DIRECTORY (CONCAT TFILE "*")))
|
||||
(|for| X |in| (DIRECTORY (CONCAT TFILE "*"))
|
||||
|when| (|for| SKIP |in| '(">." ">dinfo>") |always| (NOT (STRPOS SKIP (L-CASE X))))
|
||||
|when| (DIRECTORYNAMEP X) |do| (HCFILES X PREFIX DEST REDOFLG TOPDIRLEN)))
|
||||
|when| (DIRECTORYNAMEP X) |do| (HCFILES X DEST REDOFLG TOPDIRLEN)))
|
||||
((SETQ TFILE (INFILEP TFILE))
|
||||
(PROG ((PSFILE (PACKFILENAME.STRING 'EXTENSION (|if| (EQ REDOFLG 'IP)
|
||||
|then| 'IP
|
||||
|else| "PS")
|
||||
'NAME
|
||||
(CONCAT (OR PREFIX "")
|
||||
(|if| PREFIX
|
||||
|then| "-"
|
||||
|else| "")
|
||||
(PACK (SUBST '- '> (UNPACK (SUBSTRING (FILENAMEFIELD
|
||||
TFILE
|
||||
'DIRECTORY)
|
||||
(IPLUS 1 TOPDIRLEN)
|
||||
-1))))
|
||||
"-"
|
||||
(FILENAMEFIELD TFILE 'NAME))
|
||||
'DIRECTORY DEST))
|
||||
(LET* ((TF (UNPACKFILENAME.STRING TFILE))
|
||||
(NAME (LISTGET TF 'NAME))
|
||||
(DIR (LISTGET TF 'DIRECTORY))
|
||||
(PSFILE (PACKFILENAME.STRING
|
||||
'EXTENSION
|
||||
(|if| (EQ REDOFLG 'IP)
|
||||
|then| "IP"
|
||||
|else| "PS")
|
||||
'NAME
|
||||
(|if| (EQ DEST T)
|
||||
|then| (* \; "with the tedit file")
|
||||
NAME
|
||||
|else| (CONCAT (PACK (SUBST '- '> (UNPACK (SUBSTRING DIR (IPLUS 2 TOPDIRLEN
|
||||
)
|
||||
-1))))
|
||||
"-" NAME))
|
||||
'HOST
|
||||
(LISTGET TF 'HOST)
|
||||
'DIRECTORY
|
||||
(|if| (EQ DEST T)
|
||||
|then| DIR
|
||||
|else| DEST)))
|
||||
(TEXTSTREAM))
|
||||
(|if| (AND (NOT REDOFLG)
|
||||
(INFILEP PSFILE))
|
||||
|then| (* \; " do nothing")
|
||||
(PRINTOUT T PSFILE " already there" T)
|
||||
|elseif| (EQ REDOFLG 'TEST)
|
||||
|then| (PRINTOUT T "TESTING " TFILE)
|
||||
|then| (PRINTOUT T TFILE "-> " PSFILE T)
|
||||
(CLOSEF (OPENTEXTSTREAM TFILE))
|
||||
|else| (PRINTOUT T "Converting " TFILE "...")
|
||||
|else| (PRINTOUT T "Converting " TFILE " to " PSFILE "...")
|
||||
(TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM TFILE))
|
||||
PSFILE T NIL NIL NIL (|if| (EQ REDOFLG 'IP)
|
||||
|then| 'INTERPRESS
|
||||
@@ -224,7 +229,7 @@
|
||||
|
||||
(RPAQ? HCFILES )
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (753 7201 (GATHER-INFO 763 . 6303) (MEDLEY-FIX-LINKS 6305 . 6828) (MEDLEY-FIX-DATES 6830
|
||||
. 7199)) (7300 9150 (MAKE-EXPORTS-ALL 7310 . 8326) (MAKE-WHEREIS-HASH 8328 . 9148)) (9185 12689 (
|
||||
HCFILES 9195 . 12687)))))
|
||||
(FILEMAP (NIL (699 7147 (GATHER-INFO 709 . 6249) (MEDLEY-FIX-LINKS 6251 . 6774) (MEDLEY-FIX-DATES 6776
|
||||
. 7145)) (7246 9096 (MAKE-EXPORTS-ALL 7256 . 8272) (MAKE-WHEREIS-HASH 8274 . 9094)) (9131 12650 (
|
||||
HCFILES 9141 . 12648)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
546
internal/TESTUPF
Normal file
546
internal/TESTUPF
Normal file
@@ -0,0 +1,546 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-May-2022 12:30:29"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>TESTUPF.;1 32843 )
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TESTUPFCOMS)
|
||||
|
||||
(RPAQQ TESTUPFCOMS
|
||||
((COMS (* ; "Original code")
|
||||
(FNS OLD-UNPACKFILENAME.STRING \UPF.NEXTPOS \UPF.TEMPFILEP)
|
||||
(DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY UNPACKFILE1)))
|
||||
|
||||
(* ;; "Debugging")
|
||||
|
||||
|
||||
(* ;; "DOTTEDNAMES: mismatch intended")
|
||||
|
||||
|
||||
(* ;; "RETURNFAILS: mismatch with DIRFLG=RETURN, DIRECTORY and SUBDIRECTORY are swapped. But original doesn't agree with its own complete analaysis.")
|
||||
|
||||
(VARS DOTTEDNAMES TESTS RETURNFAILS)
|
||||
(FNS TRY TRYALL DT)))
|
||||
|
||||
|
||||
|
||||
(* ; "Original code")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(OLD-UNPACKFILENAME.STRING
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 25-Jan-2022 17:16 by rmk")
|
||||
(* ; "Edited 5-Jan-2022 11:03 by rmk")
|
||||
(* ; "Edited 30-Mar-90 22:37 by nm")
|
||||
|
||||
(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts")
|
||||
|
||||
(* ;;; "rmk: devices must come before directories.")
|
||||
|
||||
(PROG ((POS 1)
|
||||
(LEN (NCHARS FILE))
|
||||
TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI)
|
||||
(COND
|
||||
((NULL FILE)
|
||||
(RETURN NIL))
|
||||
((OR (LITATOM FILE)
|
||||
(STRINGP FILE)
|
||||
(NUMBERP FILE)))
|
||||
((TYPEP FILE 'PATHNAME)
|
||||
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
|
||||
[(STREAMP FILE) (* ;
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
|
||||
(RETURN (COND
|
||||
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
|
||||
FILE))
|
||||
(T (LIST 'NAME FILE]
|
||||
(T (\ILLEGAL.ARG FILE)))
|
||||
(COND
|
||||
((SELCHARQ (NTHCHARCODE FILE 1)
|
||||
({ (* ; "normal use in Interlisp-D")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
|
||||
FILE 2)
|
||||
0))))
|
||||
(%[ (* ;
|
||||
"some Xerox and Arpanet systems use '[' for host")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
|
||||
FILE 2)
|
||||
0))))
|
||||
(%( (* ;
|
||||
"this is the 'proposed standard' for Xerox servers")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
|
||||
FILE 2)
|
||||
0))))
|
||||
NIL)
|
||||
(UNPACKFILE1 'HOST 2 TEM)
|
||||
[COND
|
||||
((EQ TEM -1) (* ;
|
||||
"Started with the host field delimiter, but there was no corresponding terminating delimiter .")
|
||||
(* ;
|
||||
"I'm not sure why the name is dealt with the host name.")
|
||||
(RETURN (DREVERSE VAL]
|
||||
(SETQ POS (IPLUS TEM 2))
|
||||
[if (EQ OSTYPE T)
|
||||
then (* ;
|
||||
"Use actual host to determine os type")
|
||||
(SETQ OSTYPE (GETHOSTINFO (CAR VAL)
|
||||
'OSTYPE]
|
||||
(SETQ HOSTP T)))
|
||||
|
||||
(* ;; "rmk: if there is a colon before the next < or /, then we must be looking at a device. A device appears to end after the last colon, i.e., a device name can have a colon inside it.")
|
||||
|
||||
(COND
|
||||
((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /))
|
||||
FILE POS))
|
||||
(EQ (CHARCODE %:)
|
||||
(NTHCHARCODE FILE TEM))) (* ;
|
||||
"all device returned have DEVICE.END on it so that NIL: will work")
|
||||
(UNPACKFILE1 'DEVICE POS (if CLFLG
|
||||
then (SUB1 TEM)
|
||||
else TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SETQ HOSTP T)))
|
||||
(COND
|
||||
((EQ DIRFLG 'RETURN) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")
|
||||
(LET ((TYPE 'DIRECTORY)
|
||||
(START (SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(NIL (* ; "just host, return")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((/ <) (* ;
|
||||
"Started with the initial directory delimiter.")
|
||||
(ADD1 POS))
|
||||
POS))
|
||||
END)
|
||||
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
|
||||
((/ >)
|
||||
[COND
|
||||
((EQ START POS) (* ;
|
||||
"Didn't start with a directory delimiter,")
|
||||
(COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
|
||||
(SETQ TYPE 'SUBDIRECTORY))
|
||||
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(COND
|
||||
((EQ LEN POS) (* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}/%").")
|
||||
(SETQ START POS)
|
||||
-1)
|
||||
(T -2)))
|
||||
(PROGN [COND
|
||||
[(EQ START POS) (* ;
|
||||
"Both of the initial and trail delimiters are omitted.")
|
||||
(COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
|
||||
(SETQ TYPE 'SUBDIRECTORY))
|
||||
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(T (COND
|
||||
((EQ LEN POS)
|
||||
(* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}<%").")
|
||||
(SETQ START POS]
|
||||
-1)))
|
||||
(UNPACKFILE1.DIRECTORY TYPE START END))
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(/ (* ;
|
||||
"unix and the 'xerox standard' use / for delimiter")
|
||||
(* ;
|
||||
"In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (/ >))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
T)
|
||||
((< >) (* ;
|
||||
"Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
|
||||
(* ;
|
||||
"In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
T)
|
||||
NIL)
|
||||
|
||||
(* ;; "allow {DSK}/etc to be a directory specification.")
|
||||
|
||||
(if TEM
|
||||
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
|
||||
(SUB1 TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
else
|
||||
(* ;; "{DSK}/foo: the directory is /, the name is foo")
|
||||
|
||||
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
|
||||
(SETQ POS (ADD1 POS)))
|
||||
(SETQ HOSTP T))
|
||||
((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
|
||||
FILE POS)) (* ; " {eris}abc> relative")
|
||||
|
||||
(* ;;
|
||||
" This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
|
||||
|
||||
[COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
|
||||
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
|
||||
then 'DIRECTORY
|
||||
else 'SUBDIRECTORY)
|
||||
POS
|
||||
(SUB1 TEM)))
|
||||
(T (* ; "True %"relative pathname%".")
|
||||
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
|
||||
then 'DIRECTORY
|
||||
else 'RELATIVEDIRECTORY)
|
||||
POS
|
||||
(SUB1 TEM]
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SETQ HOSTP T)))
|
||||
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(if (EQ OSTYPE T)
|
||||
then (* ;
|
||||
"There wasn't a host field in the name, so we have no clue")
|
||||
(SETQ OSTYPE NIL))
|
||||
NAMELP
|
||||
|
||||
|
||||
(* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.")
|
||||
|
||||
(SELCHARQ CODE
|
||||
(%. (* ;
|
||||
"Note position for later--we only want to deal with the last set of dots")
|
||||
(if BEYONDNAME
|
||||
then (* ;
|
||||
"no longer of interest (probably a bad name, too)")
|
||||
elseif FIRSTDOT
|
||||
then (* ; "We're recording the second dot")
|
||||
(if SECONDDOT
|
||||
then (* ;
|
||||
"Note only the two most recent dots")
|
||||
(SETQ FIRSTDOT SECONDDOT))
|
||||
(SETQ SECONDDOT TEM)
|
||||
else (SETQ FIRSTDOT TEM)))
|
||||
((! ; NIL) (* ;
|
||||
"SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
|
||||
(if (SELCHARQ CODE
|
||||
(! (* ;
|
||||
"! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
|
||||
(AND OSTYPE (NEQ OSTYPE 'IFS)))
|
||||
(; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S")
|
||||
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
|
||||
NIL)
|
||||
then (GO NEXTCHAR))
|
||||
(if FIRSTDOT
|
||||
then (* ;
|
||||
"Have a name and/or extension to parse now")
|
||||
(if
|
||||
[AND SECONDDOT
|
||||
(NOT (if OSTYPE
|
||||
then (* ;
|
||||
"Known OS type must be Tops20 for second dot to mean version")
|
||||
(EQ OSTYPE 'TOPS20)
|
||||
else (* ;
|
||||
"Unknown OS type, so check that %"version%" is numeric or wildcard")
|
||||
(AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM)
|
||||
bind CH
|
||||
always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I
|
||||
)))
|
||||
(EQ CH (CHARCODE *]
|
||||
(SELCHARQ CODE
|
||||
(NIL (* ; "end of file name, ok")
|
||||
T)
|
||||
(; (* ;
|
||||
"This semi-colon better not be introducing a version")
|
||||
(\UPF.TEMPFILEP FILE (ADD1 TEM)))
|
||||
NIL]
|
||||
then (* ;
|
||||
"Second dot is not intoducing a version")
|
||||
(SETQ FIRSTDOT SECONDDOT)
|
||||
(SETQ SECONDDOT NIL))
|
||||
(UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
|
||||
(SETQ POS (ADD1 (if SECONDDOT
|
||||
then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
|
||||
(SUB1 SECONDDOT))
|
||||
(SETQ BEYONDEXT T)
|
||||
SECONDDOT
|
||||
else FIRSTDOT)))
|
||||
(SETQ BEYONDNAME T)
|
||||
(SETQ FIRSTDOT NIL))
|
||||
(UNPACKFILE1 (COND
|
||||
((NOT BEYONDNAME)
|
||||
(SETQQ BEYONDNAME NAME))
|
||||
((NOT BEYONDEXT)
|
||||
'EXTENSION)
|
||||
((AND (EQ BEYONDEXT (CHARCODE ";"))
|
||||
(\UPF.TEMPFILEP FILE POS)))
|
||||
(T (* ;
|
||||
"Everything after the semi was version")
|
||||
'VERSION))
|
||||
POS
|
||||
(SUB1 TEM))
|
||||
(if (NULL CODE)
|
||||
then (* ; "End of string")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(SETQ BEYONDEXT CODE) (* ;
|
||||
"Note the character that terminated the name/ext")
|
||||
(SETQ POS (ADD1 TEM)))
|
||||
(%' (* ; "Quoter")
|
||||
(add TEM 1))
|
||||
NIL)
|
||||
NEXTCHAR
|
||||
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
|
||||
(GO NAMELP])
|
||||
|
||||
(\UPF.NEXTPOS
|
||||
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
|
||||
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND
|
||||
((EQMEMB NCH CHAR)
|
||||
(RETURN POS))
|
||||
((EQ NCH (CHARCODE %'))
|
||||
(add POS 1)))
|
||||
(add POS 1])
|
||||
|
||||
(\UPF.TEMPFILEP
|
||||
[LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:")
|
||||
|
||||
(* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.")
|
||||
|
||||
(SELCHARQ (NTHCHARCODE FILENAME START)
|
||||
((T S) (* ; "Funny temp stuff")
|
||||
(AND (EQ START (NCHARS FILENAME))
|
||||
'TEMPORARY))
|
||||
NIL])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS CANONICAL.DIRECTORY MACRO
|
||||
[OPENLAMBDA (SRCSTRING)
|
||||
(AND
|
||||
SRCSTRING
|
||||
(LET
|
||||
((LEN (NCHARS SRCSTRING)))
|
||||
(COND
|
||||
((EQ LEN 1)
|
||||
(if (STREQUAL SRCSTRING "/")
|
||||
then "<"
|
||||
else SRCSTRING))
|
||||
(T
|
||||
(LET*
|
||||
((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
|
||||
(DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
|
||||
(DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
|
||||
(DSTPOS 0)
|
||||
(NEXTPOS -1))
|
||||
(if (NOT FATP)
|
||||
then [for SRCPOS from 1 to LEN bind CODE
|
||||
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
|
||||
(CHARCODE (< / >))) do (add SRCPOS 1))
|
||||
(if (> SRCPOS LEN)
|
||||
then (RETURN "<"))
|
||||
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
|
||||
((> /)
|
||||
(if (> DSTPOS NEXTPOS)
|
||||
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
|
||||
(SETQ NEXTPOS (add DSTPOS 1))))
|
||||
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)
|
||||
(if (NEQ SRCPOS LEN)
|
||||
then (\PUTBASETHIN DSTBASE DSTPOS
|
||||
(NTHCHARCODE SRCSTRING (add SRCPOS 1)))
|
||||
(add DSTPOS 1)))
|
||||
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)))
|
||||
finally (RETURN (if (EQ DSTPOS LEN)
|
||||
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 -2)
|
||||
else DSTSTRING)
|
||||
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
|
||||
else (SUBSTRING DSTSTRING 1 DSTPOS]
|
||||
else (for SRCPOS from 1 to LEN bind CODE
|
||||
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
|
||||
(CHARCODE (< / >))) do (add SRCPOS 1))
|
||||
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
|
||||
((> /)
|
||||
(if (> DSTPOS NEXTPOS)
|
||||
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
|
||||
(SETQ NEXTPOS (add DSTPOS 1))))
|
||||
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)
|
||||
(if (NEQ SRCPOS LEN)
|
||||
then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE
|
||||
SRCSTRING
|
||||
(add SRCPOS 1)))
|
||||
(add DSTPOS 1)))
|
||||
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)))
|
||||
finally (RETURN (if (EQ DSTPOS LEN)
|
||||
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 -2)
|
||||
else DSTSTRING)
|
||||
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
|
||||
else (SUBSTRING DSTSTRING 1 DSTPOS])
|
||||
|
||||
(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
|
||||
(LET* ((OLDDIR (SUBSTRING FILE ST END))
|
||||
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (AND NEWDIR
|
||||
(MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR "")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR ""])
|
||||
|
||||
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
"")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
""])
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Debugging")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;; "DOTTEDNAMES: mismatch intended")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"RETURNFAILS: mismatch with DIRFLG=RETURN, DIRECTORY and SUBDIRECTORY are swapped. But original doesn't agree with its own complete analaysis."
|
||||
)
|
||||
|
||||
|
||||
(RPAQQ DOTTEDNAMES (".x" ">.git" "x.y.100"))
|
||||
|
||||
(RPAQQ TESTS
|
||||
("*,;" "*.*;*" "*.;" "*.;*" "///abc/x" "/abc.x" "<" "<<<abc" "<<<abc>" "<<<abc>>" "<<<abc>x"
|
||||
"<<abc" "<<xyz>>>zz" "<<xyz>>>zzz/" "<<xyz>>zz" "<<xyz>zz" "<ABC>" "<XYZ>aa" "<a.b>"
|
||||
"<a;b>" "<ab;c" "<ab>" "<abc" "<abc*." "<abc.x" "<abc.x;1" "<abc;x" "<abc<<<x"
|
||||
"<abc<xyz<foo" "<abc<xyz>qrs" "<abc>" "<abc>;1" "<abc>xyz" "<abc>xyz>foo" "<xxx"
|
||||
"<xy>>zz" "<xyz>>>zzz/" ">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx"
|
||||
"A.B.C" "XXX<yyy" "a;b" "a;b/d" "a;b;c" "a;b;c;d" "aa" "aa;" "aa;NEWEST" "aa;newest"
|
||||
"aaa" "aaa/bbb" "aaa/bbb/" "aaa/xyz;x;m" "aaa<bbb" "aaa<bbb/" "aaa<xyz>" "aaa>bbb>"
|
||||
"aaa>xyz.e;m;n" "aaa>xyz>qrs" "abc" "abc...c" "abc///XYZ//" "abc/d" "abc/xyz"
|
||||
"abc/xyz.qrs" "abc/xyz.qrs;2" "abc:x<qrs>z" "abc<<<XYZ//" "abc<x" "abc<xyz"
|
||||
"abc<xyz>qq" "abc<xyzqq" "abc>;1" "abc>qr.x" "abc>xy" "abc>xyz" "abc>xyz;2"
|
||||
"dev:aaa>xyz>qrs" "foo:" "foo:aaa<xyz" "foo:aaa<xyz>" "foo:x<qrs>z" "foo<a:B>" "s;n;b"
|
||||
"x.y.z;w" "x.y;z" "x;y" "x<abc<xyz>qrs" "x<abc<z" "x<abc>z" "xxx<yyy" "xxx<yyy>"
|
||||
"xxx<yyy>zzz" "xxx>yyy" "xxx>yyy>" "{ABC}" "{ABC}XXX:" "{DSK}" "{DSK}*.;*" "{DSK}...<a"
|
||||
"{DSK}<a" "{DSK}xxx<a" "{DSK}xxx<xxx>yyy" "{DSK}xxx>xxx" "{DSK}xxx>yyy"
|
||||
"{HOST}foo:x<qrs>z" "{HOST}x<qrs>z" "{abc}" "{dsk}foo:aaa>b>.c.e.g;f"
|
||||
"{dsk}foo:aaa>b>.c.e;f" "{dsk}foo:aaa>b>c.e;f" "{eris}abc>" "{host}abc/xyz;2"
|
||||
"{host}abc>xyz;2" "{x}abc<xyz>qq" "{x}abc<xyzqq" "<abc<xyz>abc" "<abc<xyz>qrs"
|
||||
"<abc<xyz>"))
|
||||
|
||||
(RPAQQ RETURNFAILS (">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx" ">" ">>>abc/x"
|
||||
">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx"))
|
||||
(DEFINEQ
|
||||
|
||||
(TRY
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG) (* ; "Edited 23-May-2022 12:09 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 14:15 by rmk")
|
||||
(* ; "Edited 24-Apr-2022 08:45 by rmk")
|
||||
(* ; "Edited 21-Apr-2022 15:36 by rmk")
|
||||
(CL:WHEN (LISTP (CAR (LISTP FILE)))
|
||||
(SETQ FILE (CAR FILE)))
|
||||
(LET (ORIG NEW)
|
||||
(CL:WHEN (LISTP FILE)
|
||||
(SETQ ONEFIELDFLG (CADR FILE))
|
||||
(SETQ DIRFLG (CADDR FILE))
|
||||
(SETQ FILE (CAR FILE)))
|
||||
(SETQ ORIG (OLD-UNPACKFILENAME.STRING FILE ONEFIELDFLG DIRFLG))
|
||||
(SETQ NEW (UNPACKFILENAME.STRING FILE ONEFIELDFLG DIRFLG))
|
||||
(LIST (LIST FILE ONEFIELDFLG DIRFLG)
|
||||
(AND (EQUAL ORIG NEW)
|
||||
'=)
|
||||
ORIG NEW])
|
||||
|
||||
(TRYALL
|
||||
[LAMBDA (FILES ALLFLAG ONEFIELDFLG DIRFLG) (* ; "Edited 21-Apr-2022 17:56 by rmk")
|
||||
(* ; "Edited 2-Apr-2022 23:50 by rmk")
|
||||
(* ; "Edited 31-Mar-2022 22:57 by rmk")
|
||||
(CL:WHEN (LISTP FILES)
|
||||
(SETQ FILES (FOR F IN FILES COLLECT (CL:IF (LISTP (CAR (LISTP F)))
|
||||
(CAR F)
|
||||
F))))
|
||||
(FOR FILE INFO (SAME _ 0)
|
||||
(DIFF _ 0) IN FILES EACHTIME (SETQ INFO (TRY FILE ONEFIELDFLG DIRFLG))
|
||||
(CL:IF (CADR INFO)
|
||||
(ADD SAME 1)
|
||||
(ADD DIFF 1)) UNLESS (AND (CADR INFO)
|
||||
(NOT ALLFLAG))
|
||||
COLLECT (PRINTOUT T .P2 (CAAR INFO)
|
||||
31)
|
||||
(IF (CADR INFO)
|
||||
THEN (PRINTOUT T " = " .P2 (CADDR INFO))
|
||||
(CL:WHEN (OR (CADAR INFO)
|
||||
(CADDAR INFO))
|
||||
(PRINTOUT T 60 (CADAR INFO)
|
||||
%,,
|
||||
(CADDAR INFO))
|
||||
(TERPRI T))
|
||||
ELSE (PRINTOUT T " ~= " -2 "old: " .P2 (CADDR INFO))
|
||||
(CL:WHEN (OR (CADAR INFO)
|
||||
(CADDAR INFO))
|
||||
(PRINTOUT T 60 (CADAR INFO)
|
||||
%,,
|
||||
(CADDAR INFO))
|
||||
(TERPRI T))
|
||||
(PRINTOUT T 37 "new: " .P2 (CADDDR INFO)
|
||||
T))
|
||||
INFO FINALLY (PRINTOUT T SAME " matches, " DIFF " mismatches" T])
|
||||
|
||||
(DT
|
||||
[LAMBDA (STRINGS ALLFLAG) (* ; "Edited 21-Apr-2022 17:53 by rmk")
|
||||
(* ; "Edited 19-Apr-2022 20:55 by rmk")
|
||||
|
||||
(* ;; "Tests the DIRFLG options on STRINGS. If an element of STRINGS is a list, it is assumed to be a (STRING ONEFIELD DIRFLG), STRING is extracted.")
|
||||
|
||||
(SETQ STRINGS (FOR S INSIDE STRINGS COLLECT (CL:IF (LISTP S)
|
||||
(CAR S)
|
||||
S)))
|
||||
[AND NIL (FOR ONEFIELD IN '(NAME DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY)
|
||||
JOIN (FOR DIR ORIG NEW SAME IN '(FIELD RETURN)
|
||||
JOIN (PRINTOUT T T "ONEFIELDFLG = " ONEFIELD -3 "DIRFLG = " DIR T T)
|
||||
(TRYALL STRINGS ALLFLAG ONEFIELD DIR))
|
||||
FINALLY (FOR INFO SAME (DIFF _ 0) IN $$VAL DO (CL:IF (CADR INFO)
|
||||
(ADD SAME 1)
|
||||
(ADD DIFF 1))
|
||||
FINALLY (SETQ SAME (IDIFFERENCE (LENGTH STRINGS)
|
||||
DIFF))
|
||||
(PRINTOUT T T "Overall: " SAME " matched, " DIFF " mismatched" T]
|
||||
(TRYALL (FOR S IN STRINGS JOIN (FOR ONEFIELD IN '(NAME DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY)
|
||||
JOIN (FOR DIR IN '(FIELD RETURN)
|
||||
COLLECT (LIST S ONEFIELD DIR])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (893 18981 (OLD-UNPACKFILENAME.STRING 903 . 17808) (\UPF.NEXTPOS 17810 . 18396) (
|
||||
\UPF.TEMPFILEP 18398 . 18979)) (28216 32820 (TRY 28226 . 29192) (TRYALL 29194 . 31111) (DT 31113 .
|
||||
32818)))))
|
||||
STOP
|
||||
BIN
internal/TESTUPF.LCOM
Normal file
BIN
internal/TESTUPF.LCOM
Normal file
Binary file not shown.
23
internal/TESTUPF.TXT
Normal file
23
internal/TESTUPF.TXT
Normal file
@@ -0,0 +1,23 @@
|
||||
TESTUPF contains functions for testing the new implementation of UNPACKFILENAME.STRING (now in ADIR) and the original definition.
|
||||
|
||||
The original definition is also provided here, under the name OLD-UNPACKFILENAME.STRING
|
||||
|
||||
TESTUPF also includes some test functions, and some of the strings that I have been testing with.
|
||||
|
||||
(TRY FILE ONEDIRFLG DIRFLG)
|
||||
|
||||
returns a comparison of the behavior of the original version and the new version in a list of the form
|
||||
|
||||
(FILE ONEDIRFLG DIRFLG) MATCH ORIG NEW)
|
||||
|
||||
where MATCH is = if ORIG and NEW are EQUAL, otherwise NIL. (For convenience, a list of this form can also be passed in as an argument.)
|
||||
|
||||
(TRYALL FILES ALLFLG ONDIRFLG DIRFLG)
|
||||
|
||||
applies TRY to each file-string in FILES, prints and reports what it discovers. If ALLFLG, it prints the result on every file, otherwise just the mismatches. Value is a list of TRY values that it printed.
|
||||
|
||||
(DT FILES) sets up a call to TRYALL for DIRFLG testing (setting DIRFLG NIL, FIELD, RETURN for each file in FILES).
|
||||
|
||||
The variable TESTS has the strings that I have tested against, the variable DOTTEDNAMES has the strings that I intend to be different (.cshrc as NAME, not EXTENSION). The new behavior avoids the bug that (PACKFILENAME.STRING 'EXTENSION "txt "BODY ".bashrc") produces ".txt" instead of ".bashrc.txt".
|
||||
|
||||
The variable RETURNFAILS is a list of strings with DIRFLG=RETURN that also don¹t match, in that the DIRECTORY and SUBDIRECTORY classifications are inverted between old and new for strings beginning with ª>". But the old code is inconsistent for these inputs: it returns different classifications of those substrings with or without the RETURN. (I think RETURN is for the case "/Users/kaplan" where the caller knows that the whole thing is a directory, doesn¹t want ªkaplanº to be parsed as a name. Just wants it to be normalized, with host and device stripped off.)
|
||||
@@ -4,13 +4,13 @@ Written by Ron Kaplan, 2020-2021
|
||||
|
||||
A small package that implements copy and paste to the system clipboard.
|
||||
|
||||
It arms meta-C for copy to the clipboard from the current selection of an application that has been armed (Tedit, Sedit), and also meta-X for extraction (copy followed by delete).
|
||||
For Tedit, Sedit, and perhaps other applications, meta-C is armed for copy to the clipboard from the current selection, and also meta-X is armed for extraction (copy followed by delete).
|
||||
|
||||
Meta-V is defined as an interrupt character that pastes the current clipboard contents into whatever process curent has input focus.
|
||||
Meta-V is defined as an interrupt character that pastes the current clipboard contents into whatever process currently has input focus.
|
||||
|
||||
The information in the clipboard can be provided from or provided to external (non-Medley) applications (mail, emacs, etc.) in the usual way. For example, a form cselected in SEDIT can be copied to the clipboard and pasted into an email message.
|
||||
The information in the clipboard can be provided from or provided to external (non-Medley) applications (mail, emacs, etc.) in the usual way. For example, a form selected in SEDIT can be copied to the clipboard and pasted into an email message.
|
||||
|
||||
It assumes that the clipboard is a utf-8/unicode stream, and uses the UNICODE package to convert to and from the Medley internal character encoding (XCCS).
|
||||
It assumes that the clipboard is a UTF-8/Unicode stream, and uses the UNICODE package to convert to and from the Medley internal character encoding (XCCS).
|
||||
|
||||
The name of the clipboard stream may differ from platform to platform. On the Mac, the paste stream is "pbpaste" and the copy stream is "pbcopy". Those names are used if "darwin" is a substring of (UNIX-GETENV "ostype"). Otherwise both stream-names default to "xclip". The functions CLIPBOARD-COPY-STREAM and CLIPBOARD-PASTE-STREAM perform this selection.
|
||||
|
||||
|
||||
115
library/TEDIT
115
library/TEDIT
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Dec-2021 20:50:54" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;30 142870
|
||||
(FILECREATED " 6-Jun-2022 00:36:53"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>library>TEDIT.;40 143378
|
||||
|
||||
:CHANGES-TO (FNS TEDIT TEDIT-SEE)
|
||||
:CHANGES-TO (FNS TEDIT)
|
||||
|
||||
:PREVIOUS-DATE "28-Dec-2021 11:02:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;24)
|
||||
:PREVIOUS-DATE " 4-Jun-2022 15:43:05"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>library>TEDIT.;39)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -31,12 +32,12 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
)
|
||||
(GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
|
||||
(FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT-SEE TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE
|
||||
TEDIT.DO.BLUEPENDINGDELETE TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES
|
||||
TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE
|
||||
\TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN \TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN
|
||||
\TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE \TEDIT.DIFFUSE.PARALOOKS
|
||||
\TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1)
|
||||
(FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDITSTRING TEDIT-SEE TEDIT.CHARWIDTH TEDIT.COPY
|
||||
TEDIT.DELETE TEDIT.DO.BLUEPENDINGDELETE TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES
|
||||
TEDIT.MAPPIECES TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH TEDIT.\INSERT TEXTOBJ TEXTSTREAM
|
||||
\TEDIT.INCLUDE \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN \TEDIT.OBJECT.SHOWSEL
|
||||
\TEDIT.RESTARTFN \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE
|
||||
\TEDIT.DIFFUSE.PARALOOKS \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1)
|
||||
(P (MOVD? 'NILL 'OBJECTOUTOFTEDIT))
|
||||
(* ;
|
||||
"HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
|
||||
@@ -250,22 +251,35 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
NIL])
|
||||
|
||||
(TEDIT
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 30-Dec-2021 20:50 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 00:12 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
(* ; "Edited 11-Jun-99 14:14 by rmk:")
|
||||
(* ; "Edited 3-Jun-88 14:27 by jds")
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS)
|
||||
|
||||
(* ;; "Edited 6-Jun-2022 00:35 by rmk")
|
||||
|
||||
(* ;; "Edited 4-Jun-2022 15:42 by rmk")
|
||||
|
||||
(* ;; "Edited 31-Jan-2022 17:19 by rmk: String TEXT is a file name")
|
||||
|
||||
(* ;; "Edited 30-Dec-2021 20:50 by rmk")
|
||||
|
||||
(* ;; "Edited 28-Dec-2021 00:12 by rmk")
|
||||
|
||||
(* ;; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
|
||||
(* ;; "Edited 11-Jun-99 14:14 by rmk:")
|
||||
|
||||
(* ;; "Edited 3-Jun-88 14:27 by jds")
|
||||
|
||||
(* ;; "User entry to the text editor. Takes an optional window to be used for editing")
|
||||
|
||||
(* ;; "DONTSPAWN => Don't try to create a new process for this edit.")
|
||||
|
||||
(PROG (PROC TEDITCREATEDWINDOW) (* ;
|
||||
"Include the default properties in the list.")
|
||||
(PROG (PROC TEDITCREATEDWINDOW)
|
||||
[COND
|
||||
((AND TEXT (ATOM TEXT)) (* ;
|
||||
((AND TEXT (OR (LITATOM TEXT)
|
||||
(STRINGP TEXT)
|
||||
(CL:PATHNAMEP TEXT))) (* ;
|
||||
"Make sure the file exists before trying to open the window.")
|
||||
(SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD '((TYPE TEXT]
|
||||
(SETQ TEXT (OPENSTREAM TEXT 'INPUT 'OLD '((TYPE TEXT]
|
||||
(CL:WHEN (AND WINDOW (OR (LITATOM WINDOW)
|
||||
(REGIONP WINDOW)))
|
||||
|
||||
@@ -284,10 +298,9 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(NOT TEDIT.DEFAULT.WINDOW)
|
||||
(\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW))
|
||||
(TEDIT.CREATEW (COND
|
||||
((AND TEXT (ATOM TEXT))
|
||||
(CONCAT
|
||||
(TEXT (CONCAT
|
||||
"Please specify an editing window for "
|
||||
TEXT))
|
||||
(FULLNAME TEXT)))
|
||||
(T
|
||||
"Please specify a region for the editing window."
|
||||
))
|
||||
@@ -336,11 +349,24 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(TTY.PROCESS PROC)))
|
||||
(RETURN PROC])
|
||||
|
||||
(TEDITSTRING
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS)
|
||||
|
||||
(* ;;; "Edited 23-May-2022 15:52 by rmk")
|
||||
|
||||
(* ;;; "Edited 19-May-2022 22:46 by rmk: An interface function to replace calls to TEDIT when the text argument may be the string to be edited rather than the name of a file. This enables the transition that gets TEDIT aligned with the convention that strings, as well as litatoms, are file names")
|
||||
|
||||
(TEDIT (IF (STRINGP TEXT)
|
||||
THEN (OPENSTRINGSTREAM TEXT)
|
||||
ELSE TEXT)
|
||||
WINDOW DONTSPAWN PROPS])
|
||||
|
||||
(TEDIT-SEE
|
||||
[LAMBDA (FILE WINDOW FORMAT TITLE) (* ; "Edited 30-Dec-2021 18:03 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:33 by rmk")
|
||||
(* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
[LAMBDA (FILE WINDOW FORMAT TITLE) (* ; "Edited 5-May-2022 15:18 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 18:03 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:33 by rmk")
|
||||
(* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
(* ; "Edited 1-Feb-88 19:00 by bvm:")
|
||||
|
||||
(* ;; "See FILE in a scrollable READONLY TEDIT window. If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.")
|
||||
@@ -359,8 +385,8 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "Lisp source file")
|
||||
|
||||
(SETQ SEESTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT SEESTREAM)
|
||||
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
|
||||
(APPLY* (FUNCTION SEE)
|
||||
STREAM SEESTREAM)
|
||||
ELSE
|
||||
(* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.")
|
||||
|
||||
@@ -2243,7 +2269,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* ; "TEDIT Support information")
|
||||
|
||||
|
||||
(RPAQQ TEDITSYSTEMDATE "30-Dec-2021 20:50:54")
|
||||
(RPAQQ TEDITSYSTEMDATE " 6-Jun-2022 00:36:53")
|
||||
|
||||
(RPAQ TEDITSUPPORT "TEditSupport.PA")
|
||||
(DEFINEQ
|
||||
@@ -2269,19 +2295,20 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1992 1993 1995 1999 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4336 118040 (\TEDIT2 4346 . 7097) (COERCETEXTOBJ 7099 . 15875) (TEDIT 15877 . 21230) (
|
||||
TEDIT-SEE 21232 . 23716) (TEDIT.CHARWIDTH 23718 . 25742) (TEDIT.COPY 25744 . 34180) (TEDIT.DELETE
|
||||
34182 . 34872) (TEDIT.DO.BLUEPENDINGDELETE 34874 . 37941) (TEDIT.INSERT 37943 . 43473) (TEDIT.KILL
|
||||
43475 . 45032) (TEDIT.MAPLINES 45034 . 46433) (TEDIT.MAPPIECES 46435 . 47391) (TEDIT.MOVE 47393 .
|
||||
57177) (TEDIT.QUIT 57179 . 59179) (TEDIT.STRINGWIDTH 59181 . 59852) (TEDIT.\INSERT 59854 . 61879) (
|
||||
TEXTOBJ 61881 . 63006) (TEXTSTREAM 63008 . 64623) (\TEDIT.INCLUDE 64625 . 68525) (\TEDIT.INSERT.PIECES
|
||||
68527 . 78442) (\TEDIT.MOVE.PIECEMAPFN 78444 . 80523) (\TEDIT.OBJECT.SHOWSEL 80525 . 84154) (
|
||||
\TEDIT.RESTARTFN 84156 . 86151) (\TEDIT.CHARDELETE 86153 . 90115) (\TEDIT.COPY.PIECEMAPFN 90117 .
|
||||
93342) (\TEDIT.DELETE 93344 . 100862) (\TEDIT.DIFFUSE.PARALOOKS 100864 . 103628) (\TEDIT.FOREIGN.COPY?
|
||||
103630 . 107357) (\TEDIT.QUIT 107359 . 110505) (\TEDIT.WORDDELETE 110507 . 115340) (\TEDIT1 115342 .
|
||||
118038)) (118154 118270 (\CREATE.TEDIT.RESTART.MENU 118164 . 118268)) (118369 122058 (PLCHAIN 118379
|
||||
. 118653) (PRINTLINE 118655 . 121419) (SEEFILE 121421 . 122056)) (122099 141742 (TEDIT.INSERT.OBJECT
|
||||
122109 . 131186) (TEDIT.EDIT.OBJECT 131188 . 133444) (TEDIT.FIND.OBJECT 133446 . 134339) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 134341 . 135147) (TEDIT.PUT.OBJECT 135149 . 136808) (TEDIT.GET.OBJECT 136810
|
||||
. 140009) (TEDIT.OBJECT.CHANGED 140011 . 141740)) (142020 142383 (MAKETEDITFORM 142030 . 142381)))))
|
||||
(FILEMAP (NIL (4349 118548 (\TEDIT2 4359 . 7110) (COERCETEXTOBJ 7112 . 15888) (TEDIT 15890 . 21072) (
|
||||
TEDITSTRING 21074 . 21633) (TEDIT-SEE 21635 . 24224) (TEDIT.CHARWIDTH 24226 . 26250) (TEDIT.COPY 26252
|
||||
. 34688) (TEDIT.DELETE 34690 . 35380) (TEDIT.DO.BLUEPENDINGDELETE 35382 . 38449) (TEDIT.INSERT 38451
|
||||
. 43981) (TEDIT.KILL 43983 . 45540) (TEDIT.MAPLINES 45542 . 46941) (TEDIT.MAPPIECES 46943 . 47899) (
|
||||
TEDIT.MOVE 47901 . 57685) (TEDIT.QUIT 57687 . 59687) (TEDIT.STRINGWIDTH 59689 . 60360) (TEDIT.\INSERT
|
||||
60362 . 62387) (TEXTOBJ 62389 . 63514) (TEXTSTREAM 63516 . 65131) (\TEDIT.INCLUDE 65133 . 69033) (
|
||||
\TEDIT.INSERT.PIECES 69035 . 78950) (\TEDIT.MOVE.PIECEMAPFN 78952 . 81031) (\TEDIT.OBJECT.SHOWSEL
|
||||
81033 . 84662) (\TEDIT.RESTARTFN 84664 . 86659) (\TEDIT.CHARDELETE 86661 . 90623) (
|
||||
\TEDIT.COPY.PIECEMAPFN 90625 . 93850) (\TEDIT.DELETE 93852 . 101370) (\TEDIT.DIFFUSE.PARALOOKS 101372
|
||||
. 104136) (\TEDIT.FOREIGN.COPY? 104138 . 107865) (\TEDIT.QUIT 107867 . 111013) (\TEDIT.WORDDELETE
|
||||
111015 . 115848) (\TEDIT1 115850 . 118546)) (118662 118778 (\CREATE.TEDIT.RESTART.MENU 118672 . 118776
|
||||
)) (118877 122566 (PLCHAIN 118887 . 119161) (PRINTLINE 119163 . 121927) (SEEFILE 121929 . 122564)) (
|
||||
122607 142250 (TEDIT.INSERT.OBJECT 122617 . 131694) (TEDIT.EDIT.OBJECT 131696 . 133952) (
|
||||
TEDIT.FIND.OBJECT 133954 . 134847) (TEDIT.FIND.OBJECT.SUBTREE 134849 . 135655) (TEDIT.PUT.OBJECT
|
||||
135657 . 137316) (TEDIT.GET.OBJECT 137318 . 140517) (TEDIT.OBJECT.CHANGED 140519 . 142248)) (142528
|
||||
142891 (MAKETEDITFORM 142538 . 142889)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
250
library/TEXTOFD
250
library/TEXTOFD
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "22-Dec-2021 10:29:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;12 182752
|
||||
(FILECREATED " 4-Jun-2022 15:43:05"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>library>TEXTOFD.;19 183223
|
||||
|
||||
:CHANGES-TO (FNS \TEXTBIN \TEXTPEEKBIN)
|
||||
:CHANGES-TO (FNS OPENTEXTSTREAM)
|
||||
|
||||
:PREVIOUS-DATE "22-Dec-2021 10:01:53"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;11)
|
||||
:PREVIOUS-DATE " 5-May-2022 15:12:26"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>library>TEXTOFD.;18)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -107,20 +108,23 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(RETURN NEWSTREAM])
|
||||
|
||||
(OPENTEXTSTREAM
|
||||
[LAMBDA (TEXT WINDOW START END PROPS) (* ; "Edited 4-May-93 14:38 by jds")
|
||||
[LAMBDA (TEXT WINDOW START END PROPS) (* ; "Edited 4-Jun-2022 15:42 by rmk")
|
||||
(* ;
|
||||
"Edited 31-Jan-2022 17:25 by rmk: A string TEXT is converted here to a stream")
|
||||
(* ; "Edited 4-May-93 14:38 by jds")
|
||||
(* ;
|
||||
"Create a text-type STREAM to describe TEXT. Optionally, connect that to WINDOW for display.")
|
||||
"Create a text-type STREAM to describe TEXT. Optionally, connect that to WINDOW for display.")
|
||||
(PROG* ([WAS-TEXTSTREAM (AND (type? STREAM TEXT)
|
||||
(type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT]
|
||||
[TEXTOBJ (COND
|
||||
(WAS-TEXTSTREAM (* ;
|
||||
"If the guy gave us a text stream to edit, use its TEXTOBJ as ours.")
|
||||
(create TEXTOBJ
|
||||
reusing (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
|
||||
\INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 \INSERTPCVALID _ NIL))
|
||||
"If the guy gave us a text stream to edit, use its TEXTOBJ as ours.")
|
||||
(create TEXTOBJ reusing (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
|
||||
\INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1
|
||||
\INSERTPCVALID _ NIL))
|
||||
((type? TEXTOBJ TEXT)
|
||||
(create TEXTOBJ using TEXT \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1
|
||||
\INSERTPCVALID _ NIL))
|
||||
\INSERTPCVALID _ NIL))
|
||||
(T (create TEXTOBJ]
|
||||
(TEDIT.GET.FINISHEDFORMS NIL)
|
||||
[PROPS (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)
|
||||
@@ -129,18 +133,18 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(EQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ]
|
||||
FONT SEL PCTB PC TEXTSTREAM OTEXTOBJ PROP CLEARGET? PARALOOKS PWINDOW)
|
||||
(* ;
|
||||
"Remember if the textobj had a window already.")
|
||||
"Remember if the textobj had a window already.")
|
||||
(replace (TEXTOBJ \WINDOW) of TEXTOBJ with (AND WINDOW (LIST WINDOW)))
|
||||
(* ;
|
||||
"Necessary because some incoming object types depend on knowing where the window is.")
|
||||
"Necessary because some incoming object types depend on knowing where the window is.")
|
||||
(replace (TEXTOBJ LINES) of TEXTOBJ with NIL)
|
||||
|
||||
(* ;; "This is here so if we re-OPENTEXTSTREAM an existing stream/window pair we don't get two sets of line descriptors")
|
||||
|
||||
(for PROPNAME in PROPS by (CDDR PROPNAME) as PROPVAL
|
||||
in (CDR PROPS) by (CDDR PROPVAL) do (TEXTPROP TEXTOBJ PROPNAME PROPVAL)
|
||||
) (* ;
|
||||
"Save the PROPS for later people who'd like to know them")
|
||||
(for PROPNAME in PROPS by (CDDR PROPNAME) as PROPVAL in (CDR PROPS)
|
||||
by (CDDR PROPVAL) do (TEXTPROP TEXTOBJ PROPNAME PROPVAL))
|
||||
(* ;
|
||||
"Save the PROPS for later people who'd like to know them")
|
||||
[SETQ FONT (COND
|
||||
((type? CHARLOOKS (LISTGET PROPS 'FONT))
|
||||
(LISTGET PROPS 'FONT))
|
||||
@@ -152,38 +156,36 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(T (OR (LISTGET PROPS 'FONT)
|
||||
DEFAULTFONT]
|
||||
NIL TEXTOBJ] (* ;
|
||||
"Find the default font for this session -- either what the guy tells us, or the global default font")
|
||||
"Find the default font for this session -- either what the guy tells us, or the global default font")
|
||||
(SETQ PARALOOKS (LISTGET PROPS 'PARALOOKS))
|
||||
|
||||
(* ;; "Get the default paragraph looks. This must come before the first piece is created, so its fields can be filled in right.")
|
||||
|
||||
(replace (TEXTOBJ FMTSPEC) of TEXTOBJ
|
||||
with (\TEDIT.UNIQUIFY.PARALOOKS [SETQ PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST
|
||||
(OR PARALOOKS
|
||||
(create FMTSPEC
|
||||
using
|
||||
(replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS
|
||||
[SETQ PARALOOKS
|
||||
(\TEDIT.PARSE.PARALOOKS.LIST
|
||||
(OR PARALOOKS (create FMTSPEC using
|
||||
TEDIT.DEFAULT.FMTSPEC
|
||||
]
|
||||
TEXTOBJ))
|
||||
TEXTOBJ))
|
||||
[COND
|
||||
[WAS-TEXTSTREAM (* ;
|
||||
"We got a TEXTOFD stream to edit; just use it")
|
||||
"We got a TEXTOFD stream to edit; just use it")
|
||||
(SETQ OTEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT))
|
||||
(SETQ TEXTSTREAM TEXT)
|
||||
(for SELN in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ MOVESEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ DELETESEL) of TEXTOBJ))
|
||||
(fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ MOVESEL) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ DELETESEL) of TEXTOBJ))
|
||||
do
|
||||
(* ;; "Make all the selections point to the CURRENT textobj!")
|
||||
|
||||
(* ;; "Make all the selections point to the CURRENT textobj!")
|
||||
|
||||
(COND
|
||||
((EQ OTEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELN))
|
||||
(replace (SELECTION \TEXTOBJ) of SELN with TEXTOBJ))
|
||||
(T (replace (SELECTION SET) of SELN with NIL)))
|
||||
(replace (SELECTION ONFLG) of SELN with NIL))
|
||||
(COND
|
||||
((EQ OTEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELN))
|
||||
(replace (SELECTION \TEXTOBJ) of SELN with TEXTOBJ))
|
||||
(T (replace (SELECTION SET) of SELN with NIL)))
|
||||
(replace (SELECTION ONFLG) of SELN with NIL))
|
||||
(replace (TEXTSTREAM TEXTOBJ) of TEXTSTREAM with TEXTOBJ)
|
||||
(replace (TEXTOBJ STREAMHINT) of TEXTOBJ with TEXTSTREAM)
|
||||
(SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
|
||||
@@ -193,106 +195,107 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(* ; "And mark it not changed.")
|
||||
(COND
|
||||
(FONT (* ;
|
||||
"If a new default font was specified, set it up.")
|
||||
(replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ
|
||||
with (\TEDIT.UNIQUIFY.CHARLOOKS FONT TEXTOBJ]
|
||||
((type? TEXTOBJ TEXT) (* ;
|
||||
"We got a TEXTOBJ to edit; fill in the stream, since it might have been GC'd.")
|
||||
"If a new default font was specified, set it up.")
|
||||
(replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (
|
||||
\TEDIT.UNIQUIFY.CHARLOOKS
|
||||
FONT TEXTOBJ]
|
||||
((type? TEXTOBJ TEXT) (* ;
|
||||
"We got a TEXTOBJ to edit; fill in the stream, since it might have been GC'd.")
|
||||
(SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ
|
||||
with (create TEXTSTREAM
|
||||
TEXTOBJ _ TEXTOBJ)))
|
||||
TEXTOBJ _ TEXTOBJ)))
|
||||
(SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
|
||||
(for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM)))
|
||||
(T (* ;
|
||||
"Otherwise, create a TEXTOFD to describe the text we're editing.-")
|
||||
"Otherwise, create a TEXTOFD to describe the text we're editing.-")
|
||||
(CL:WHEN (AND TEXT (OR (LITATOM TEXT)
|
||||
(STRINGP TEXT)
|
||||
(CL:PATHNAMEP TEXT)))(* ; "rmk: Strings are now file names")
|
||||
[SETQ TEXT (OPENSTREAM TEXT 'INPUT 'OLD '((TYPE TEXT])
|
||||
(SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ
|
||||
with (create TEXTSTREAM
|
||||
TEXTOBJ _ TEXTOBJ)))
|
||||
[replace (TEXTOBJ PCTB) of TEXTOBJ
|
||||
with (SETQ PCTB (TEDIT.BUILD.PCTB TEXT TEXTOBJ START END FONT PARALOOKS
|
||||
(LISTGET PROPS 'CLEARGET]
|
||||
TEXTOBJ _ TEXTOBJ)))
|
||||
[replace (TEXTOBJ PCTB) of TEXTOBJ with (SETQ PCTB
|
||||
(TEDIT.BUILD.PCTB TEXT TEXTOBJ START END
|
||||
FONT PARALOOKS (LISTGET PROPS
|
||||
'CLEARGET]
|
||||
|
||||
(* ;; "(setq pc (\\editelt pctb (add1 |\\FirstPieceOffset|)))")
|
||||
|
||||
(SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB)
|
||||
0))
|
||||
(for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM))
|
||||
(replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN)
|
||||
of PCTB]
|
||||
(replace (TEXTOBJ CARETLOOKS) of TEXTOBJ
|
||||
with (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CARETLOOKS.VERIFY TEXTOBJ
|
||||
(replace (TEXTOBJ DEFAULTCHARLOOKS)
|
||||
of TEXTOBJ with (
|
||||
(replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN) of PCTB]
|
||||
(replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS
|
||||
(\TEDIT.CARETLOOKS.VERIFY
|
||||
TEXTOBJ
|
||||
(replace (TEXTOBJ DEFAULTCHARLOOKS)
|
||||
of TEXTOBJ with (
|
||||
\TEDIT.UNIQUIFY.CHARLOOKS
|
||||
FONT TEXTOBJ)))
|
||||
TEXTOBJ))
|
||||
(replace (TEXTOBJ CARET) of TEXTOBJ with (create
|
||||
TEDITCARET
|
||||
TCCARETDS _
|
||||
(AND WINDOW (WINDOWPROP WINDOW
|
||||
'DSP))
|
||||
TCFORCEUP _ T))
|
||||
FONT TEXTOBJ)))
|
||||
TEXTOBJ))
|
||||
(replace (TEXTOBJ CARET) of TEXTOBJ with (create TEDITCARET
|
||||
TCCARETDS _ (AND WINDOW
|
||||
(WINDOWPROP WINDOW
|
||||
'DSP))
|
||||
TCFORCEUP _ T))
|
||||
(replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with (LISTGET PROPS 'READONLY))
|
||||
(replace (TEXTOBJ TXTTERMSA) of TEXTOBJ with (AND (SETQ PROP
|
||||
(LISTGET PROPS 'TERMTABLE))
|
||||
(fetch TERMSA
|
||||
of PROP)))
|
||||
(replace (TEXTOBJ TXTTERMSA) of TEXTOBJ with (AND (SETQ PROP (LISTGET PROPS 'TERMTABLE))
|
||||
(fetch TERMSA of PROP)))
|
||||
(replace (TEXTOBJ TXTRTBL) of TEXTOBJ with (LISTGET PROPS 'READTABLE))
|
||||
(replace (TEXTOBJ TXTWTBL) of TEXTOBJ with (LISTGET PROPS 'BOUNDTABLE))
|
||||
[COND
|
||||
((LISTGET PROPS 'PAGEFORMAT) (* ;
|
||||
"A default page formatting was supplied. Impose it on the document.")
|
||||
"A default page formatting was supplied. Impose it on the document.")
|
||||
(TEDIT.PAGEFORMAT TEXTOBJ (LISTGET PROPS 'PAGEFORMAT]
|
||||
(SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
|
||||
(SETQ PROP (LISTGET PROPS 'SEL)) (* ; "Initial Selection, if any.")
|
||||
(COND
|
||||
((EQ PROP 'DON'T) (* ;
|
||||
"A SEL prop of DON'T means don't make an initial selection")
|
||||
"A SEL prop of DON'T means don't make an initial selection")
|
||||
(replace (SELECTION SET) of SEL with NIL))
|
||||
((type? SELECTION PROP) (* ;
|
||||
"We came in with an explicit initial sel. Set it up.")
|
||||
((type? SELECTION PROP) (* ;
|
||||
"We came in with an explicit initial sel. Set it up.")
|
||||
(\COPYSEL PROP SEL)
|
||||
(replace (SELECTION SET) of SEL with T)
|
||||
(replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ))
|
||||
((AND (fetch (SELECTION SET) of SEL)
|
||||
(NOT PROP)) (* ;
|
||||
"If we came into this with a valid selection, highlight it.")
|
||||
"If we came into this with a valid selection, highlight it.")
|
||||
(replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ))
|
||||
(T (* ;
|
||||
"Starting without a selection; let's start with a point selection before the first character.")
|
||||
"Starting without a selection; let's start with a point selection before the first character.")
|
||||
(replace (SELECTION CH#) of SEL with (COND
|
||||
((FIXP PROP))
|
||||
(PROP (CAR PROP))
|
||||
(1)))
|
||||
((FIXP PROP))
|
||||
(PROP (CAR PROP))
|
||||
(1)))
|
||||
(replace (SELECTION CHLIM) of SEL with (COND
|
||||
((FIXP PROP))
|
||||
(PROP (IPLUS (CAR PROP)
|
||||
(CADR PROP)))
|
||||
(1)))
|
||||
((FIXP PROP))
|
||||
(PROP (IPLUS (CAR PROP)
|
||||
(CADR PROP)))
|
||||
(1)))
|
||||
(replace (SELECTION DCH) of SEL with (COND
|
||||
((FIXP PROP)
|
||||
0)
|
||||
(PROP (CADR PROP))
|
||||
(0)))
|
||||
((FIXP PROP)
|
||||
0)
|
||||
(PROP (CADR PROP))
|
||||
(0)))
|
||||
(replace (SELECTION DX) of SEL with 0)
|
||||
(replace (SELECTION POINT) of SEL with 'LEFT)
|
||||
(replace (SELECTION SELKIND) of SEL with 'CHAR)
|
||||
(replace (SELECTION SET) of SEL with (NOT (fetch (TEXTOBJ
|
||||
TXTREADONLY)
|
||||
of TEXTOBJ)))
|
||||
(replace (SELECTION SET) of SEL with (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)))
|
||||
(replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)))
|
||||
[COND
|
||||
((fetch (SELECTION SET) of SEL) (* ;
|
||||
"If there's an initial selection, it implies initial caret looks, too.")
|
||||
(replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS
|
||||
TEXTOBJ SEL]
|
||||
((fetch (SELECTION SET) of SEL) (* ;
|
||||
"If there's an initial selection, it implies initial caret looks, too.")
|
||||
(replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ SEL
|
||||
]
|
||||
(COND
|
||||
((AND WINDOW (NOT TEXTOBJ.WINDOW.VALID)) (* ;
|
||||
"Only if there's a window to display it in:")
|
||||
"Only if there's a window to display it in:")
|
||||
(replace (TEXTOBJ \WINDOW) of TEXTOBJ with NIL)
|
||||
(\TEDIT.WINDOW.SETUP WINDOW TEXTOBJ TEXTSTREAM PROPS)
|
||||
(* ;
|
||||
"Set up the window, and display the initial text.")
|
||||
"Set up the window, and display the initial text.")
|
||||
)
|
||||
((SETQ PWINDOW (LISTGET PROPS 'PROMPTWINDOW))
|
||||
|
||||
@@ -300,10 +303,10 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
|
||||
(replace (TEXTOBJ PROMPTWINDOW) of TEXTOBJ with PWINDOW)))
|
||||
(\SETUPGETCH (create EDITMARK
|
||||
PC _ (\GETBASEPTR (\FIRSTNODE PCTB)
|
||||
0)
|
||||
PCOFF _ 0
|
||||
PCNO _ 1)
|
||||
PC _ (\GETBASEPTR (\FIRSTNODE PCTB)
|
||||
0)
|
||||
PCOFF _ 0
|
||||
PCNO _ 1)
|
||||
TEXTOBJ) (* ; "Set the file ptr to 0")
|
||||
(RETURN TEXTSTREAM])
|
||||
|
||||
@@ -676,9 +679,10 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(RETURN PC])
|
||||
|
||||
(\TEXTINIT
|
||||
[LAMBDA NIL (* ; "Edited 7-Oct-2021 08:40 by rmk:")
|
||||
[LAMBDA NIL (* ; "Edited 5-May-2022 15:12 by rmk")
|
||||
(* ; "Edited 7-Oct-2021 08:40 by rmk:")
|
||||
(* ;
|
||||
"Create the FDEV and STREAM prototypes for TEXT streams.")
|
||||
"Create the FDEV and STREAM prototypes for TEXT streams.")
|
||||
|
||||
(* ;; "TEXT streams make use of the following STREAM fields:")
|
||||
|
||||
@@ -700,7 +704,7 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
|
||||
(* ;; "(FW8 WORD)")
|
||||
|
||||
(SETQ \TEXTIMAGEOPS (create IMAGEOPS
|
||||
[SETQ \TEXTIMAGEOPS (create IMAGEOPS
|
||||
IMAGETYPE _ 'TEXT
|
||||
IMXPOSITION _ (FUNCTION \TEXTDSPXPOSITION)
|
||||
IMYPOSITION _ (FUNCTION \TEXTDSPYPOSITION)
|
||||
@@ -711,7 +715,8 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
IMFONTCREATE _ 'DISPLAY
|
||||
IMLINEFEED _ (FUNCTION \TEXTDSPLINEFEED)
|
||||
IMCHARWIDTH _ (FUNCTION \TEXTDSPCHARWIDTH)
|
||||
IMSTRINGWIDTH _ (FUNCTION \TEXTDSPSTRINGWIDTH)))
|
||||
IMSTRINGWIDTH _ (FUNCTION \TEXTDSPSTRINGWIDTH)
|
||||
IMSCALE _ (FUNCTION (LAMBDA NIL 1]
|
||||
(SETQ \TEXTFDEV (create FDEV
|
||||
DEVICENAME _ 'TEXT
|
||||
RESETABLE _ T
|
||||
@@ -780,9 +785,8 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(LET ((STREAM (STREAM-ERROR-STREAM CONDITION)))
|
||||
(COND
|
||||
[(AND (BOUNDP 'ERRORPOS)
|
||||
(TEXTSTREAMP STREAM))
|
||||
(* ;
|
||||
"This happened in the error handler, and it happened to a TEdit stream, so try the fix:")
|
||||
(TEXTSTREAMP STREAM)) (* ;
|
||||
"This happened in the error handler, and it happened to a TEdit stream, so try the fix:")
|
||||
(LET ((XCL::RESULT (REOPENTEXTSTREAM STREAM)))
|
||||
(CL:WHEN XCL::RESULT
|
||||
(ENVAPPLY (STKNAME ERRORPOS)
|
||||
@@ -791,7 +795,7 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
ERRORPOS T T))]
|
||||
(*TEDIT-OLD-STREAM-ERROR-HANDLER*
|
||||
(* ;
|
||||
"Some other kind of stream, so punt to the old handler (if there is one):")
|
||||
"Some other kind of stream, so punt to the old handler (if there is one):")
|
||||
(APPLY* *TEDIT-OLD-STREAM-ERROR-HANDLER* CONDITION])
|
||||
|
||||
(\TEXTMARK
|
||||
@@ -2721,25 +2725,25 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1993 1994 1995 1999 2000 2001 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2992 53117 (COPYTEXTSTREAM 3002 . 6124) (OPENTEXTSTREAM 6126 . 21003) (REOPENTEXTSTREAM
|
||||
21005 . 21427) (TEDIT.STREAMCHANGEDP 21429 . 21727) (TEXTSTREAMP 21729 . 22043) (TXTFILE 22045 .
|
||||
22490) (\DELETECH 22492 . 33748) (\SETUPGETCH 33750 . 41029) (\TEDIT.REOPEN.STREAM 41031 . 42881) (
|
||||
\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42883 . 45321) (\TEXTINIT 45323 . 51010) (\TEXTMARK 51012 . 51760) (
|
||||
\TEXTTTYBOUT 51762 . 53115)) (53118 78550 (\INSERTCH 53128 . 76854) (\INSERTCR 76856 . 78548)) (78616
|
||||
98932 (\CHTOPC 78626 . 79815) (\CHTOPCNO 79817 . 81079) (\CLEARPCTB 81081 . 81877) (
|
||||
\CREATEPIECEORSTREAM 81879 . 84853) (\DELETEPIECE 84855 . 85768) (\FINDPIECE 85770 . 86136) (
|
||||
\INSERTPIECE 86138 . 89148) (\MAKEPCTB 89150 . 91065) (\SPLITPIECE 91067 . 98026) (\INSERT.FIRST.PIECE
|
||||
98028 . 98930)) (98984 123222 (\TEXTCLOSEF 98994 . 100221) (\TEXTCLOSEF-SUBTREE 100223 . 100929) (
|
||||
\TEXTDSPFONT 100931 . 101923) (\TEXTEOFP 101925 . 103284) (\TEXTGETEOFPTR 103286 . 103496) (
|
||||
\TEXTGETFILEPTR 103498 . 105561) (\TEXTOPENF 105563 . 106393) (\TEXTOPENF-SUBTREE 106395 . 107196) (
|
||||
\TEXTOUTCHARFN 107198 . 107546) (\TEXTBACKFILEPTR 107548 . 113449) (\TEXTBOUT 113451 . 116799) (
|
||||
\TEDITOUTCCODEFN 116801 . 118067) (\TEXTSETEOF 118069 . 118578) (\TEXTSETFILEPTR 118580 . 119805) (
|
||||
\TEXTDSPXPOSITION 119807 . 120664) (\TEXTDSPYPOSITION 120666 . 121211) (\TEXTLEFTMARGIN 121213 .
|
||||
121696) (\TEXTRIGHTMARGIN 121698 . 122634) (\TEXTDSPCHARWIDTH 122636 . 122874) (\TEXTDSPSTRINGWIDTH
|
||||
122876 . 123116) (\TEXTDSPLINEFEED 123118 . 123220)) (123223 161060 (\TEXTBIN 123233 . 144112) (
|
||||
\TEDIT.TEXTBIN.STRINGSETUP 144114 . 149827) (\TEDIT.TEXTBIN.FILESETUP 149829 . 156215) (
|
||||
\TEDIT.TEXTBIN.NEW.PAGE 156217 . 161058)) (161061 176823 (\TEXTPEEKBIN 161071 . 172564) (
|
||||
\TEDIT.PEEKBIN.NEW.PAGE 172566 . 176821)) (176861 182079 (CGETTEXTPROP 176871 . 177347) (CTEXTPROP
|
||||
177349 . 179693) (GETTEXTPROP 179695 . 180290) (PUTTEXTPROP 180292 . 181617) (TEXTPROP 181619 . 182077
|
||||
(FILEMAP (NIL (2996 53588 (COPYTEXTSTREAM 3006 . 6128) (OPENTEXTSTREAM 6130 . 21350) (REOPENTEXTSTREAM
|
||||
21352 . 21774) (TEDIT.STREAMCHANGEDP 21776 . 22074) (TEXTSTREAMP 22076 . 22390) (TXTFILE 22392 .
|
||||
22837) (\DELETECH 22839 . 34095) (\SETUPGETCH 34097 . 41376) (\TEDIT.REOPEN.STREAM 41378 . 43228) (
|
||||
\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 43230 . 45668) (\TEXTINIT 45670 . 51481) (\TEXTMARK 51483 . 52231) (
|
||||
\TEXTTTYBOUT 52233 . 53586)) (53589 79021 (\INSERTCH 53599 . 77325) (\INSERTCR 77327 . 79019)) (79087
|
||||
99403 (\CHTOPC 79097 . 80286) (\CHTOPCNO 80288 . 81550) (\CLEARPCTB 81552 . 82348) (
|
||||
\CREATEPIECEORSTREAM 82350 . 85324) (\DELETEPIECE 85326 . 86239) (\FINDPIECE 86241 . 86607) (
|
||||
\INSERTPIECE 86609 . 89619) (\MAKEPCTB 89621 . 91536) (\SPLITPIECE 91538 . 98497) (\INSERT.FIRST.PIECE
|
||||
98499 . 99401)) (99455 123693 (\TEXTCLOSEF 99465 . 100692) (\TEXTCLOSEF-SUBTREE 100694 . 101400) (
|
||||
\TEXTDSPFONT 101402 . 102394) (\TEXTEOFP 102396 . 103755) (\TEXTGETEOFPTR 103757 . 103967) (
|
||||
\TEXTGETFILEPTR 103969 . 106032) (\TEXTOPENF 106034 . 106864) (\TEXTOPENF-SUBTREE 106866 . 107667) (
|
||||
\TEXTOUTCHARFN 107669 . 108017) (\TEXTBACKFILEPTR 108019 . 113920) (\TEXTBOUT 113922 . 117270) (
|
||||
\TEDITOUTCCODEFN 117272 . 118538) (\TEXTSETEOF 118540 . 119049) (\TEXTSETFILEPTR 119051 . 120276) (
|
||||
\TEXTDSPXPOSITION 120278 . 121135) (\TEXTDSPYPOSITION 121137 . 121682) (\TEXTLEFTMARGIN 121684 .
|
||||
122167) (\TEXTRIGHTMARGIN 122169 . 123105) (\TEXTDSPCHARWIDTH 123107 . 123345) (\TEXTDSPSTRINGWIDTH
|
||||
123347 . 123587) (\TEXTDSPLINEFEED 123589 . 123691)) (123694 161531 (\TEXTBIN 123704 . 144583) (
|
||||
\TEDIT.TEXTBIN.STRINGSETUP 144585 . 150298) (\TEDIT.TEXTBIN.FILESETUP 150300 . 156686) (
|
||||
\TEDIT.TEXTBIN.NEW.PAGE 156688 . 161529)) (161532 177294 (\TEXTPEEKBIN 161542 . 173035) (
|
||||
\TEDIT.PEEKBIN.NEW.PAGE 173037 . 177292)) (177332 182550 (CGETTEXTPROP 177342 . 177818) (CTEXTPROP
|
||||
177820 . 180164) (GETTEXTPROP 180166 . 180761) (PUTTEXTPROP 180763 . 182088) (TEXTPROP 182090 . 182548
|
||||
)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 9-May-2022 20:28:46"
|
||||
{DSK}<users>kaplan>local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;218 123686
|
||||
(FILECREATED "25-May-2022 08:44:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;234 125334
|
||||
|
||||
:CHANGES-TO (FNS SOURCE-FOR-COMPILED-P)
|
||||
:CHANGES-TO (VARS COMPAREDIRECTORIESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Apr-2022 09:25:02"
|
||||
{DSK}<users>kaplan>local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;217)
|
||||
:PREVIOUS-DATE "24-May-2022 15:49:54"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;233)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -52,8 +52,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
TABLEBROWSER))
|
||||
(FNS CD.TABLEITEM CD.TABLEITEM.PRINTFN CD.TABLEITEM.COPYFN
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN)
|
||||
(FNS CDTABLEBROWSER.WHENSELECTEDFN CD.COMMANDSELECTEDFN CD-MENUFN CDBROWSER-COPY
|
||||
CDBROWSER-DELETE-FILE CD-SWAPDIRS)
|
||||
(FNS CDTABLEBROWSER.WHENSELECTEDFN CD.COMMANDSELECTEDFN CD-MENUFN CD-COMPARE-FILES
|
||||
CDBROWSER-COPY CDBROWSER-DELETE-FILE CD-SWAPDIRS)
|
||||
(VARS CDTABLEBROWSER.MENUITEMS)
|
||||
(FILES (SYSLOAD)
|
||||
COMPARESOURCES COMPARETEXT))))
|
||||
@@ -150,6 +150,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(COMPAREDIRECTORIES.INFOS
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH USEDIRECTORYDATE)
|
||||
|
||||
(* ;; "Edited 22-May-2022 14:17 by rmk")
|
||||
|
||||
(* ;; "Edited 29-Mar-2022 11:53 by rmk: Produces a list of CDINFOS with the match-name consed on to the front.")
|
||||
|
||||
(* ;; "Each entry is a list of the form (matchname . CDINFOS). CDINFOS is guaranteed to be a singleton, unless ALLVERSIONS. ")
|
||||
@@ -159,12 +161,13 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
COLLECT
|
||||
|
||||
(* ;; "GDATE/IDATE in case Y2K")
|
||||
(* ;
|
||||
"Is it a Lisp file? Get it's internal filecreated date. ")
|
||||
|
||||
(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)))
|
||||
(* ;
|
||||
"Is it a Lisp file? Get it's internal filecreated date. ")
|
||||
(CL:MULTIPLE-VALUE-SETQ (TYPE LDATE)
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE STREAM))
|
||||
(PROG1 (LIST (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ (FULLNAME STREAM)
|
||||
@@ -174,7 +177,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
LDATE)))
|
||||
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
|
||||
AUTHOR _ (GETFILEINFO STREAM 'AUTHOR)
|
||||
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE STREAM LDATE)
|
||||
TYPE _ TYPE
|
||||
EOL _ (EOLTYPE STREAM)))
|
||||
(CLOSEF? STREAM))
|
||||
FINALLY
|
||||
@@ -319,18 +322,20 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
CDE])
|
||||
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE
|
||||
[LAMBDA (FULLNAME LDATE) (* ; "Edited 25-Apr-2022 09:02 by rmk")
|
||||
[LAMBDA (FILE) (* ; "Edited 22-May-2022 14:27 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 09:02 by rmk")
|
||||
(* ; "Edited 4-Jan-2022 13:10 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(LET [(EXT (FILENAMEFIELD FULLNAME 'EXTENSION]
|
||||
(IF LDATE
|
||||
THEN (CL:IF (MEMB EXT *COMPILED-EXTENSIONS*)
|
||||
'COMPILED
|
||||
'SOURCE)
|
||||
ELSEIF (PRINTFILETYPE FULLNAME)
|
||||
ELSE (CL:IF (MEMB EXT '(TXT TEXT SH MD C))
|
||||
'TEXT
|
||||
'OTHER)])
|
||||
(LET (TYPE DATE)
|
||||
(CL:MULTIPLE-VALUE-SETQ (TYPE DATE)
|
||||
(LISPFILETYPE FILE))
|
||||
(CL:UNLESS TYPE
|
||||
(SETQ TYPE (IF (PRINTFILETYPE FILE)
|
||||
ELSEIF (MEMB (FILENAMEFIELD FILE 'EXTENSION)
|
||||
'(TXT TEXT SH MD C))
|
||||
THEN 'TEXT
|
||||
ELSE 'OTHER)))
|
||||
(CL:VALUES TYPE DATE])
|
||||
|
||||
(MATCHNAME
|
||||
[LAMBDA (NAME STARTPOS) (* ; "Edited 24-Feb-2022 09:10 by rmk")
|
||||
@@ -1866,105 +1871,123 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(CD-MENUFN
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY)
|
||||
|
||||
(* ;; "Edited 27-Feb-2022 12:47 by rmk: FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
|
||||
(* ;; "Edited 21-May-2022 21:59 by rmk")
|
||||
|
||||
(* ;; "The FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
|
||||
(* ;; "Edited 27-Feb-2022 12:47 by rmk: 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.")
|
||||
|
||||
(DECLARE (USEDFREE CDENTRY LABEL1 LABLE2 FILE1 FILE2 WINDOW))
|
||||
(DECLARE (USEDFREE LABEL1 LABEL2 FILE1 FILE2 WINDOW TYPE))
|
||||
(SETQ MENUITEM (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM)))
|
||||
(CL:WHEN (MEMB MENUITEM '(Compare See See% right See% both See% left))
|
||||
(* ; "Close the previous ones")
|
||||
(CLOSEWITH.DOIT WINDOW))
|
||||
(LET
|
||||
(CHILDREN)
|
||||
(SETQ CHILDREN
|
||||
(SELECTQ MENUITEM
|
||||
(Compare (IF (AND FILE1 FILE2)
|
||||
THEN [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)
|
||||
NIL)))
|
||||
(COMPILED (FLASHWINDOW T)
|
||||
(PRIN3 "Cannot compare compiled files" T))
|
||||
((TEXT TEDIT OTHER)
|
||||
(* ;;
|
||||
"Works for TEDIT, but doesn't detect image object differences")
|
||||
|
||||
(LET ((COMPARETEXT.ALLCHUNKS))
|
||||
(DECLARE (SPECVARS COMPARETEXT.ALLCHUNKS))
|
||||
(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)
|
||||
(EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2
|
||||
(RELCREATEREGION 1400 700 'LEFT 'TOP
|
||||
`(,WINDOW 0.5 -701)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
NIL]
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "Only one file" T)))
|
||||
(See% left (IF FILE1
|
||||
THEN (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% right (IF FILE2
|
||||
THEN (TEDIT-SEE FILE2 (RELCREATEREGION 700 700 'LEFT 'TOP
|
||||
`(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
NIL)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL2))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
((See See% both)
|
||||
(EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2 (RELCREATEREGION
|
||||
1400 700 'LEFT 'TOP `(,WINDOW 0.5 -701)
|
||||
(LET (CHILDREN)
|
||||
(SETQ CHILDREN (SELECTQ MENUITEM
|
||||
(Compare (IF (AND FILE1 FILE2)
|
||||
THEN (CD-COMPARE-FILES FILE1 FILE2 LABEL1 LABEL2 TYPE
|
||||
(WINDOWPROP WINDOW 'REGION))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "Only one file" T)))
|
||||
(See% left (IF FILE1
|
||||
THEN (TEDIT-SEE FILE1
|
||||
(RELCREATEREGION
|
||||
700 700 'RIGHT 'TOP `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
NIL)))
|
||||
(Copy% -> (CDBROWSER-COPY CDBROWSER TBITEM 'LEFT))
|
||||
(Copy% <- (CDBROWSER-COPY CDBROWSER TBITEM 'RIGHT))
|
||||
(Delete% <- (CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'LEFT T))
|
||||
(|Delete ALL <-|
|
||||
(CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'LEFT NIL))
|
||||
(Delete% -> (CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'RIGHT T))
|
||||
(|Delete ALL ->|
|
||||
(CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'RIGHT NIL))
|
||||
(SHOULDNT)))
|
||||
(CLOSEWITH CHILDREN WINDOW)
|
||||
(MOVEWITH CHILDREN WINDOW])
|
||||
T)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL1))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% right (IF FILE2
|
||||
THEN (TEDIT-SEE FILE2
|
||||
(RELCREATEREGION
|
||||
700 700 'LEFT 'TOP `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
NIL)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL2))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
((See See% both)
|
||||
(EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2
|
||||
(RELCREATEREGION 1400 700 'LEFT 'TOP `(,WINDOW 0.5 -701)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
NIL)))
|
||||
(Copy% -> (CDBROWSER-COPY CDBROWSER TBITEM 'LEFT))
|
||||
(Copy% <- (CDBROWSER-COPY CDBROWSER TBITEM 'RIGHT))
|
||||
(Delete% <- (CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'LEFT T))
|
||||
(|Delete ALL <-|
|
||||
(CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'LEFT NIL))
|
||||
(Delete% -> (CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'RIGHT T))
|
||||
(|Delete ALL ->|
|
||||
(CDBROWSER-DELETE-FILE CDBROWSER TBITEM 'RIGHT NIL))
|
||||
(SHOULDNT)))
|
||||
(CLOSEWITH CHILDREN WINDOW)
|
||||
(MOVEWITH CHILDREN WINDOW])
|
||||
|
||||
(CD-COMPARE-FILES
|
||||
[LAMBDA (FILE1 FILE2 LABEL1 LABEL2 TYPE PARENTREGION) (* ; "Edited 22-May-2022 14:41 by rmk")
|
||||
(PROG NIL
|
||||
(SETQ FILE1 (OR (STREAMP FILE1)
|
||||
(INFILEP FILE1)))
|
||||
(SETQ FILE2 (OR (STREAMP FILE2)
|
||||
(INFILEP FILE2)))
|
||||
(CL:UNLESS TYPE
|
||||
(SETQ TYPE (COMPAREDIRECTORIES.INFOS.TYPE FILE1))
|
||||
(CL:UNLESS (EQ TYPE (COMPAREDIRECTORIES.INFOS.TYPE FILE2))
|
||||
(FLASHWINDOW T)
|
||||
(PRIN3 "Can't compare files of different types" T)
|
||||
(RETURN)))
|
||||
(RETURN (SELECTQ TYPE
|
||||
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2
|
||||
(AND PARENTREGION (RELCREATEREGION
|
||||
(FIXR (TIMES 0.75 (FETCH (REGION WIDTH)
|
||||
OF PARENTREGION)))
|
||||
200
|
||||
'LEFT
|
||||
'TOP
|
||||
`(,PARENTREGION 0.125)
|
||||
(IPLUS (FETCH (REGION BOTTOM) OF PARENTREGION
|
||||
)
|
||||
20)
|
||||
NIL))))
|
||||
(COMPILED (FLASHWINDOW T)
|
||||
(PRIN3 "Cannot compare compiled files" T))
|
||||
((TEXT TEDIT OTHER)
|
||||
(* ;;
|
||||
"Works for TEDIT, but doesn't detect image object differences")
|
||||
|
||||
(LET ((COMPARETEXT.ALLCHUNKS))
|
||||
(DECLARE (SPECVARS COMPARETEXT.ALLCHUNKS))
|
||||
(COMPARETEXT FILE1 FILE2 'LINE
|
||||
(AND PARENTREGION (RELCREATEPOSITION
|
||||
`(,PARENTREGION 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM) OF
|
||||
PARENTREGION
|
||||
)
|
||||
20)))
|
||||
(LIST LABEL1 LABEL2))))
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(PRIN3 "Unable to compare, showing both" T)
|
||||
(EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2
|
||||
(AND PARENTREGION (RELCREATEREGION 1400 700 'LEFT 'TOP
|
||||
`(,PARENTREGION 0.5 -701)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF PARENTREGION)
|
||||
-1)
|
||||
NIL])
|
||||
|
||||
(CDBROWSER-COPY
|
||||
[LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 25-Apr-2022 09:24 by rmk")
|
||||
[LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 24-May-2022 15:49 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 09:24 by rmk")
|
||||
(* ; "Edited 5-Feb-2022 17:27 by rmk")
|
||||
(* ; "Edited 2-Feb-2022 22:18 by rmk")
|
||||
|
||||
@@ -2095,24 +2118,25 @@ 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 (2611 21960 (COMPAREDIRECTORIES 2621 . 7454) (COMPAREDIRECTORIES.INFOS 7456 . 10307) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10309 . 13694) (CDENTRIES.SELECT 13696 . 18471) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 18473 . 19194) (MATCHNAME 19196 . 19876) (CD.INSURECDVALUE 19878 . 21492
|
||||
) (CD.UPDATEWIDTHS 21494 . 21958)) (21961 31630 (CDFILES 21971 . 27724) (CDFILES.MATCH 27726 . 29351)
|
||||
(CDFILES.PATS 29353 . 31628)) (31631 46716 (CDPRINT 31641 . 33986) (CDPRINT.HEADER 33988 . 34885) (
|
||||
CDPRINT.LINE 34887 . 37443) (CDPRINT.MAXWIDTHS 37445 . 41560) (CDPRINT.COLHEADERS 41562 . 42200) (
|
||||
CDPRINT.COLUMNS 42202 . 46081) (CDTEDIT 46083 . 46714)) (46717 55086 (CDMAP 46727 . 48159) (CDENTRY
|
||||
48161 . 48470) (CDSUBSET 48472 . 49911) (CDMERGE 49913 . 53767) (CDMERGE.COMMON 53769 . 55084)) (55087
|
||||
62625 (BINCOMP 55097 . 59386) (EOLTYPE 59388 . 61950) (EOLTYPE.SHOW 61952 . 62623)) (63153 75680 (
|
||||
FIND-UNCOMPILED-FILES 63163 . 66806) (FIND-UNSOURCED-FILES 66808 . 69192) (FIND-SOURCE-FILES 69194 .
|
||||
70932) (FIND-COMPILED-FILES 70934 . 72811) (FIND-UNLOADED-FILES 72813 . 73666) (FIND-LOADED-FILES
|
||||
73668 . 74096) (FIND-MULTICOMPILED-FILES 74098 . 75678)) (75681 84112 (CREATED-AS 75691 . 80488) (
|
||||
SOURCE-FOR-COMPILED-P 80490 . 83417) (COMPILE-SOURCE-DATE-DIFF 83419 . 84110)) (84113 94419 (
|
||||
FIX-DIRECTORY-DATES 84123 . 87116) (FIX-EQUIV-DATES 87118 . 88643) (COPY-COMPARED-FILES 88645 . 90466)
|
||||
(COPY-MISSING-FILES 90468 . 92625) (COMPILED-ON-SAME-SOURCE 92627 . 94417)) (94613 101959 (CDBROWSER
|
||||
94623 . 98550) (CDBROWSER.STRINGS 98552 . 101957)) (102121 103857 (CD.TABLEITEM 102131 . 102351) (
|
||||
CD.TABLEITEM.PRINTFN 102353 . 102552) (CD.TABLEITEM.COPYFN 102554 . 103612) (
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN 103614 . 103855)) (103858 123102 (CDTABLEBROWSER.WHENSELECTEDFN
|
||||
103868 . 104336) (CD.COMMANDSELECTEDFN 104338 . 109439) (CD-MENUFN 109441 . 115804) (CDBROWSER-COPY
|
||||
115806 . 119366) (CDBROWSER-DELETE-FILE 119368 . 122581) (CD-SWAPDIRS 122583 . 123100)))))
|
||||
(FILEMAP (NIL (2640 22197 (COMPAREDIRECTORIES 2650 . 7483) (COMPAREDIRECTORIES.INFOS 7485 . 10359) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10361 . 13746) (CDENTRIES.SELECT 13748 . 18523) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 18525 . 19431) (MATCHNAME 19433 . 20113) (CD.INSURECDVALUE 20115 . 21729
|
||||
) (CD.UPDATEWIDTHS 21731 . 22195)) (22198 31867 (CDFILES 22208 . 27961) (CDFILES.MATCH 27963 . 29588)
|
||||
(CDFILES.PATS 29590 . 31865)) (31868 46953 (CDPRINT 31878 . 34223) (CDPRINT.HEADER 34225 . 35122) (
|
||||
CDPRINT.LINE 35124 . 37680) (CDPRINT.MAXWIDTHS 37682 . 41797) (CDPRINT.COLHEADERS 41799 . 42437) (
|
||||
CDPRINT.COLUMNS 42439 . 46318) (CDTEDIT 46320 . 46951)) (46954 55323 (CDMAP 46964 . 48396) (CDENTRY
|
||||
48398 . 48707) (CDSUBSET 48709 . 50148) (CDMERGE 50150 . 54004) (CDMERGE.COMMON 54006 . 55321)) (55324
|
||||
62862 (BINCOMP 55334 . 59623) (EOLTYPE 59625 . 62187) (EOLTYPE.SHOW 62189 . 62860)) (63390 75917 (
|
||||
FIND-UNCOMPILED-FILES 63400 . 67043) (FIND-UNSOURCED-FILES 67045 . 69429) (FIND-SOURCE-FILES 69431 .
|
||||
71169) (FIND-COMPILED-FILES 71171 . 73048) (FIND-UNLOADED-FILES 73050 . 73903) (FIND-LOADED-FILES
|
||||
73905 . 74333) (FIND-MULTICOMPILED-FILES 74335 . 75915)) (75918 84349 (CREATED-AS 75928 . 80725) (
|
||||
SOURCE-FOR-COMPILED-P 80727 . 83654) (COMPILE-SOURCE-DATE-DIFF 83656 . 84347)) (84350 94656 (
|
||||
FIX-DIRECTORY-DATES 84360 . 87353) (FIX-EQUIV-DATES 87355 . 88880) (COPY-COMPARED-FILES 88882 . 90703)
|
||||
(COPY-MISSING-FILES 90705 . 92862) (COMPILED-ON-SAME-SOURCE 92864 . 94654)) (94850 102196 (CDBROWSER
|
||||
94860 . 98787) (CDBROWSER.STRINGS 98789 . 102194)) (102358 104094 (CD.TABLEITEM 102368 . 102588) (
|
||||
CD.TABLEITEM.PRINTFN 102590 . 102789) (CD.TABLEITEM.COPYFN 102791 . 103849) (
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN 103851 . 104092)) (104095 124750 (CDTABLEBROWSER.WHENSELECTEDFN
|
||||
104105 . 104573) (CD.COMMANDSELECTEDFN 104575 . 109676) (CD-MENUFN 109678 . 113989) (CD-COMPARE-FILES
|
||||
113991 . 117343) (CDBROWSER-COPY 117345 . 121014) (CDBROWSER-DELETE-FILE 121016 . 124229) (CD-SWAPDIRS
|
||||
124231 . 124748)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "12-May-2022 10:17:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;123 41825
|
||||
(FILECREATED "22-May-2022 18:46:01"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPARESOURCES.;128 39655
|
||||
|
||||
:CHANGES-TO (FNS CSBROWSER)
|
||||
:CHANGES-TO (FNS COMPARESOURCES CSBROWSER \CS.EXAMINE)
|
||||
(VARS COMPARESOURCESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "11-May-2022 19:12:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;122)
|
||||
:PREVIOUS-DATE "12-May-2022 10:17:13"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPARESOURCES.;123)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -29,7 +30,6 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
'CSOBJ.COPYBUTTONEVENTINFN]
|
||||
(VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS)
|
||||
(COMS (FNS CSBROWSER)
|
||||
(INITVARS (COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW))
|
||||
(FILES (SYSLOAD)
|
||||
OBJECTWINDOW EXAMINEDEFS REGIONMANAGER))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE)
|
||||
@@ -37,19 +37,15 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARESOURCES
|
||||
[LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM IGNORECOMMENTS)(* ; "Edited 11-May-2022 19:12 by rmk")
|
||||
(* ; "Edited 28-Jan-2022 17:10 by rmk")
|
||||
(* ; "Edited 26-Dec-2021 21:32 by rmk")
|
||||
(* ; "Edited 19-Apr-2018 10:49 by rmk:")
|
||||
[LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM IGNORECOMMENTS LABELX LABELY)
|
||||
(* ; "Edited 22-May-2022 18:45 by rmk")
|
||||
|
||||
(* ;;; "Compare two lisp source files, reporting differences. LISTSTREAM if given is an open stream")
|
||||
(* ;;; "Compare two lisp source files, reporting differences. LISTSTREAM if given is an open stream, or an object window")
|
||||
|
||||
(DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES))
|
||||
(PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY DATECOL
|
||||
[INSERTOBJECTS (AND EXAMINE (IF (TEXTSTREAMP LISTSTREAM)
|
||||
THEN 'TEDIT
|
||||
ELSEIF (OBJWINDOWP LISTSTREAM)
|
||||
THEN 'OBJECTWINDOW]
|
||||
(PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY DATECOL (INSERTOBJECTS
|
||||
(AND EXAMINE (OBJWINDOWP
|
||||
LISTSTREAM)))
|
||||
(COMPARESTREAM LISTSTREAM)
|
||||
(CONTEXTSTREAM LISTSTREAM)
|
||||
OBJECTS)
|
||||
@@ -59,10 +55,12 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(SETQ CONTEXTSTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
|
||||
(LINELENGTH 65535 COMPARESTREAM) (* ; "Let the receiver do the wrapping")
|
||||
(LINELENGTH 65535 CONTEXTSTREAM))
|
||||
(OR (INFILEP FILEX)
|
||||
(OR (STREAMP FILEX)
|
||||
(INFILEP FILEX)
|
||||
(SETQ FILEX (FINDFILE FILEX T))
|
||||
(RETURN (printout CONTEXTSTREAM FILEX " not found" T)))
|
||||
(OR (INFILEP FILEY)
|
||||
(OR (STREAMP FILEY)
|
||||
(INFILEP FILEY)
|
||||
(SETQ FILEY (FINDFILE FILEY T))
|
||||
(RETURN (printout CONTEXTSTREAM FILEY " not found" T)))
|
||||
|
||||
@@ -79,15 +77,18 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(DECLARE (SPECVARS *REMOVE-INTERLISP-COMMENTS*))
|
||||
(SETQ BODYX (REMOVE-COMMENTS BODYX))
|
||||
(SETQ BODYY (REMOVE-COMMENTS BODYY))))
|
||||
(CL:UNLESS LABELX (SETQ LABELX FILEX))
|
||||
(CL:UNLESS LABELY (SETQ LABELY FILEY))
|
||||
[SETQ DATECOL (PLUS 2 (CONSTANT (NCHARS "Comparing"))
|
||||
(IMAX (NCHARS FILEX)
|
||||
(NCHARS FILEY]
|
||||
(printout CONTEXTSTREAM "Comparing " FILEX .TAB0 DATECOL "dated " (GETFILEINFO FILEX
|
||||
'CREATIONDATE)
|
||||
(IMAX (NCHARS LABELX)
|
||||
(NCHARS LABELY]
|
||||
(printout CONTEXTSTREAM "Comparing " LABELX .TAB0 DATECOL "dated " (GETFILEINFO
|
||||
FILEX
|
||||
'CREATIONDATE)
|
||||
.TAB
|
||||
[SUB1 (CONSTANT (IDIFFERENCE (NCHARS "Comparing ")
|
||||
(NCHARS "and "]
|
||||
" and " FILEY .TAB0 DATECOL "dated " (GETFILEINFO FILEY 'CREATIONDATE)
|
||||
" and " LABELY .TAB0 DATECOL "dated " (GETFILEINFO FILEY 'CREATIONDATE)
|
||||
T T)
|
||||
[SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR)
|
||||
'DECLARE%:]
|
||||
@@ -131,15 +132,11 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(REVERSE Y)
|
||||
DW?]
|
||||
(TERPRI CONTEXTSTREAM))
|
||||
(SELECTQ INSERTOBJECTS
|
||||
(OBJECTWINDOW (CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE (CL:GET-OUTPUT-STREAM-STRING
|
||||
CONTEXTSTREAM))))
|
||||
(SETQ OBJECTS (DREVERSE OBJECTS))
|
||||
(OBJ.ADDMANYTOW LISTSTREAM OBJECTS))
|
||||
(TEDIT (HELP "Don't know about TEDIT"))
|
||||
(NIL)
|
||||
(HELP))
|
||||
(CL:WHEN INSERTOBJECTS
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE (CL:GET-OUTPUT-STREAM-STRING CONTEXTSTREAM))))
|
||||
(SETQ OBJECTS (DREVERSE OBJECTS))
|
||||
(OBJ.ADDMANYTOW LISTSTREAM OBJECTS))
|
||||
(RETURN (OR (REVERSE DIFFERENCES)
|
||||
'SAME])
|
||||
|
||||
@@ -304,13 +301,8 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
RESULT)])
|
||||
|
||||
(\CS.EXAMINE
|
||||
[LAMBDA (X Y ONLYONE NAME TYPE) (* ; "Edited 24-Dec-2021 22:48 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 22:46 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 23:23 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 16:43 by rmk")
|
||||
(* ; "Edited 2-Dec-2021 15:23 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 20:37 by rmk:")
|
||||
(* ; "Edited 27-Nov-2021 11:21 by rmk:")
|
||||
[LAMBDA (X Y ONLYONE NAME TYPE) (* ; "Edited 22-May-2022 16:28 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 11:21 by rmk:")
|
||||
(DECLARE (USEDFREE EXAMINE INSERTOBJECTS COMPARESTREAM CONTEXTSTREAM OBJECTS))
|
||||
|
||||
(* ;; "ONLYONE as a flag, because we don't want to test X or Y for NIL, that could be the contrasting value.")
|
||||
@@ -324,34 +316,30 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(* ;; "Context gets printed to the CONTEXTSTREAM, diffs go to the COMPARESTREAM. If we aren't doing objects, those are the same streams, and the output gets printed in the right order. Nothing to do here.")
|
||||
|
||||
(IF INSERTOBJECTS
|
||||
THEN (SELECTQ INSERTOBJECTS
|
||||
(OBJECTWINDOW [LET (STRING)
|
||||
THEN [LET (STRING)
|
||||
|
||||
(* ;; "Take out last EOL, let SEPDIST space things out.")
|
||||
(* ;; "Take out last EOL, let SEPDIST space things out.")
|
||||
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING CONTEXTSTREAM))
|
||||
(CL:WHEN (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING)))
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR COMPARESTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING COMPARESTREAM))
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING CONTEXTSTREAM))
|
||||
(CL:WHEN (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING)))
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR COMPARESTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING COMPARESTREAM))
|
||||
|
||||
(* ;; "Don't know why, but SEPTDIST doesn't work if there if there isn't at least one EOL. Magically, this gets the right appearance and behavior.")
|
||||
(* ;; "Don't know why, but SEPTDIST doesn't work if there if there isn't at least one EOL. Magically, this gets the right appearance and behavior.")
|
||||
|
||||
(CL:WHEN (AND (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -2)))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING
|
||||
(LIST NAME TYPE X Y LABEL1 LABEL2)
|
||||
ONLYONE)))])
|
||||
(TEDIT (HELP "TEDIT NOT IMPLEMENTED"))
|
||||
NIL)
|
||||
(CL:WHEN (AND (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -2)))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING (LIST NAME TYPE X Y LABEL1 LABEL2)
|
||||
ONLYONE)))]
|
||||
ELSEIF (OR (LISTP X)
|
||||
(LISTP Y))
|
||||
THEN (* ;
|
||||
@@ -634,8 +622,11 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(CSBROWSER
|
||||
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION IGNORECOMMENTS)
|
||||
(* ; "Edited 12-May-2022 10:16 by rmk")
|
||||
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION IGNORECOMMENTS TITLE)
|
||||
|
||||
(* ;; "Edited 22-May-2022 18:42 by rmk")
|
||||
|
||||
(* ;; "Edited 12-May-2022 10:16 by rmk")
|
||||
|
||||
(* ;; "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.")
|
||||
|
||||
@@ -646,44 +637,33 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(* ;; "Don't use the INFILEP value, because that might screw with capitalization that the caller prefers. If the file can be found that way, then lower functions will find it.")
|
||||
|
||||
(DECLARE (SPECVARS LABEL1 LABEL2))
|
||||
(SETQ FILEX (OR (INFILEP FILEX)
|
||||
(SETQ FILEX (OR (STREAMP FILEX)
|
||||
(INFILEP FILEX)
|
||||
(FINDFILE FILEX NIL DIRECTORIES)
|
||||
(ERROR "FILE NOT FOUND" FILEX)))
|
||||
(SETQ FILEY (OR (INFILEP FILEY)
|
||||
(SETQ FILEY (OR (STREAMP FILEY)
|
||||
(INFILEP FILEY)
|
||||
(FINDFILE FILEY NIL DIRECTORIES)
|
||||
(ERROR "FILE NOT FOUND" FILEY)))
|
||||
(CL:UNLESS (LISPSOURCEFILEP FILEX)
|
||||
(ERROR FILEX " is not a Medley source file"))
|
||||
(CL:UNLESS (LISPSOURCEFILEP FILEY)
|
||||
(ERROR FILEX " is not a Medley source file"))
|
||||
(LET [(TITLE (CONCAT "COMPARESOURCES of " (OR LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL
|
||||
'BODY FILEX))
|
||||
" and "
|
||||
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY]
|
||||
(SELECTQ COMPARESOURCES-BROWSER-TYPE
|
||||
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T
|
||||
(FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
|
||||
(GETPROMPTWINDOW WINDOW T)
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
|
||||
(COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
|
||||
DW? WINDOW IGNORECOMMENTS)
|
||||
(OPENW WINDOW)
|
||||
WINDOW))
|
||||
(TEDIT (LET ((TSTREAM (OPENTEXTSTREAM)))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(COMPARESOURCES FILEX FILEY EXAMINE DW? TSTREAM IGNORECOMMENTS)
|
||||
[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])
|
||||
(CL:UNLESS TITLE
|
||||
[SETQ TITLE (CONCAT "COMPARESOURCES of " (OR LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL
|
||||
'BODY FILEX))
|
||||
" and "
|
||||
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY])
|
||||
(LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T (FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
|
||||
(GETPROMPTWINDOW WINDOW T)
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
|
||||
(COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
|
||||
DW? WINDOW IGNORECOMMENTS LABEL1 LABEL2)
|
||||
(OPENW WINDOW)
|
||||
WINDOW])
|
||||
)
|
||||
|
||||
(RPAQ? COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW)
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
OBJECTWINDOW EXAMINEDEFS REGIONMANAGER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
@@ -699,16 +679,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 (1852 26954 (COMPARESOURCES 1862 . 8290) (\CS.COMPARE.MASTERS 8292 . 15704) (
|
||||
\CS.COMPARE.TYPES 15706 . 18972) (\CS.EXAMINE 18974 . 23201) (\CS.FIXFNS 23203 . 24705) (
|
||||
\CS.SORT.DECLARES 24707 . 25050) (\CS.SORT.DECLARE1 25052 . 26472) (\CS.FILTER.GARBAGE 26474 . 26952))
|
||||
(26955 31491 (\CS.ISFNFORM 26965 . 27233) (\CS.COMPARE.FNS 27235 . 27477) (\CS.FNSID 27479 . 27623) (
|
||||
\CS.ISVARFORM 27625 . 27730) (\CS.COMPARE.VARS 27732 . 28394) (\CS.ISMACROFORM 28396 . 28534) (
|
||||
\CS.ISRECFORM 28536 . 28864) (\CS.REC.NAME 28866 . 29185) (\CS.ISCOURIERFORM 29187 . 29287) (
|
||||
\CS.ISTEMPLATEFORM 29289 . 29387) (\CS.COMPARE.TEMPLATES 29389 . 29754) (\CS.ISPROPFORM 29756 . 29911)
|
||||
(\CS.PROP.NAME 29913 . 30058) (\CS.COMPARE.PROPS 30060 . 30217) (\CS.ISADDVARFORM 30219 . 30312) (
|
||||
\CS.COMPARE.ADDVARS 30314 . 30479) (\CS.ISFPKGCOMFORM 30481 . 30688) (\CS.COMPARE.FPKGCOMS 30690 .
|
||||
30897) (\CS.COMPARE.DEFINE-FILE-INFO 30899 . 31489)) (31492 37556 (CSOBJ.CREATE 31502 . 31915) (
|
||||
CSOBJ.DISPLAYFN 31917 . 32670) (CSOBJ.IMAGEBOXFN 32672 . 34833) (CSOBJ.BUTTONEVENTINFN 34835 . 37306)
|
||||
(CSOBJ.COPYBUTTONEVENTINFN 37308 . 37554)) (38437 41343 (CSBROWSER 38447 . 41341)))))
|
||||
(FILEMAP (NIL (1864 25616 (COMPARESOURCES 1874 . 8001) (\CS.COMPARE.MASTERS 8003 . 15415) (
|
||||
\CS.COMPARE.TYPES 15417 . 18683) (\CS.EXAMINE 18685 . 21863) (\CS.FIXFNS 21865 . 23367) (
|
||||
\CS.SORT.DECLARES 23369 . 23712) (\CS.SORT.DECLARE1 23714 . 25134) (\CS.FILTER.GARBAGE 25136 . 25614))
|
||||
(25617 30153 (\CS.ISFNFORM 25627 . 25895) (\CS.COMPARE.FNS 25897 . 26139) (\CS.FNSID 26141 . 26285) (
|
||||
\CS.ISVARFORM 26287 . 26392) (\CS.COMPARE.VARS 26394 . 27056) (\CS.ISMACROFORM 27058 . 27196) (
|
||||
\CS.ISRECFORM 27198 . 27526) (\CS.REC.NAME 27528 . 27847) (\CS.ISCOURIERFORM 27849 . 27949) (
|
||||
\CS.ISTEMPLATEFORM 27951 . 28049) (\CS.COMPARE.TEMPLATES 28051 . 28416) (\CS.ISPROPFORM 28418 . 28573)
|
||||
(\CS.PROP.NAME 28575 . 28720) (\CS.COMPARE.PROPS 28722 . 28879) (\CS.ISADDVARFORM 28881 . 28974) (
|
||||
\CS.COMPARE.ADDVARS 28976 . 29141) (\CS.ISFPKGCOMFORM 29143 . 29350) (\CS.COMPARE.FPKGCOMS 29352 .
|
||||
29559) (\CS.COMPARE.DEFINE-FILE-INFO 29561 . 30151)) (30154 36218 (CSOBJ.CREATE 30164 . 30577) (
|
||||
CSOBJ.DISPLAYFN 30579 . 31332) (CSOBJ.IMAGEBOXFN 31334 . 33495) (CSOBJ.BUTTONEVENTINFN 33497 . 35968)
|
||||
(CSOBJ.COPYBUTTONEVENTINFN 35970 . 36216)) (37099 39228 (CSBROWSER 37109 . 39226)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
597
lispusers/GITFNS
597
lispusers/GITFNS
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "13-May-2022 10:51:44" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;278 95386
|
||||
(FILECREATED " 4-Jun-2022 20:44:07"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>GITFNS.;313 100657
|
||||
|
||||
:CHANGES-TO (COMMANDS cdg cdw)
|
||||
(VARS GITFNSCOMS)
|
||||
:CHANGES-TO (FNS GIT-BRANCH-DIFF)
|
||||
|
||||
:PREVIOUS-DATE "13-May-2022 10:45:15"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;277)
|
||||
:PREVIOUS-DATE "29-May-2022 21:59:23"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>GITFNS.;312)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT GITFNSCOMS)
|
||||
@@ -40,7 +40,7 @@
|
||||
(* ;; "Lisp exec commands")
|
||||
|
||||
(INITVARS (GIT-MERGE-COMPARES T))
|
||||
(COMMANDS gmc bbc prc cob b? cdg cdw)
|
||||
(COMMANDS gwc bbc prc cob b? cdg cdw)
|
||||
|
||||
(* ;; "")
|
||||
|
||||
@@ -69,8 +69,9 @@
|
||||
|
||||
(* ;; "Branches")
|
||||
|
||||
(FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS?
|
||||
GIT-PICK-BRANCH GIT-PRC-MENU GIT-PULL-REQUESTS)
|
||||
(FNS GIT-BRANCH-NUM GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES
|
||||
GIT-BRANCH-EXISTS? GIT-PICK-BRANCH GIT-PRC-MENU GIT-PULL-REQUESTS GIT-SHORT-BRANCH-NAME
|
||||
GIT-LONG-NAME)
|
||||
|
||||
(* ;; "My branches")
|
||||
|
||||
@@ -88,8 +89,9 @@
|
||||
|
||||
(* ;; "Comparisons")
|
||||
|
||||
(FNS GIT-GET-DIFFERENT-FILES GIT-COMPARE-BRANCHES GIT-COMPARE-WITH-MYMEDLEY
|
||||
GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN)
|
||||
(FNS GIT-GET-DIFFERENT-FILES GIT-BRANCHES-COMPARE-DIRECTORIES GIT-WORKING-COMPARE-DIRECTORIES
|
||||
GIT-COMPARE-WORKTREE GITCDOBJBUTTONFN GIT-CD-LABELFN GIT-CD-MENUFN
|
||||
GIT-WORKING-COMPARE-FILES GIT-BRANCHES-COMPARE-FILES)
|
||||
(INITVARS (FROMGITN 0))
|
||||
|
||||
(* ;; "")
|
||||
@@ -97,7 +99,8 @@
|
||||
|
||||
(* ;; "Utilities")
|
||||
|
||||
(FNS CDGITDIR GIT-COMMAND GITORIGIN GIT-INITIALS)))
|
||||
(FNS CDGITDIR GIT-COMMAND GITORIGIN GIT-INITIALS)
|
||||
(PROPS (GITFNS FILETYPE))))
|
||||
|
||||
|
||||
|
||||
@@ -141,6 +144,7 @@
|
||||
|
||||
(GIT-MAKE-PROJECT
|
||||
[LAMBDA (PROJECTNAME PROJECTPATH WORKINGPATH EXCLUSIONS DEFAULTSUBDIRS)
|
||||
(* ; "Edited 17-May-2022 17:08 by rmk")
|
||||
(* ; "Edited 13-May-2022 10:40 by rmk")
|
||||
(* ; "Edited 12-May-2022 00:26 by rmk")
|
||||
(* ; "Edited 9-May-2022 16:20 by rmk")
|
||||
@@ -201,26 +205,49 @@
|
||||
`("deleted/" "*.sysout"))
|
||||
:TEST
|
||||
(FUNCTION STRING.EQUAL)))
|
||||
[SETQ WP
|
||||
(DIRECTORYNAME (SELECTQ WORKINGPATH
|
||||
((T NIL)
|
||||
(PACKFILENAME.STRING 'HOST 'DSK 'BODY
|
||||
(CONCAT (SUBSTRING CLONEPATH 1
|
||||
(STRPOS "/" CLONEPATH -2 NIL NIL NIL
|
||||
FILEDIRCASEARRAY T))
|
||||
"my-"
|
||||
(OR (SUBSTRING PROJECTPATH
|
||||
(OR (STRPOS CLONEPATH PROJECTPATH 1
|
||||
NIL NIL T FILEDIRCASEARRAY)
|
||||
-2))
|
||||
(L-CASE PROJECTNAME))
|
||||
">")))
|
||||
(TRUEFILENAME WORKINGPATH]
|
||||
|
||||
(* ;; "The %"my-%" case is for backward compatibility, eventually deprecated.")
|
||||
|
||||
(SETQ WP
|
||||
(SELECTQ WORKINGPATH
|
||||
((T NIL)
|
||||
(OR (DIRECTORYNAME (PACKFILENAME.STRING
|
||||
'HOST
|
||||
'DSK
|
||||
'BODY
|
||||
(CONCAT (SUBSTRING CLONEPATH 1
|
||||
(STRPOS "/" CLONEPATH -2 NIL NIL NIL
|
||||
FILEDIRCASEARRAY T))
|
||||
"working-"
|
||||
(OR (SUBSTRING PROJECTPATH
|
||||
(OR (STRPOS CLONEPATH PROJECTPATH 1 NIL
|
||||
NIL T FILEDIRCASEARRAY)
|
||||
-2))
|
||||
(L-CASE PROJECTNAME))
|
||||
">"))
|
||||
T)
|
||||
(DIRECTORYNAME (PACKFILENAME.STRING
|
||||
'HOST
|
||||
'DSK
|
||||
'BODY
|
||||
(CONCAT (SUBSTRING CLONEPATH 1
|
||||
(STRPOS "/" CLONEPATH -2 NIL NIL NIL
|
||||
FILEDIRCASEARRAY T))
|
||||
"my-"
|
||||
(OR (SUBSTRING PROJECTPATH
|
||||
(OR (STRPOS CLONEPATH PROJECTPATH 1 NIL
|
||||
NIL T FILEDIRCASEARRAY)
|
||||
-2))
|
||||
(L-CASE PROJECTNAME))
|
||||
">"))
|
||||
T)))
|
||||
(DIRECTORYNAME (TRUEFILENAME WORKINGPATH)
|
||||
T)))
|
||||
[SETQ WORKINGPATH (IF WP
|
||||
THEN (UNSLASHIT WP T)
|
||||
ELSEIF (EQ WORKINGPATH T)
|
||||
THEN NIL
|
||||
ELSE (ERROR (CONCAT "Can't find my working directory "
|
||||
ELSE (ERROR (CONCAT "Can't find the working directory "
|
||||
(OR WORKINGPATH "")
|
||||
" for " PROJECTNAME]
|
||||
(SETQ PROJECT (CREATE GIT-PROJECT
|
||||
@@ -350,7 +377,7 @@
|
||||
|
||||
(RPAQ? GIT-MERGE-COMPARES T)
|
||||
|
||||
(DEFCOMMAND gmc (SUBDIR . OTHERS)
|
||||
(DEFCOMMAND gwc (SUBDIR . OTHERS)
|
||||
|
||||
(* ;; "Compares the specified local git-medley subdirectories against my working Medley. The SUBDIRS are the arguments up to one that looks like a project")
|
||||
|
||||
@@ -361,14 +388,28 @@
|
||||
THEN (SETQ PROJECT (CAR STAIL))
|
||||
(GO $$OUT))
|
||||
(CAR STAIL)))
|
||||
(GIT-COMPARE-WITH-MYMEDLEY SUBDIRS NIL NIL NIL T PROJECT)))
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES SUBDIRS NIL NIL NIL T PROJECT)))
|
||||
|
||||
(DEFCOMMAND bbc (BRANCH1 BRANCH2 LOCAL PROJECT)
|
||||
|
||||
(* ;; "Compares 2 git branches. Defaults to local/ if LOCAL, otherwise defaults to origin/. BRANCH2 defaults to the main branch (origin/ or local/ depending on LOCAL)")
|
||||
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(GIT-COMPARE-BRANCHES BRANCH1 (OR BRANCH (GIT-MAINBRANCH PROJECT LOCAL))
|
||||
(SETQ BRANCH1 (SELECTQ (U-CASE BRANCH1)
|
||||
((NIL T)
|
||||
(GIT-MY-CURRENT-BRANCH PROJECT))
|
||||
((LOCAL REMOTE ORIGIN)
|
||||
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH1 PROJECT T)))
|
||||
(OR (GIT-LONG-NAME BRANCH1 NIL PROJECT)
|
||||
BRANCH1)))
|
||||
(SETQ BRANCH2 (SELECTQ (U-CASE BRANCH2)
|
||||
((NIL T)
|
||||
(GIT-MAINBRANCH PROJECT LOCAL))
|
||||
((LOCAL REMOTE ORIGIN)
|
||||
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH2 PROJECT T)))
|
||||
(OR (GIT-LONG-NAME BRANCH2 NIL PROJECT)
|
||||
BRANCH2)))
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES BRANCH1 (OR BRANCH2 (GIT-MAINBRANCH PROJECT LOCAL))
|
||||
LOCAL PROJECT))
|
||||
|
||||
(DEFCOMMAND prc (REMOTEBRANCH DRAFTS PROJECT)
|
||||
@@ -378,41 +419,45 @@
|
||||
(LET ((RB REMOTEBRANCH)
|
||||
(DR DRAFTS))
|
||||
(IF PROJECT
|
||||
THEN (SETQ PROOJECT (GIT-GET-PROJECT PROJECT))
|
||||
THEN (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
ELSEIF (GIT-GET-PROJECT RB T)
|
||||
THEN (SETQ PROJECT RB)
|
||||
(SETQ RB NIL)
|
||||
ELSEIF (GIT-GET-PROJECT DRAFTS T)
|
||||
THEN (SETQ PROJECT DRAFTS)
|
||||
(SETQ DRAFTS NIL))
|
||||
(SETQ DRFTS NIL))
|
||||
(CL:WHEN (MEMB (U-CASE RB)
|
||||
'(DRAFT DRAFTS))
|
||||
(SETQ RB NIL)
|
||||
(SETQ DR T))
|
||||
(CL:WHEN (OR RB (SETQ RB (GIT-PICK-BRANCH (GIT-PRC-MENU DR PROJECT)
|
||||
"Pull requests" NIL PROJECT)))
|
||||
(GIT-COMPARE-BRANCHES RB (GIT-MAINBRANCH PROJECT)
|
||||
"Pull requests")))
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES RB (GIT-MAINBRANCH PROJECT)
|
||||
NIL PROJECT))))
|
||||
|
||||
(DEFCOMMAND cob (BRANCH PROJECT)
|
||||
(DEFCOMMAND cob (BRANCH NEXTTITLESTRING PROJECT)
|
||||
|
||||
(* ;; "Switches to BRANCH. T means my current branch, NEW/NEXT means my next branch (under wherever we are now). Default is to bring up a menu of locally available branches.")
|
||||
(* ;; "Switches to BRANCH. T means my current branch, NEW/NEXT means my next branch (under wherever we are now), and NEXTTITLESTRING if given will be attached to the branch-name. Default is to bring up a menu of locally available branches.")
|
||||
|
||||
(CL:UNLESS PROJECT
|
||||
(CL:WHEN (GIT-GET-PROJECT BRANCH T)
|
||||
(SETQ PROJECT BRANCH)
|
||||
(SETQ BRANCH NIL)))
|
||||
(CL:UNLESS (STRINGP NEXTTITLESTRING)
|
||||
(SETQ PROJECT NEXTTITLESTRING))
|
||||
(CL:UNLESS PROJECT
|
||||
(CL:WHEN (GIT-GET-PROJECT BRANCH T)
|
||||
(SETQ PROJECT BRANCH)
|
||||
(SETQ BRANCH NIL)))
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SELECTQ (U-CASE BRANCH)
|
||||
(T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH PROJECT)
|
||||
PROJECT))
|
||||
((NEW NEXT)
|
||||
(GIT-MAKE-BRANCH NIL NIL PROJECT))
|
||||
(GIT-CHECKOUT (OR BRANCH (GIT-PICK-BRANCH NIL (CONCAT (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
T)
|
||||
" branches")
|
||||
'LOCAL PROJECT))
|
||||
PROJECT)))
|
||||
(GIT-MAKE-BRANCH NIL NEXTTITLESTRING PROJECT))
|
||||
(CL:WHEN [SETQ BRANCH (IF BRANCH
|
||||
THEN (GIT-LONG-NAME BRANCH NIL PROJECT)
|
||||
ELSE (GIT-PICK-BRANCH (GIT-BRANCHES 'LOCAL PROJECT T)
|
||||
(CONCAT (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
T)
|
||||
" branches"]
|
||||
(GIT-CHECKOUT BRANCH PROJECT))))
|
||||
|
||||
(DEFCOMMAND b? (PROJECT) (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(CONCAT (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
@@ -737,6 +782,8 @@
|
||||
(GIT-GET-FILE
|
||||
[LAMBDA (BRANCH GITFILE LOCALFILE NOERROR PROJECT)
|
||||
|
||||
(* ;; "Edited 22-May-2022 17:34 by rmk")
|
||||
|
||||
(* ;; "Edited 8-May-2022 16:54 by rmk: the stream, not the name because of the NODIRCORE case.")
|
||||
|
||||
(* ;; "Edited 6-Mar-2022 17:45 by rmk: the stream, not the name because of the NODIRCORE case.")
|
||||
@@ -840,6 +887,8 @@
|
||||
(GIT-BRANCH-DIFF
|
||||
[LAMBDA (BRANCH1 BRANCH2 PROJECT)
|
||||
|
||||
(* ;; "Edited 4-Jun-2022 20:43 by rmk")
|
||||
|
||||
(* ;; "Edited 9-May-2022 16:21 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
|
||||
|
||||
(* ;; "Edited 6-May-2022 14:04 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).")
|
||||
@@ -863,7 +912,7 @@
|
||||
POS NIL T)
|
||||
THEN BRANCH1
|
||||
ELSE BRANCH2)))
|
||||
(SORT [FOR L IN LINES
|
||||
(SORT (FOR L IN LINES
|
||||
COLLECT (SELCHARQ (CHCON1 L)
|
||||
(A (CL:IF (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 2))
|
||||
@@ -897,7 +946,7 @@
|
||||
" Ignore remaining files? "
|
||||
)))
|
||||
(ERROR!)))
|
||||
(HELP "Unrecognized git-diff code" (NTHCHAR L 1]
|
||||
(HELP "Unrecognized git-diff code %"" L "%"")))
|
||||
T])
|
||||
|
||||
(GIT-COMMIT-DIFFS
|
||||
@@ -910,65 +959,61 @@
|
||||
NIL NIL PROJECT])
|
||||
|
||||
(GIT-BRANCH-RELATIONS
|
||||
[LAMBDA (BRANCHES BRANCH2 STRIPWHERE PROJECT) (* ; "Edited 9-May-2022 16:12 by rmk")
|
||||
[LAMBDA (BRANCHES BRANCH2 STRIPWHERE PROJECT) (* ; "Edited 29-May-2022 21:59 by rmk")
|
||||
(* ; "Edited 9-May-2022 16:12 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
|
||||
(* ;; "Returns a pair (SUPERSETS EQUALS), where each item in SUPERSETS is a list of the form (B0 B1 B2...) where each Bi is a superset of Bj for i < j and EQUALS is a list of branch equivalence classes. ")
|
||||
|
||||
(CL:WHEN BRANCH2
|
||||
(SETQ BRANCHES (LIST BRANCHES BRANCH2)))
|
||||
(FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS ON (FOR B IN BRANCHES
|
||||
COLLECT (CONS B (GIT-COMMIT-DIFFS B (
|
||||
GIT-MAINBRANCH
|
||||
PROJECT)
|
||||
PROJECT)))
|
||||
DO
|
||||
(* ;; "For each branch we now have the list of commit identifiers (hexstrings) that they do not share with the main branch.")
|
||||
(LET
|
||||
((MAIN (GIT-MAINBRANCH PROJECT)))
|
||||
(FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
|
||||
ON (FOR B IN BRANCHES COLLECT (CONS B (GIT-COMMIT-DIFFS B MAIN PROJECT)))
|
||||
DO
|
||||
(* ;; "For each branch we now have the list of commit identifiers (hexstrings) that they do not share with the main branch.")
|
||||
|
||||
(SETQ D1 (CAR DTAIL))
|
||||
[FOR D2 IN (CDR DTAIL)
|
||||
DO (CL:WHEN (EQUAL (CDR D1)
|
||||
(CDR D2)) (* ; "Unlikely")
|
||||
(PUSH [CDR (OR (ASSOC (CAR D1)
|
||||
EQUALS)
|
||||
(CAR (PUSH EQUALS (CONS (CAR D1]
|
||||
(CAR D2))
|
||||
(GO $$ITERATE))
|
||||
(SETQ MORE2 (MEMBER (CADR D1)
|
||||
(CDR D2))) (* ;
|
||||
(SETQ D1 (CAR DTAIL))
|
||||
[FOR D2 IN (CDR DTAIL)
|
||||
DO (CL:WHEN (EQUAL (CDR D1)
|
||||
(CDR D2)) (* ; "Unlikely")
|
||||
(PUSH [CDR (OR (ASSOC (CAR D1)
|
||||
EQUALS)
|
||||
(CAR (PUSH EQUALS (CONS (CAR D1]
|
||||
(CAR D2))
|
||||
(GO $$ITERATE))
|
||||
(SETQ MORE2 (MEMBER (CADR D1)
|
||||
(CDR D2))) (* ;
|
||||
"The most recent commit of D1 is in D2")
|
||||
(SETQ MORE1 (MEMBER (CADR D2)
|
||||
(CDR D1)))
|
||||
(IF MORE2
|
||||
THEN (CL:UNLESS MORE1
|
||||
(PUSH [CDR (OR (ASSOC (CAR D2)
|
||||
SUPERSETS)
|
||||
(CAR (PUSH SUPERSETS (CONS (CAR D2]
|
||||
(CAR D1)))
|
||||
ELSEIF MORE1
|
||||
THEN (PUSH [CDR (OR (ASSOC (CAR D1)
|
||||
SUPERSETS)
|
||||
(CAR (PUSH SUPERSETS (CONS (CAR D1]
|
||||
(CAR D2]
|
||||
FINALLY
|
||||
(SETQ MORE1 (MEMBER (CADR D2)
|
||||
(CDR D1)))
|
||||
(IF MORE2
|
||||
THEN (CL:UNLESS MORE1
|
||||
(PUSH [CDR (OR (ASSOC (CAR D2)
|
||||
SUPERSETS)
|
||||
(CAR (PUSH SUPERSETS (CONS (CAR D2]
|
||||
(CAR D1)))
|
||||
ELSEIF MORE1
|
||||
THEN (PUSH [CDR (OR (ASSOC (CAR D1)
|
||||
SUPERSETS)
|
||||
(CAR (PUSH SUPERSETS (CONS (CAR D1]
|
||||
(CAR D2]
|
||||
FINALLY
|
||||
|
||||
(* ;; "Sort the supersets so that the larger ones come before the smaller ones")
|
||||
(* ;; "Sort the supersets so that the larger ones come before the smaller ones")
|
||||
|
||||
(CL:WHEN STRIPWHERE
|
||||
[SETQ SUPERSETS (FOR S IN SUPERSETS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS]
|
||||
[SETQ EQUALS (FOR S IN EQUALS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS])
|
||||
[FOR S IN SUPERSETS
|
||||
DO (CHANGE (CDR S)
|
||||
(SORT DATUM (FUNCTION (LAMBDA (B1 B2)
|
||||
(OR (MEMB B2 (CDR (ASSOC B1 SUPERSETS)))
|
||||
(NOT (MEMB B1 (CDR (ASSOC B2 SUPERSETS]
|
||||
[FOR E IN EQUALS DO (CHANGE (CDR E)
|
||||
(IF (MEMB (GIT-MAINBRANCH PROJECT)
|
||||
(CDR E))
|
||||
THEN (CONS (GIT-MAINBRANCH PROJECT)
|
||||
(DREMOVE (GIT-MAINBRANCH PROJECT)
|
||||
(SORT DATUM)))
|
||||
ELSE (SORT DATUM]
|
||||
(RETURN (LIST SUPERSETS EQUALS])
|
||||
(CL:WHEN STRIPWHERE
|
||||
[SETQ SUPERSETS (FOR S IN SUPERSETS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS]
|
||||
[SETQ EQUALS (FOR S IN EQUALS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS])
|
||||
[FOR S IN SUPERSETS
|
||||
DO (CHANGE (CDR S)
|
||||
(SORT DATUM (FUNCTION (LAMBDA (B1 B2)
|
||||
(OR (MEMB B2 (CDR (ASSOC B1 SUPERSETS)))
|
||||
(NOT (MEMB B1 (CDR (ASSOC B2 SUPERSETS]
|
||||
[FOR E IN EQUALS DO (CHANGE (CDR E)
|
||||
(IF (MEMB MAIN (CDR E))
|
||||
THEN (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
|
||||
ELSE (SORT DATUM]
|
||||
(RETURN (LIST SUPERSETS EQUALS])
|
||||
)
|
||||
|
||||
|
||||
@@ -982,6 +1027,19 @@
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(GIT-BRANCH-NUM
|
||||
[LAMBDA (BRANCH INITS) (* ; "Edited 19-May-2022 19:11 by rmk")
|
||||
|
||||
(* ;; "Returns nnn if BRANCH is ({local|origin}/)INITSnnn(-xxxx)")
|
||||
|
||||
(CL:UNLESS INITS
|
||||
(SETQ INITS (GIT-INITIALS)))
|
||||
(LET (NPOS (SPOS (OR (STRPOS "/" BRANCH 1 NIL NIL T)
|
||||
1)))
|
||||
(CL:WHEN (SETQ NPOS (STRPOS INITS BRANCH SPOS NIL NIL T UPPERCASEARRAY))
|
||||
[NUMBERP (SUBATOM BRANCH NPOS (SUB1 (OR (STRPOS "-" BRANCH NPOS)
|
||||
0])])
|
||||
|
||||
(GIT-CHECKOUT
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 9-May-2022 15:12 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:51 by rmk")
|
||||
@@ -998,7 +1056,8 @@
|
||||
(MKATOM (CONCAT "local/" (CAR (GIT-COMMAND "git rev-parse --abbrev-ref HEAD" NIL NIL PROJECT])
|
||||
|
||||
(GIT-MAKE-BRANCH
|
||||
[LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 9-May-2022 15:13 by rmk")
|
||||
[LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 19-May-2022 17:57 by rmk")
|
||||
(* ; "Edited 9-May-2022 15:13 by rmk")
|
||||
|
||||
(* ;; " The new branch is directly under the currently checked out branch. Maybe it should always make it under the main branch?")
|
||||
|
||||
@@ -1010,7 +1069,14 @@
|
||||
(CL:UNLESS NAME
|
||||
(SETQ NAME (GIT-MY-NEXT-BRANCH PROJECT)))
|
||||
(CL:WHEN TITLESTRING
|
||||
(SETQ NAME (CONCAT NAME (CONCAT ": " TITLESTRING))))
|
||||
|
||||
(* ;; "Git branch names can't contain spaces or colons")
|
||||
|
||||
[SETQ TITLESTRING (CONCATCODES (FOR I C FROM 1 WHILE (SETQ C (NTHCHARCODE TITLESTRING I))
|
||||
COLLECT (IF (EQ C (CHARCODE SPACE))
|
||||
THEN (CHARCODE -)
|
||||
ELSE C]
|
||||
(SETQ NAME (CONCAT NAME "--" TITLESTRING)))
|
||||
(LET ((UNDER (GIT-WHICH-BRANCH PROJECT))
|
||||
(RESULT (GIT-COMMAND (CONCAT "git checkout -b " NAME)
|
||||
NIL NIL PROJECT)))
|
||||
@@ -1024,27 +1090,31 @@
|
||||
ELSE (HELP "Unexpected git result" RESULT])
|
||||
|
||||
(GIT-BRANCHES
|
||||
[LAMBDA (WHERE PROJECT) (* ; "Edited 9-May-2022 14:10 by rmk")
|
||||
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 23-May-2022 14:25 by rmk")
|
||||
(* ; "Edited 19-May-2022 10:06 by rmk")
|
||||
(* ; "Edited 9-May-2022 14:10 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:29 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
|
||||
(* ;; "Strips of the %"* %" that indicates the current branch and the 2-space padding on other branches. Packs local/ on to local branches")
|
||||
|
||||
(LET [[LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
|
||||
(LET ([LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
|
||||
'(NIL ALL LOCAL))
|
||||
(FOR B IN (GIT-COMMAND "git branch" NIL NIL PROJECT)
|
||||
COLLECT (PACK* "local/" (SUBATOM B 3))))]
|
||||
(REMOTE (CL:WHEN (MEMB (U-CASE WHERE)
|
||||
[REMOTE (CL:WHEN (MEMB (U-CASE WHERE)
|
||||
'(NIL ALL REMOTE T))
|
||||
(FOR B IN (GIT-COMMAND "git branch -r" NIL NIL PROJECT)
|
||||
COLLECT (SUBATOM B 3)))]
|
||||
(SORT (APPEND LOCAL REMOTE])
|
||||
BRANCHES)
|
||||
(SETQ BRANCHES (APPEND LOCAL REMOTE))
|
||||
(CL:WHEN EXCLUDEMERGED
|
||||
(SETQ BRANCHES (FOR B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) IN BRANCHES
|
||||
UNLESS (GIT-COMMIT-DIFFS MAINBRANCH B PROJECT) COLLECT B)))
|
||||
(SORT BRANCHES])
|
||||
|
||||
(GIT-BRANCH-EXISTS?
|
||||
[LAMBDA (BRANCH NOERROR PROJECT) (* ; "Edited 9-May-2022 14:18 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:28 by rmk")
|
||||
(* ; "Edited 3-May-2022 12:56 by rmk")
|
||||
(* ; "Edited 17-Nov-2021 18:24 by rmk:")
|
||||
[LAMBDA (BRANCH NOERROR PROJECT EXCLUDEMERGED) (* ; "Edited 19-May-2022 10:10 by rmk")
|
||||
|
||||
(* ;; "Returns the canonical name of the branch (xxx or origin/xxx) depending on whether BRANCH is local/xxx or origin/xxx")
|
||||
|
||||
@@ -1053,51 +1123,43 @@
|
||||
THEN 'REMOTE
|
||||
ELSEIF (STRPOS "local/" BRANCH 1 NIL T)
|
||||
THEN 'LOCAL)
|
||||
PROJECT)))
|
||||
PROJECT EXCLUDEMERGED)))
|
||||
ELSEIF (NOT NOERROR)
|
||||
THEN (ERROR "Unknown branch" BRANCH])
|
||||
|
||||
(GIT-PICK-BRANCH
|
||||
[LAMBDA (BRANCHES TITLE WHERE PROJECT) (* ; "Edited 11-May-2022 23:53 by rmk")
|
||||
(* ; "Edited 9-May-2022 17:07 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:54 by rmk")
|
||||
(* ; "Edited 6-Mar-2022 08:55 by rmk")
|
||||
(* ; "Edited 25-Feb-2022 09:02 by rmk")
|
||||
(MENU (CREATE MENU
|
||||
TITLE _ (OR TITLE 'Branches)
|
||||
ITEMS _ (OR (LISTP BRANCHES)
|
||||
(GIT-BRANCHES WHERE PROJECT))
|
||||
MENUFONT _ DEFAULTFONT])
|
||||
[LAMBDA (BRANCHES TITLE) (* ; "Edited 18-May-2022 13:44 by rmk")
|
||||
(CL:WHEN (MKLIST BRANCHES)
|
||||
(MENU (CREATE MENU
|
||||
TITLE _ (OR TITLE 'Branches)
|
||||
ITEMS _ BRANCHES
|
||||
MENUFONT _ DEFAULTFONT)))])
|
||||
|
||||
(GIT-PRC-MENU
|
||||
[LAMBDA (DRAFT PROJECT) (* ; "Edited 9-May-2022 16:54 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:48 by rmk")
|
||||
(* ; "Edited 6-May-2022 09:59 by rmk")
|
||||
(* ; "Edited 3-May-2022 22:58 by rmk")
|
||||
(* ; "Edited 29-Apr-2022 21:42 by rmk")
|
||||
(LET* ((PRS (GIT-PULL-REQUESTS T DRAFT PROJECT))
|
||||
(RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (GITORIGIN (CADDR PR)))
|
||||
NIL T PROJECT))
|
||||
(SUPERSETS (CAR RELATIONS))
|
||||
(EQUALS (CADR RELATIONS)))
|
||||
(SORT [FOR PR REL LABEL IN PRS
|
||||
COLLECT (SETQ LABEL (IF [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
|
||||
SUPERSETS]
|
||||
THEN (CONCAT (CADDR PR)
|
||||
" > " REL)
|
||||
ELSEIF [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
|
||||
EQUALS]
|
||||
THEN (CONCAT (CADDR PR)
|
||||
" = " REL)
|
||||
ELSE (CADDR PR)))
|
||||
(LIST (CL:IF (MEMB 'DRAFT PR)
|
||||
(CONCAT LABEL " (draft)")
|
||||
LABEL)
|
||||
(GITORIGIN (CADDR PR))
|
||||
(CONCAT " " (CADR PR)
|
||||
" #"
|
||||
(CAR PR]
|
||||
T])
|
||||
[LAMBDA (DRAFT PROJECT) (* ; "Edited 16-May-2022 19:44 by rmk")
|
||||
(LET ((PRS (GIT-PULL-REQUESTS T DRAFT PROJECT)))
|
||||
(CL:WHEN PRS
|
||||
(SETQ RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (GITORIGIN (CADDR PR)))
|
||||
NIL T PROJECT))
|
||||
(SORT [FOR PR REL LABEL (SUPERSETS _ (CAR RELATIONS))
|
||||
(EQUALS _ (CADR RELATIONS)) IN PRS
|
||||
COLLECT (SETQ LABEL (IF [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
|
||||
SUPERSETS]
|
||||
THEN (CONCAT (CADDR PR)
|
||||
" > " REL)
|
||||
ELSEIF [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
|
||||
EQUALS]
|
||||
THEN (CONCAT (CADDR PR)
|
||||
" = " REL)
|
||||
ELSE (CADDR PR)))
|
||||
(LIST (CL:IF (MEMB 'DRAFT PR)
|
||||
(CONCAT LABEL " (draft)")
|
||||
LABEL)
|
||||
(GITORIGIN (CADDR PR))
|
||||
(CONCAT " " (CADR PR)
|
||||
" #"
|
||||
(CAR PR]
|
||||
T))])
|
||||
|
||||
(GIT-PULL-REQUESTS
|
||||
[LAMBDA (ALLINFO INCLUDEDRAFTS PROJECT) (* ; "Edited 9-May-2022 16:54 by rmk")
|
||||
@@ -1116,6 +1178,21 @@
|
||||
,(SUBATOM LINE (ADD1 TAB3]
|
||||
ELSE (SUBATOM LINE (ADD1 TAB2)
|
||||
(SUB1 TAB3])
|
||||
|
||||
(GIT-SHORT-BRANCH-NAME
|
||||
[LAMBDA (BRANCH) (* ; "Edited 22-May-2022 22:36 by rmk")
|
||||
|
||||
(* ;; "Reduces rmk29--xxxxx to rmk29 for display")
|
||||
|
||||
(SUBSTRING BRANCH 1 (SUB1 (OR (STRPOS "--" BRANCH 1)
|
||||
0])
|
||||
|
||||
(GIT-LONG-NAME
|
||||
[LAMBDA (BRANCH WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 24-May-2022 17:49 by rmk")
|
||||
|
||||
(* ;; "Allows short-hand reference to branch: rmk40 will return rmk40--xyz")
|
||||
|
||||
(FIND B IN (GIT-BRANCHES WHERE PROJECT EXCLUDEMERGED) SUCHTHAT (STRPOS BRANCH B])
|
||||
)
|
||||
|
||||
|
||||
@@ -1125,37 +1202,27 @@
|
||||
(DEFINEQ
|
||||
|
||||
(GIT-MY-CURRENT-BRANCH
|
||||
[LAMBDA (PROJECT) (* ; "Edited 7-May-2022 23:51 by rmk")
|
||||
(* ; "Edited 19-Jan-2022 13:22 by rmk")
|
||||
(CAR (LAST (GIT-MY-BRANCHES PROJECT])
|
||||
[LAMBDA (PROJECT INITS) (* ; "Edited 19-May-2022 19:13 by rmk")
|
||||
(CL:UNLESS INITS
|
||||
(SETQ INITS (GIT-INITIALS)))
|
||||
(FOR B IN (GIT-MY-BRANCHES PROJECT NIL INITS) LARGEST (OR (GIT-BRANCH-NUM B INITS)
|
||||
0])
|
||||
|
||||
(GIT-MY-BRANCHP
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 7-May-2022 23:56 by rmk")
|
||||
(* ; "Edited 26-Jan-2022 11:41 by rmk")
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 19-May-2022 17:44 by rmk")
|
||||
(* ; "Edited 19-Jan-2022 13:22 by rmk")
|
||||
|
||||
(* ;; "Returns n if BRANCH is INITIALSn (local or origin), possibly followed by a trailing comment after colon or space.")
|
||||
(* ;; "Returns n if BRANCH is INITIALSn (local or origin), possibly followed by a trailing comment after hyphen.")
|
||||
|
||||
(CL:UNLESS BRANCH
|
||||
(SETQ BRANCH (GIT-WHICH-BRANCH PROJECT)))
|
||||
(LET* ((INITS (GIT-INITIALS))
|
||||
(INC (NCHARS INITS))
|
||||
(SPOS (ADD1 (OR (STRPOS "/" BRANCH)
|
||||
0)))
|
||||
(EPOS))
|
||||
(CL:WHEN (STRPOS INITS BRANCH SPOS NIL T NIL UPPERCASEARRAY)
|
||||
(CL:WHEN (SETQ EPOS (\UPF.NEXTPOS (CHARCODE (%: SPACE))
|
||||
BRANCH SPOS))
|
||||
(ADD EPOS -1))
|
||||
(SUBATOM BRANCH (IPLUS SPOS INC)
|
||||
EPOS))])
|
||||
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT])
|
||||
|
||||
(GIT-MY-NEXT-BRANCH
|
||||
[LAMBDA (PROJECT) (* ; "Edited 7-May-2022 23:56 by rmk")
|
||||
(* ; "Edited 19-Jan-2022 23:14 by rmk")
|
||||
[LAMBDA (PROJECT) (* ; "Edited 19-May-2022 14:08 by rmk")
|
||||
(* ; "Edited 8-Jan-2022 09:43 by rmk")
|
||||
|
||||
(* ;; "Figures out what my next incremental branch would be. ")
|
||||
(* ;; "Figures out the number of my next incremental branch would be. ")
|
||||
|
||||
(PACK* (GIT-INITIALS)
|
||||
(ADD1 (OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH PROJECT)
|
||||
@@ -1163,11 +1230,7 @@
|
||||
0])
|
||||
|
||||
(GIT-MY-BRANCHES
|
||||
[LAMBDA (PROJECT) (* ; "Edited 7-May-2022 23:51 by rmk")
|
||||
(* ; "Edited 6-Mar-2022 21:50 by rmk")
|
||||
(* ; "Edited 19-Jan-2022 13:20 by rmk")
|
||||
(* ; "Edited 8-Jan-2022 09:53 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 11:46 by rmk")
|
||||
[LAMBDA (PROJECT EXCLUDEMERGED INITS) (* ; "Edited 19-May-2022 19:10 by rmk")
|
||||
|
||||
(* ;; "This returns only local branch names: xyzn and not origin/xyzn or local/xyzn")
|
||||
|
||||
@@ -1175,12 +1238,27 @@
|
||||
|
||||
(* ;; "The return list is sorted so that lower n's come before later n's. The last element is my current branch")
|
||||
|
||||
(FOR B (INITS _ (CONCAT "local/" (GIT-INITIALS)))
|
||||
INC IN (GIT-BRANCHES NIL PROJECT) FIRST (SETQ INC (NCHARS INITS))
|
||||
WHEN (STRPOS INITS B 1 NIL T NIL UPPERCASEARRAY) COLLECT B
|
||||
FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (A B)
|
||||
(ILESSP (SUBATOM A (ADD1 INC))
|
||||
(SUBATOM B (ADD1 INC])
|
||||
(CL:UNLESS INITS
|
||||
(SETQ INITS (GIT-INITIALS)))
|
||||
(FOR B IPOS IN (GIT-BRANCHES 'LOCAL PROJECT EXCLUDEMERGED)
|
||||
WHEN [AND (SETQ IPOS (STRPOS INITS B 1 NIL NIL NIL UPPERCASEARRAY))
|
||||
(OR (EQ IPOS 1)
|
||||
(EQ (CHARCODE /)
|
||||
(NTHCHARCODE B (SUB1 IPOS] COLLECT (CONS B (GIT-BRANCH-NUM B INITS))
|
||||
FINALLY
|
||||
|
||||
(* ;; "We expect a branch beginning with INITS rmk is of the form %"rmknnn%" or %"rmknnn--somestring%". If so, we want to sort b the number. If not, sort alphabetically at the end, with numbered ones first.")
|
||||
|
||||
(RETURN (FOR B IN [SORT $$VAL (FUNCTION (LAMBDA (X Y)
|
||||
(IF (CDR X)
|
||||
THEN (IF (CDR Y)
|
||||
THEN (ILESSP (CDR X)
|
||||
(CDR Y))
|
||||
ELSE T)
|
||||
ELSEIF (NOT (CDR Y))
|
||||
THEN (ALPHORDER (CAR X)
|
||||
(CAR Y]
|
||||
COLLECT (CAR B])
|
||||
)
|
||||
|
||||
|
||||
@@ -1273,10 +1351,13 @@
|
||||
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2 PROJECT)
|
||||
(DECLARE (USEDFREE FROMGITN))
|
||||
|
||||
(* ;; "Edited 21-May-2022 23:38 by rmk")
|
||||
|
||||
(* ;; "Edited 9-May-2022 14:17 by rmk: Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")
|
||||
|
||||
(* ;; "Edited 6-May-2022 08:26 by rmk: Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")
|
||||
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SETQ BRANCH1 (GIT-BRANCH-EXISTS? BRANCH1 NIL PROJECT))
|
||||
(SETQ BRANCH2 (GIT-BRANCH-EXISTS? BRANCH2 NIL PROJECT))
|
||||
(LET
|
||||
@@ -1362,19 +1443,19 @@
|
||||
(HELP "UNKNOWN GIT-DIFF TAG" D)))
|
||||
(LIST DIR1 DIR2 MAPPINGS))])
|
||||
|
||||
(GIT-COMPARE-BRANCHES
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 9-May-2022 15:14 by rmk")
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 22-May-2022 22:47 by rmk")
|
||||
(* ; "Edited 9-May-2022 15:14 by rmk")
|
||||
(* ; "Edited 3-May-2022 23:04 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SETQ BRANCH1 (IF BRANCH1
|
||||
THEN (GITORIGIN BRANCH1 LOCAL)
|
||||
ELSE (GIT-WHICH-BRANCH PROJECT)))
|
||||
(SETQ BRANCH2 (GITORIGIN (OR BRANCH2 (GIT-MAINBRANCH PROJECT))
|
||||
LOCAL))
|
||||
(PRINTOUT T "Comparing all " (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
T)
|
||||
" subdirectories of " BRANCH1 " and " BRANCH2 T)
|
||||
(LET (CDVALUE DIRS NENTRIES MAPPINGS)
|
||||
(LET (CDVALUE DIRS NENTRIES MAPPINGS (SHORT1 (GIT-SHORT-BRANCH-NAME BRANCH1))
|
||||
(SHORT2 (GIT-SHORT-BRANCH-NAME BRANCH2)))
|
||||
(PRINTOUT T "Comparing all " (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
T)
|
||||
" subdirectories of " SHORT1 " and " SHORT2 T)
|
||||
(PRINTOUT T "Fetching differences" T)
|
||||
(SETQ DIRS (GIT-GET-DIFFERENT-FILES BRANCH1 BRANCH2 NIL NIL PROJECT))
|
||||
(SETQ MAPPINGS (CADDR DIRS))
|
||||
@@ -1432,10 +1513,10 @@
|
||||
(CDBROWSER CDVALUE (CONCAT "Comparing " (L-CASE (FETCH PROJECTNAME
|
||||
OF PROJECT)
|
||||
T)
|
||||
" " BRANCH1 " and " BRANCH2 " "
|
||||
" " SHORT1 " and " SHORT2 " "
|
||||
(LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVALUE))
|
||||
" files")
|
||||
(LIST BRANCH1 BRANCH2)
|
||||
(LIST SHORT1 SHORT2)
|
||||
`(LABELFN GIT-CD-LABELFN BRANCH1 ,BRANCH1 BRANCH2 ,BRANCH2 PROJECT
|
||||
,PROJECT)
|
||||
NIL
|
||||
@@ -1447,12 +1528,15 @@
|
||||
ELSE '(0 differences))
|
||||
ELSE '(0 differences])
|
||||
|
||||
(GIT-COMPARE-WITH-MYMEDLEY
|
||||
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)
|
||||
(* ; "Edited 10-May-2022 10:41 by rmk")
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES
|
||||
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)
|
||||
|
||||
(* ;; "Edited 17-May-2022 17:39 by rmk")
|
||||
|
||||
(* ;; "Edited 10-May-2022 10:41 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Edited 29-Mar-2022 13:58 by rmk: my medley subdirectories with the current local git branch.")
|
||||
"Edited 29-Mar-2022 13:58 by rmk: working medley subdirectories with the current local git branch.")
|
||||
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(CL:WHEN UPDATE (GIT-REMOTE-UPDATE NIL PROJECT)) (* ; "Doesn't matter if we are looking only at local files in the current branch. We aren't fetching or checking out.")
|
||||
@@ -1467,11 +1551,11 @@
|
||||
THEN (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
|
||||
"ALL subdirectories"
|
||||
ELSE SUBDIRS)))
|
||||
(FOR SUBDIR TITLE CDVAL (MYPROJ _ (CONCAT "My " (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
T)))
|
||||
(FOR SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
T)))
|
||||
(NENTRIES _ 0)
|
||||
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT))
|
||||
FIRST (PRINTOUT T "Comparing " SUBDIRSTRING " of " MYPROJ " and " BRANCH2 T)
|
||||
FIRST (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
|
||||
(BKSYSBUF " ") INSIDE SUBDIRS
|
||||
COLLECT (TERPRI T)
|
||||
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
|
||||
@@ -1497,12 +1581,12 @@
|
||||
(SETQ $$VAL (CDMERGE $$VAL))
|
||||
[SETQ SUBDIRS (CONCATLIST (FOR SUBDIR IN SUBDIRS COLLECT (CONCAT SUBDIR " "])
|
||||
[FOR CDVAL TITLE IN $$VAL AS SUBDIR INSIDE SUBDIRS
|
||||
DO (SETQ TITLE (CONCAT "Comparing " MYPROJ " and " BRANCH2 " " SUBDIR
|
||||
DO (SETQ TITLE (CONCAT "Comparing " WPROJ " and " BRANCH2 " " SUBDIR
|
||||
" " (LENGTH (fetch (CDVALUE CDENTRIES)
|
||||
of CDVAL))
|
||||
" files"))
|
||||
[CDBROWSER CDVAL TITLE `(,MYPROJ ,BRANCH2)
|
||||
`(BRANCH1 ,MYPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN
|
||||
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
|
||||
`(BRANCH1 ,WPROJ BRANCH2 ,BRANCH2 SUBDIR ,SUBDIR LABELFN
|
||||
GIT-CD-LABELFN PROJECT ,PROJECT)
|
||||
NIL
|
||||
`(Compare See "" Copy% <- (|Delete ALL <-| GIT-CD-MENUFN)
|
||||
@@ -1512,7 +1596,7 @@
|
||||
(FOR CDENTRY IN (fetch CDENTRIES of CDVAL)
|
||||
COLLECT (fetch MATCHNAME of CDENTRY)))
|
||||
(ADD NENTRIES (LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVAL]
|
||||
(SETQ LAST-MYMEDLEY-CDVALUES $$VAL)
|
||||
(SETQ LAST-WMEDLEY-CDVALUES $$VAL)
|
||||
(TERPRI T)
|
||||
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
|
||||
'difference
|
||||
@@ -1681,7 +1765,8 @@
|
||||
(OR LABEL2 FILE2])
|
||||
|
||||
(GIT-CD-MENUFN
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 8-May-2022 09:26 by rmk")
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 22-May-2022 19:13 by rmk")
|
||||
(* ; "Edited 8-May-2022 09:26 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 08:52 by rmk")
|
||||
|
||||
(* ;; "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")
|
||||
@@ -1690,24 +1775,20 @@
|
||||
(SELECTQ (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
(Delete% -> (FLASHWINDOW PWINDOW)
|
||||
(IF FILE1
|
||||
THEN (PRIN3 "Use 'Delete BOTH' instead")
|
||||
ELSE (GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN [OR (EQ KEY 'MIDDLE)
|
||||
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? "]
|
||||
(GIT-DELETE-FILE FILE2 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM))))
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN [OR (EQ KEY 'MIDDLE)
|
||||
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete " LABEL2 " ? "]
|
||||
(GIT-DELETE-FILE FILE2 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM)))
|
||||
(|Delete ALL <-|
|
||||
(FLASHWINDOW PWINDOW)
|
||||
(IF FILE2
|
||||
THEN (PRIN3 "Use 'Delete BOTH' instead")
|
||||
ELSE (GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN [OR (EQ KEY 'MIDDLE)
|
||||
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
|
||||
(NAMEFIELD LABEL1 T)
|
||||
" ? "]
|
||||
(MYMEDLEY-DELETE-FILES FILE1 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM))))
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN [OR (EQ KEY 'MIDDLE)
|
||||
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of " (NAMEFIELD LABEL1
|
||||
T)
|
||||
" ? "]
|
||||
(MYMEDLEY-DELETE-FILES FILE1 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM)))
|
||||
(Delete% BOTH (FLASHWINDOW PWINDOW)
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT
|
||||
@@ -1718,6 +1799,38 @@
|
||||
(MYMEDLEY-DELETE-FILES FILE1 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM)))
|
||||
(SHOULDNT])
|
||||
|
||||
(GIT-WORKING-COMPARE-FILES
|
||||
[LAMBDA (FILE PROJECT) (* ; "Edited 22-May-2022 14:45 by rmk")
|
||||
(LET ((FILE1 (UNSLASHIT (PACKFILENAME 'HOST (GIT-GET-PROJECT PROJECT NIL 'WHOST)
|
||||
'BODY FILE)
|
||||
T))
|
||||
(FILE2 (SLASHIT (PACKFILENAME 'HOST (GIT-GET-PROJECT PROJECT NIL 'GITHOST)
|
||||
'BODY FILE)
|
||||
T)))
|
||||
(CD-COMPARE-FILES FILE1 FILE2 FILE1 FILE2])
|
||||
|
||||
(GIT-BRANCHES-COMPARE-FILES
|
||||
[LAMBDA (FILE BRANCH1 BRANCH2 PROJECT LOCAL) (* ; "Edited 22-May-2022 22:50 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SETQ BRANCH1 (SELECTQ (U-CASE BRANCH1)
|
||||
((NIL T)
|
||||
(GIT-MY-CURRENT-BRANCH PROJECT))
|
||||
((LOCAL REMOTE ORIGIN)
|
||||
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH1 PROJECT T)))
|
||||
BRANCH1))
|
||||
(SETQ BRANCH2 (SELECTQ (U-CASE BRANCH2)
|
||||
((NIL T)
|
||||
(GIT-MAINBRANCH PROJECT LOCAL))
|
||||
((LOCAL REMOTE ORIGIN)
|
||||
(GIT-PICK-BRANCH (GIT-BRANCHES BRANCH2 PROJECT T)))
|
||||
BRANCH2))
|
||||
(LET ((FILE1 (GIT-GET-FILE BRANCH1 FILE NIL NIL PROJECT))
|
||||
(FILE2 (GIT-GET-FILE BRANCH2 FILE NIL NIL PROJECT)))
|
||||
(CD-COMPARE-FILES FILE1 FILE2 (CONCAT (GIT-SHORT-BRANCH-NAME BRANCH1)
|
||||
" " FILE)
|
||||
(CONCAT (GIT-SHORT-BRANCH-NAME BRANCH2)
|
||||
" " FILE])
|
||||
)
|
||||
|
||||
(RPAQ? FROMGITN 0)
|
||||
@@ -1795,27 +1908,31 @@
|
||||
INITIALS)
|
||||
(ERROR "INITIALS is not set"])
|
||||
)
|
||||
|
||||
(PUTPROPS GITFNS FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3224 15673 (GIT-CLONEP 3234 . 4497) (GIT-MAKE-PROJECT 4499 . 11213) (GIT-GET-PROJECT
|
||||
11215 . 12552) (GIT-PROJECT-PATH 12554 . 13598) (FIND-ANCESTOR-DIRECTORY 13600 . 13949) (
|
||||
GIT-FIND-CLONE 13951 . 15032) (GIT-MAINBRANCH 15034 . 15318) (GIT-MAINBRANCH? 15320 . 15671)) (20524
|
||||
23312 (ALLSUBDIRS 20534 . 21820) (MEDLEYSUBDIRS 21822 . 22515) (GITSUBDIRS 22517 . 23310)) (23313
|
||||
28103 (TOGIT 23323 . 24729) (FROMGIT 24731 . 25712) (GIT-DELETE-FILE 25714 . 26560) (
|
||||
MYMEDLEY-DELETE-FILES 26562 . 28101)) (28104 30636 (MYMEDLEYSUBDIR 28114 . 28570) (GITSUBDIR 28572 .
|
||||
29015) (STRIPDIR 29017 . 29388) (STRIPHOST 29390 . 29630) (STRIPNAME 29632 . 30385) (STRIPWHERE 30387
|
||||
. 30634)) (30637 32539 (GFILE4MFILE 30647 . 31010) (MFILE4GFILE 31012 . 31581) (GIT-REPO-FILENAME
|
||||
31583 . 32537)) (32588 40339 (GIT-COMMIT 32598 . 33424) (GIT-PUSH 33426 . 34070) (GIT-PULL 34072 .
|
||||
34684) (GIT-APPROVAL 34686 . 35035) (GIT-GET-FILE 35037 . 37506) (GIT-FILE-EXISTS? 37508 . 38452) (
|
||||
GIT-REMOTE-UPDATE 38454 . 39178) (GIT-REMOTE-ADD 39180 . 39487) (GIT-FILE-DATE 39489 . 40337)) (40369
|
||||
49297 (GIT-BRANCH-DIFF 40379 . 45082) (GIT-COMMIT-DIFFS 45084 . 45528) (GIT-BRANCH-RELATIONS 45530 .
|
||||
49295)) (49342 57178 (GIT-CHECKOUT 49352 . 49864) (GIT-WHICH-BRANCH 49866 . 50164) (GIT-MAKE-BRANCH
|
||||
50166 . 51399) (GIT-BRANCHES 51401 . 52378) (GIT-BRANCH-EXISTS? 52380 . 53397) (GIT-PICK-BRANCH 53399
|
||||
. 54188) (GIT-PRC-MENU 54190 . 56157) (GIT-PULL-REQUESTS 56159 . 57176)) (57208 60548 (
|
||||
GIT-MY-CURRENT-BRANCH 57218 . 57508) (GIT-MY-BRANCHP 57510 . 58546) (GIT-MY-NEXT-BRANCH 58548 . 59142)
|
||||
(GIT-MY-BRANCHES 59144 . 60546)) (60594 64546 (GIT-ADD-WORKTREE 60604 . 62088) (GIT-REMOVE-WORKTREE
|
||||
62090 . 63020) (GIT-LIST-WORKTREES 63022 . 63826) (WORKTREEDIR 63828 . 64544)) (64594 92310 (
|
||||
GIT-GET-DIFFERENT-FILES 64604 . 70330) (GIT-COMPARE-BRANCHES 70332 . 76046) (GIT-COMPARE-WITH-MYMEDLEY
|
||||
76048 . 80505) (GIT-COMPARE-WORKTREE 80507 . 84380) (GITCDOBJBUTTONFN 84382 . 88872) (GIT-CD-LABELFN
|
||||
88874 . 89956) (GIT-CD-MENUFN 89958 . 92308)) (92380 95363 (CDGITDIR 92390 . 92768) (GIT-COMMAND 92770
|
||||
. 94356) (GITORIGIN 94358 . 95055) (GIT-INITIALS 95057 . 95361)))))
|
||||
(FILEMAP (NIL (3384 17231 (GIT-CLONEP 3394 . 4657) (GIT-MAKE-PROJECT 4659 . 12771) (GIT-GET-PROJECT
|
||||
12773 . 14110) (GIT-PROJECT-PATH 14112 . 15156) (FIND-ANCESTOR-DIRECTORY 15158 . 15507) (
|
||||
GIT-FIND-CLONE 15509 . 16590) (GIT-MAINBRANCH 16592 . 16876) (GIT-MAINBRANCH? 16878 . 17229)) (23164
|
||||
25952 (ALLSUBDIRS 23174 . 24460) (MEDLEYSUBDIRS 24462 . 25155) (GITSUBDIRS 25157 . 25950)) (25953
|
||||
30743 (TOGIT 25963 . 27369) (FROMGIT 27371 . 28352) (GIT-DELETE-FILE 28354 . 29200) (
|
||||
MYMEDLEY-DELETE-FILES 29202 . 30741)) (30744 33276 (MYMEDLEYSUBDIR 30754 . 31210) (GITSUBDIR 31212 .
|
||||
31655) (STRIPDIR 31657 . 32028) (STRIPHOST 32030 . 32270) (STRIPNAME 32272 . 33025) (STRIPWHERE 33027
|
||||
. 33274)) (33277 35179 (GFILE4MFILE 33287 . 33650) (MFILE4GFILE 33652 . 34221) (GIT-REPO-FILENAME
|
||||
34223 . 35177)) (35228 43029 (GIT-COMMIT 35238 . 36064) (GIT-PUSH 36066 . 36710) (GIT-PULL 36712 .
|
||||
37324) (GIT-APPROVAL 37326 . 37675) (GIT-GET-FILE 37677 . 40196) (GIT-FILE-EXISTS? 40198 . 41142) (
|
||||
GIT-REMOTE-UPDATE 41144 . 41868) (GIT-REMOTE-ADD 41870 . 42177) (GIT-FILE-DATE 42179 . 43027)) (43059
|
||||
51650 (GIT-BRANCH-DIFF 43069 . 47821) (GIT-COMMIT-DIFFS 47823 . 48267) (GIT-BRANCH-RELATIONS 48269 .
|
||||
51648)) (51695 60630 (GIT-BRANCH-NUM 51705 . 52278) (GIT-CHECKOUT 52280 . 52792) (GIT-WHICH-BRANCH
|
||||
52794 . 53092) (GIT-MAKE-BRANCH 53094 . 54838) (GIT-BRANCHES 54840 . 56331) (GIT-BRANCH-EXISTS? 56333
|
||||
. 57037) (GIT-PICK-BRANCH 57039 . 57367) (GIT-PRC-MENU 57369 . 58997) (GIT-PULL-REQUESTS 58999 .
|
||||
60016) (GIT-SHORT-BRANCH-NAME 60018 . 60309) (GIT-LONG-NAME 60311 . 60628)) (60660 63995 (
|
||||
GIT-MY-CURRENT-BRANCH 60670 . 61040) (GIT-MY-BRANCHP 61042 . 61547) (GIT-MY-NEXT-BRANCH 61549 . 62043)
|
||||
(GIT-MY-BRANCHES 62045 . 63993)) (64041 67993 (GIT-ADD-WORKTREE 64051 . 65535) (GIT-REMOVE-WORKTREE
|
||||
65537 . 66467) (GIT-LIST-WORKTREES 66469 . 67273) (WORKTREEDIR 67275 . 67991)) (68041 97537 (
|
||||
GIT-GET-DIFFERENT-FILES 68051 . 73876) (GIT-BRANCHES-COMPARE-DIRECTORIES 73878 . 79720) (
|
||||
GIT-WORKING-COMPARE-DIRECTORIES 79722 . 84188) (GIT-COMPARE-WORKTREE 84190 . 88063) (GITCDOBJBUTTONFN
|
||||
88065 . 92555) (GIT-CD-LABELFN 92557 . 93639) (GIT-CD-MENUFN 93641 . 95848) (GIT-WORKING-COMPARE-FILES
|
||||
95850 . 96369) (GIT-BRANCHES-COMPARE-FILES 96371 . 97535)) (97607 100590 (CDGITDIR 97617 . 97995) (
|
||||
GIT-COMMAND 97997 . 99583) (GITORIGIN 99585 . 100282) (GIT-INITIALS 100284 . 100588)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -14,7 +14,7 @@ where
|
||||
|
||||
GITFNS provides a Medley-oriented interface for comparing the files in two different branches of a git repository. This makes it easier to understand what functions or other definitions have changed in a Lisp source file, or what text has changed in a Tedit file. This may be particularly helpful in evaluating the changes in a pull request.
|
||||
Separately, GITFNS also provides tools and conventions for bridging between git's file-oriented style of development and version control and Medley's residential development style with its own version control conventions. GITFNS allows for intelligent comparisons between Lisp source files,Tedit files, and text files in a local git clone and a local Medley-style working directory, and for migrating files to and from the git clone and the working directory.
|
||||
|
||||
|
||||
Git projects: Connecting git clones to GITFNS capabilities
|
||||
The GITFNS capabilities operate on pre-existing clones of remote git repositories that have been installed at the end of some path on the local disk. The path to a clone can be used to create a "git project" for that clone:
|
||||
(GIT-MAKE-PROJECT PROJECTNAME PROJECTPATH WORKINGPATH EXCLUSIONS
|
||||
@@ -30,10 +30,10 @@ If MEDLEYDIR is defined,
|
||||
|
||||
For convenience, if PROJECTPATH is NIL or T (and not a path), then a squence of probes based on PROJECTNAME attempts to find a clone directory (with a .git subdirectory):
|
||||
(UNIX-GETENV PROJECTNAME)
|
||||
(UNIX-GETENV (CONCAT PROJECTNAME 'DIR)
|
||||
(UNIX-GETENV (CONCAT PROJECTNAME 'DIR)
|
||||
(CONCAT MEDLEYDIR "../git-" PROJECTNAME)
|
||||
(a sister of MEDLEYDIR named git-PROJECTNAME, e.g. git-notecards)
|
||||
Thus:
|
||||
Thus:
|
||||
If MEDLEYDIR is defined,
|
||||
(GIT-MAKE-PROJECT 'MEDLEY) will make the MEDLEY project
|
||||
If NOTECARDS is defined
|
||||
@@ -57,10 +57,12 @@ bbc branch1 branch2 (project) [command]
|
||||
prc rmk15
|
||||
brings up a lispusers/COMPAREDIRECTORIES browser for the files that currently differ between origin/rmk15 and origin/master. If the selected files are Lisp source files, the Compare item on the file browser menu will show the differences in a lispusers/COMPARESOURCES browser. The differences for other file types will be shown in a lispusers/COMPARETEXT browser.
|
||||
If branch is not specified and the shell command gh is available, then a menu of open pull-request branches will be provided. If gh is not available, the menu will offer all known branches. If the optional DRAFT is provided, then the menu will include draft PR's as well as open ones.
|
||||
If one PR, say rmk15, contains all the commits of another (rmk14), then the menu will indicate this by
|
||||
rmk15 > rmk14
|
||||
Note that the prc comparison is read-only: any comments, approvals, or merges of the branch must be specified using the normal Medley-external git interfaces and commands.
|
||||
Note that the prc comparison is read-only: any comments, approvals, or merges of the branch must be specified using the normal Medley-external git interfaces and commands.
|
||||
|
||||
|
||||
prc is the special case of the more general bbc command ("branch-branch compare) for comparing the files in any two branches:
|
||||
bbc branch1 branch2 (project) [command]
|
||||
This compares the files in branch1 and branch2, for example
|
||||
bbc rmk15 lmm12 (local)
|
||||
This will compare the files in origin/rmk15 and origin/lmm12 in the GIT-DEFAULT project. branch1 defaults to the origin files of the currently checked out branch, the second defaults to origin/master. If local is non-NIL, then a branch that has neither local/ or origin/ prepended will default to local (e.g. local/rmk15) instead of origin/. Local refers to the files that are currently in the clone directory, which may not be the same as the origin files, depending on the push/pull status.
|
||||
@@ -68,25 +70,25 @@ b? (project) [command]
|
||||
|
||||
The command cob ("check out branch") checks out a specified branch:
|
||||
cob branch (nexttitlestring) (project) [command]
|
||||
cob branch (project) [command]
|
||||
This checks out branch of project and then executes git pull. The branch parameter may also be a local branch, T (= my current branch), or NEW/NEXT (= my next branch). My current branch is a the branch named <initials>nnn, e.g. rmk15. The initials are the value of INITIALS as used for SEDIT time stamps, and nnn is the largest of the integers of all of the branches beginning with those initials. If branch is NEW or NEXT, then a new initialed branch is created and becomes the user's current branch. Its number is one greater than the largest number of previous initialed branches.
|
||||
This checks out branch of project and then executes git pull. The branch parameter may also be a local branch, T (= the current working branch), or NEW/NEXT (= the next working branch). The current working branch is the branch named <initials>nnn, e.g. rmk15. The initials are the value of INITIALS as used for SEDIT time stamps, and nnn is the largest of the integers of all of the branches beginning with those initials.
|
||||
If branch is NEW or NEXT, then a new initialed branch is created and becomes the user's current branch. Its number is one greater than the largest number of previous initialed branches. If nexttitlestring is provided, then that string will be appended to the name of the branch, after the initials and next number, and two hyphens. Spaces in nexttitlestring will also be replaced by hyphens, according to git conventions.
|
||||
If branch is not provided, a menu of locally available branches pops up.
|
||||
|
||||
The currently checked out branch is obtained by the b? command:
|
||||
b? (project) [command]
|
||||
|
||||
The currently checked out branch is obtained by the b? command:
|
||||
b? (project) [command]
|
||||
|
||||
Correlating git source control with separate Medley development
|
||||
Correlating git source control with separate Medley development
|
||||
It is generally unsafe to do Medley development by operating with files in a local clone repository. Medley provides a residential development environment that integrates tightly with the local file system. It is important to have consistent access to the source files of the currently running system, especially for files whose contents have been only partially loaded. A git pull or a branch switch that introduces new versions of some files or removes old files altogether can lead to unpredictable disconnects that are hard to recover from. This is true also because development can go on in the same Medley memory image for days if not weeks, so it is important to have explicit control of any file version changes.
|
||||
GITFNS mitigates the danger by conventions that separate the files in the git clone from the files in the working Medley development directory. The location of the Medley development source tree for a project is given by the WORKINGPATH argument to GIT-MAKE-PROJECT. If WORKINGPATH is T or NIL and there exists a directory >working-projectname> as a sister to the clone, then that is taken to be the WORKINGPATH and thus the prefix for a pseudohost {Wprojectname}.
|
||||
When Medley development is carried out in the WORKINGPATH, the variable MEDLEYDIR should point initially to the working directory, and the directory search paths (DIRECTORIES, LISPUSERSDIRECTORIES, FONTDIRECTORIES, etc.) all have MEDLEYDIR as a prefix. In that case, the clone for the project, if PROJECTPATH doesn't specify it explicitly, should be located at the >git-medley> sister directory of MEDLEYDIR.
|
||||
When Medley development is carried out in the WORKINGPATH, the variable MEDLEYDIR should point initially to the working directory, and the directory search paths (DIRECTORIES, LISPUSERSDIRECTORIES, FONTDIRECTORIES, etc.) all have MEDLEYDIR (or {WMEDLEY}) as a prefix. In that case, the clone for the project, if PROJECTPATH doesn't specify it explicitly, should be located at the >git-medley> sister directory of MEDLEYDIR.
|
||||
Any back and forth transfer of information between the git clone and Medley development must be done by explicit synchronization actions. Crucially, Medley-updated files do not appear in the clone directories and new clone files do not move to the Medley directories without user intervention.
|
||||
The files in Medley working tree and the git clone of a project can be compared with the gwc ("git-working-compare") command:
|
||||
gwc subdirectories (project) [command]
|
||||
This produces a browser for all the files in the corresponding WORKINGPATH subdirectories that differ from the files in the currently checked out branch of the git clone. If subdirectories is omitted, it defaults to the DEFAULTSUBDIRS of the project. If it is ALL, then files in all subdirectories that are not found in the project's EXCLUSIONS are compared.
|
||||
This produces a browser for all the files in the corresponding WORKINGPATH subdirectories that differ from the files in the currently checked out branch of the git clone. If subdirectories is omitted, it defaults to the DEFAULTSUBDIRS or the project. If it is ALL, then files in all subdirectoriesthat are not found in the project's EXCLUSIONS are compared.
|
||||
In addition to the commands for comparing and viewing files, the menu for this browser also has commands for copying files from the git clone {Gprojectname} to {Wprojectname} and deleting files from {Wprojectname}.
|
||||
If master/main branch is the current branch then the menu has no commands to change the clone directory. The browser will show those files that have been updated from a recent merge, and they can individually be copied from the git branch to realign the two source trees with incremented Medley version numbers. If the comparison is with a different branch, say the user's current staging branch, copying files from the working Medley to to the git clone or deleting git files will set git up for future commits.
|
||||
Note that the menu item for deleting Medley files will cause all version to be removed, not just the latest one, to avoid the possibility that an earlier one is revealed. Deletion for Medley files is also accomplished by renaming to a {Wprojectname}<deletion> subdirectory so that they can be recovered if a deletion is in error. Files in the git-clone are removed from the file system immediately, since git provides its own recovery mechanism for those files.
|
||||
GITFNS does not (yet?) include functions for commits, pushes, or merges for updating the remote repository. Those have to be done outside of Medley through the usual github interfaces, as guided by the information provided by the comparisons.
|
||||
(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 È È 4 È È 4 È È 4 È È . È . Š Š8 . Š Š8 J È È PAGEHEADING RUNNINGHEAD MODERN
|
||||
TIMESROMAN $ TERMINAL MODERN
|
||||
In addition to the commands for comparing and viewing files, the menu for this browser also has commands for copying files from the git clone {Gprojectname} to {Wprojectname} and deleting files from {Wprojectname}.
|
||||
If the master/main branch is the current branch then the menu has no commands to change the clone directory. The browser will show those files that have been updated from a recent merge, and they can individually be copied from the git branch to realign the two source trees with incremented Medley version numbers. If the comparison is with a different branch, say the user's current staging branch, copying files from the working Medley to the git clone or deleting git files will set git up for future commits.
|
||||
Note that the menu item for deleting Medley files will cause all version to be removed, not just the latest one, to avoid the possibility that an earlier one is revealed. Deletion for Medley files is also accomplished by renaming to a {Wprojectname}<deletion> subdirectory so that they can be recovered if a deletion is in error. Files in the git-clone are removed from the file system immediately, since git provides its own recovery mechanism for those files.
|
||||
GITFNS does not (yet?) include functions for commits, pushes, or merges for updating the remote repository. Those have to be done outside of Medley through the usual github interfaces, as guided by the information provided by the comparisons.
|
||||
(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 È È 4 È È 4 È È 4 È È . È . Š Š8 . Š Š8 J È È PAGEHEADING RUNNINGHEAD TERMINAL
|
||||
MODERN
|
||||
BIN
lispusers/MODERNIZE.TEDIT
Normal file
BIN
lispusers/MODERNIZE.TEDIT
Normal file
Binary file not shown.
@@ -1,78 +0,0 @@
|
||||
MODERNIZE documentation
|
||||
|
||||
Ron Kaplan, February 2021
|
||||
|
||||
[A renaming of an earlier MACINTERFACE package]
|
||||
|
||||
MODERNIZE is a simple Lispusers package that changes the mouse actions on Medley windows so that moving and shaping can be done in a way that approximates the behavior of windows on modern platforms, Mac, Windows, etc. It also adds some meta keys to also emulate more conventional behavior.
|
||||
|
||||
Thus, for a window that has been created or transformed in this way, you can move the window by left-clicking in the title bar and dragging the window's ghost region. Or you can reshape by clicking in a corner of the title bar or near the bottom of the window to drag out the ghost region by that corner.
|
||||
|
||||
The menu behavior for other buttons or buttons clicked in other positions is unchanged.
|
||||
|
||||
|
||||
For bottom corners, "near" means inside the window within MODERN-WINDOW-MARGIN (initially 25) pixels above or to the left/right of the corner.
|
||||
|
||||
For top corners, "near" means within the title bar and within the margin from the left/right edges.
|
||||
|
||||
(Windows that don't have a title-bar, like Snap windows, can be set up so that moving can happen by clicking anywhere, and shaping at the top is determined by the margin inside the window region.)
|
||||
|
||||
When the package is loaded, this behavior is installed for the following kinds of windows:
|
||||
|
||||
Tedit
|
||||
Debugger/break
|
||||
Sedit
|
||||
Inspector
|
||||
Snap
|
||||
Exec
|
||||
File Browser
|
||||
Grapher
|
||||
|
||||
The function MODERNWINDOW.SETUP establishes the new behavior for classes of windows:
|
||||
|
||||
(MODERNWINDOW.SETUP ORIGFN MODERNWINDOWFN ANYWHERE TITLEPROPORTION)
|
||||
|
||||
ORIGFN is either the name of the BUTTONEVENTFN for a class of windows (e.g. \TEDIT.BUTTONEVENTFN for Tedit windows) or it is a function that creates windows of a particulate kind (e.g. SNAPW or ADD-EXEC).
|
||||
|
||||
MODERNWINDOW.SETUP moves the definition of ORIGFN to the name (PACK* 'MODERN-ORIG- ORIGFN), and then provides a new definition for ORIGFN that does the moving or reshaping for clicks in the triggering locations, and otherwise passes control through to the original definition.
|
||||
|
||||
If ORIGNFN is a button event function, then MODERNWINDOWFN should not be specified. In that case a new definition for ORIGFN is constructed to provide the desired windowing behavior.
|
||||
|
||||
Otherwise, if ORIGFN is the function that creates windows of a class (e.g. SNAPW), then a MODERNWINDOWFN should be provided to create such windows (by calling (PACK* MODERN-ORIG- ORIGFN)). The definition of MODERNWINDOWFN replaces the original definition of ORIGFN.
|
||||
|
||||
If the flag ANYWHERE is non-NIL, especially for windows without a title bar, then the moving behavior is triggered by a click anywhere in the window (except the corners).
|
||||
|
||||
Because this works by redefining existing functions, it is important that the MODERNIZE package be loaded AFTER Tedit and Sedit, if those are not already in the sysout. And it should be called to upgrade the proper functions for other window classes that might later be added.
|
||||
|
||||
Provided these capabilities are already loaded, the following window classes are "modernized" when MODERNIZE is loaded are:
|
||||
|
||||
TEDIT
|
||||
SEDIT
|
||||
INSPECTOR
|
||||
SNAP
|
||||
DEBUGGER
|
||||
EXEC
|
||||
TABLEBROWSER
|
||||
FILEBROWSER
|
||||
FREEMENU
|
||||
GRAPHER
|
||||
PROMPTWINDOW
|
||||
|
||||
If it is not known or it is inconvenient to systematically upgrade a button function or a window-creation function, the new behavior can be provided after a particular window has been created, by invoking
|
||||
|
||||
(MODERNWINDOW WINDOW ANYWHERE TITLEPROPORTION)
|
||||
|
||||
This saves the windows existing BUTTONEVENTFN as a window property PREMODERN-BUTTONEVENTFN, and installs a simple stub function in its place.
|
||||
|
||||
If things go awry:
|
||||
|
||||
(UNMODERN.SETUP ORIGFN) is provided to restore the original behavior for windows whose buttonevent function is ORIGIN.
|
||||
|
||||
(UNMODERNWINDOW WINDOW) restores a modernized window (via MACWINDOW) to its original state.
|
||||
|
||||
Known issues:
|
||||
|
||||
Clicking at the bottom of an EXEC window running TTYIN is effective only when the input line is empty.
|
||||
|
||||
|
||||
|
||||
@@ -10,7 +10,7 @@ It is toggled on and off by
|
||||
|
||||
(ENABLEWHEELSCROLL ON) (initially (ENABLEWHEELSCROLL T))
|
||||
|
||||
The scrolling speed is controlled by the variable
|
||||
The vertical scrolling speed is controlled by the variable
|
||||
|
||||
WHEELSCROLLDELTA (initially 20)
|
||||
The number of points to scroll for each click of the wheel. Higher values give faster scrolling. A negative value reverses the scrolling direction.
|
||||
|
||||
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "25-Feb-2022 14:36:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;116 46252
|
||||
(FILECREATED "20-May-2022 16:35:56"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>comparetext.;118 46470
|
||||
|
||||
:CHANGES-TO (FNS COMPARETEXT.WINDOW)
|
||||
:CHANGES-TO (FNS IMCOMPARE.BOXNODE)
|
||||
|
||||
:PREVIOUS-DATE "19-Feb-2022 12:01:45"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;115)
|
||||
:PREVIOUS-DATE "25-Feb-2022 14:36:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>comparetext.;116)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -193,20 +193,26 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
X])
|
||||
|
||||
(IMCOMPARE.BOXNODE
|
||||
[LAMBDA (WINDOW NODE1 NODE2) (* ; "Edited 25-Dec-2021 12:01 by rmk")
|
||||
[LAMBDA (WINDOW NODE1 NODE2)
|
||||
|
||||
(* ;; "Edited 20-May-2022 16:35 by rmk: Invert nodes rather than FLIPNODES, so they stay inverted when scrolled")
|
||||
|
||||
(* ;; "Edited 25-Dec-2021 12:01 by rmk")
|
||||
(* rmk%: "14-Dec-84 13:40")
|
||||
|
||||
(* ;; "Marks NODE1 and NODE2 as having been selected, removing marks on previous nodes.")
|
||||
|
||||
(LET [(LASTNODES (WINDOWPROP WINDOW 'LASTNODES] (* ; "FLIPNODE ?")
|
||||
(CL:WHEN (CAR LASTNODES)
|
||||
(FLIPNODE (CAR LASTNODES)
|
||||
WINDOW))
|
||||
(RESET/NODE/LABELSHADE (CAR LASTNODES)
|
||||
'INVERT WINDOW))
|
||||
(CL:WHEN (CADR LASTNODES)
|
||||
(FLIPNODE (CADR LASTNODES)
|
||||
WINDOW))
|
||||
(CL:WHEN NODE1 (FLIPNODE NODE1 WINDOW))
|
||||
(CL:WHEN NODE2 (FLIPNODE NODE2 WINDOW))
|
||||
(RESET/NODE/LABELSHADE (CADR LASTNODES)
|
||||
'INVERT WINDOW))
|
||||
(CL:WHEN NODE1
|
||||
(RESET/NODE/LABELSHADE NODE1 'INVERT WINDOW))
|
||||
(CL:WHEN NODE2
|
||||
(RESET/NODE/LABELSHADE NODE2 'INVERT WINDOW))
|
||||
(WINDOWPROP WINDOW 'LASTNODES (LIST NODE1 NODE2])
|
||||
|
||||
(IMCOMPARE.CHUNKS
|
||||
@@ -737,12 +743,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1344 38872 (COMPARETEXT 1354 . 2854) (COMPARETEXT.WINDOW 2856 . 6357) (
|
||||
COMPARETEXT.TEXTOBJ 6359 . 9067) (COMPARETEXT.SETSEL 9069 . 9859) (CHUNKNODELABEL 9861 . 10982) (
|
||||
IMCOMPARE.BOXNODE 10984 . 11751) (IMCOMPARE.CHUNKS 11753 . 16129) (IMCOMPARE.COLLECT.HASH.CHUNKS 16131
|
||||
. 19048) (IMCOMPARE.DISPLAYGRAPH 19050 . 26893) (IMCOMPARE.HASH 26895 . 31082) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 31084 . 34580) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 34582 . 36537) (
|
||||
IMCOMPARE.SHOW.DIST 36539 . 36985) (IMCOMPARE.UPDATE.SYMBOL.TABLE 36987 . 38870)) (38873 45030 (
|
||||
IMCOMPARE.LEFTBUTTONFN 38883 . 41460) (IMCOMPARE.MIDDLEBUTTONFN 41462 . 44578) (IMCOMPARE.COPYBUTTONFN
|
||||
44580 . 45028)) (45083 45774 (TAIL1 45093 . 45447) (TAIL2 45449 . 45772)))))
|
||||
(FILEMAP (NIL (1353 39090 (COMPARETEXT 1363 . 2863) (COMPARETEXT.WINDOW 2865 . 6366) (
|
||||
COMPARETEXT.TEXTOBJ 6368 . 9076) (COMPARETEXT.SETSEL 9078 . 9868) (CHUNKNODELABEL 9870 . 10991) (
|
||||
IMCOMPARE.BOXNODE 10993 . 11969) (IMCOMPARE.CHUNKS 11971 . 16347) (IMCOMPARE.COLLECT.HASH.CHUNKS 16349
|
||||
. 19266) (IMCOMPARE.DISPLAYGRAPH 19268 . 27111) (IMCOMPARE.HASH 27113 . 31300) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 31302 . 34798) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 34800 . 36755) (
|
||||
IMCOMPARE.SHOW.DIST 36757 . 37203) (IMCOMPARE.UPDATE.SYMBOL.TABLE 37205 . 39088)) (39091 45248 (
|
||||
IMCOMPARE.LEFTBUTTONFN 39101 . 41678) (IMCOMPARE.MIDDLEBUTTONFN 41680 . 44796) (IMCOMPARE.COPYBUTTONFN
|
||||
44798 . 45246)) (45301 45992 (TAIL1 45311 . 45665) (TAIL2 45667 . 45990)))))
|
||||
STOP
|
||||
|
||||
@@ -27,7 +27,7 @@ fi
|
||||
|
||||
if [ ! -d "$MEDLEYDIR/loadups" ] ; then
|
||||
echo "MEDLEYDIR has no loadups: $MEDLEYDIR"
|
||||
if [ inferred_medleydir = true ] ; then
|
||||
if [ $inferred_medleydir = true ] ; then
|
||||
echo "I tried to infer it based on your working directory, but that didn't work."
|
||||
echo "Try cd there or setting the MEDLEYDIR environment variable to its location."
|
||||
fi
|
||||
|
||||
@@ -108,7 +108,11 @@ do git checkout -q $commit "$file" && \
|
||||
n=$fcv
|
||||
fi
|
||||
fi
|
||||
ln "$file" "$file.~"$n"~" && n=`expr $n + 1`
|
||||
ln "$file" "$file.~"$n"~" && \
|
||||
date=`git log $commit -1 --date=format-local:%Y%m%d%H%M.%S --pretty="format:%cd"` && \
|
||||
echo $commit $file $n $date && \
|
||||
touch -t $date "$file" "$file.~"$n"~" && \
|
||||
n=`expr $n + 1`
|
||||
done
|
||||
|
||||
### END SKIP
|
||||
|
||||
811
sources/ADIR
811
sources/ADIR
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Mar-2022 09:39:50" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;13 67302
|
||||
(FILECREATED "23-May-2022 12:02:10" {DSK}<users>kaplan>local>medley3.5>working-medley>sources>ADIR.;14 65884
|
||||
|
||||
:CHANGES-TO (VARS ADIRCOMS)
|
||||
(FNS FILENAMEFIELD.STRING)
|
||||
:CHANGES-TO (FNS UNPACKFILENAME.STRING)
|
||||
(VARS ADIRCOMS)
|
||||
|
||||
:PREVIOUS-DATE "26-Jan-2022 10:18:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;12)
|
||||
:PREVIOUS-DATE "26-Mar-2022 09:39:50"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>ADIR.;13)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -26,10 +26,16 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
|
||||
|
||||
(MOVD? 'NILL 'CL:PATHNAMEP]
|
||||
(COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP
|
||||
FILENAMEFIELD FILENAMEFIELD.STRING PACKFILENAME PACKFILENAME.STRING)
|
||||
(DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY
|
||||
PACKFILENAME.ASSEMBLE UNPACKFILE1))
|
||||
[COMS (FNS UNPACKFILENAME.STRING \UPF.DIRECTORY)
|
||||
(DECLARE%: DONTCOPY (MACROS \UPF.EXTRACT \UPF.DIRTYPE)
|
||||
(CONSTANTS (FILENAMECODES (CHARCODE (%: < > / %. ; ! %')))
|
||||
(MINFILENAMECODE (APPLY (FUNCTION IMIN)
|
||||
FILENAMECODES))
|
||||
(MAXFILENAMECODE (APPLY (FUNCTION IMAX)
|
||||
FILENAMECODES]
|
||||
(COMS (FNS UNPACKFILENAME LASTCHPOS FILENAMEFIELD FILENAMEFIELD.STRING PACKFILENAME
|
||||
PACKFILENAME.STRING)
|
||||
(DECLARE%: DONTCOPY (MACROS PACKFILENAME.ASSEMBLE))
|
||||
(VARS \FILENAME.SYNTAX)
|
||||
(FNS FILEDIRCASEARRAY)
|
||||
(VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY)))
|
||||
@@ -284,273 +290,427 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(UNPACKFILENAME
|
||||
[LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:")
|
||||
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])
|
||||
|
||||
(UNPACKFILENAME.STRING
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 25-Jan-2022 17:16 by rmk")
|
||||
(* ; "Edited 5-Jan-2022 11:03 by rmk")
|
||||
(* ; "Edited 30-Mar-90 22:37 by nm")
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 28-Apr-2022 11:40 by rmk")
|
||||
(* ; "Edited 24-Apr-2022 14:11 by rmk")
|
||||
|
||||
(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts")
|
||||
(* ;; "")
|
||||
|
||||
(* ;;; "rmk: devices must come before directories.")
|
||||
(* ;;
|
||||
"Given a string or atom representation of a file name, unpack it into its component parts.")
|
||||
|
||||
(PROG ((POS 1)
|
||||
(LEN (NCHARS FILE))
|
||||
TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI)
|
||||
(* ;; "From the front, the host and device are unmistakable:")
|
||||
|
||||
(* ;; " host is marked with { } [ ] or ( ); if no closer, then the whole thing is host")
|
||||
|
||||
(* ;; " device follows host until first colon; no device if directory bracket comes first (originally: Only / or > could be in the device")
|
||||
|
||||
(* ;; "Fom the back, version and extension are unmistakable:")
|
||||
|
||||
(* ;; " version is preceded by last ; Version can't contain directory brackets (but can contain dots??)")
|
||||
|
||||
(* ;; " extension is preceded by last . (not following a version ;)")
|
||||
|
||||
(* ;; "Then the directory and name fight it out in the middle:")
|
||||
|
||||
(* ;;
|
||||
" If there is < or / anywhere else but no closing / or >, then the whole thing is a name ")
|
||||
|
||||
(* ;;
|
||||
" If it begins with < or / but no closing / or >, then directory is < and the rest is name")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " If there is at least one / or > then the last one ends the directory, anything before is possibly a relative or subdirectory. Anything after is a name")
|
||||
(* ; "")
|
||||
|
||||
(* ;; " (Rationale: Those are not sub-directory brackets)")
|
||||
|
||||
(* ;;
|
||||
"Leading < duplicates are discarded. But internal << duplicates are retained (abc<<xyz) ")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Strategy:")
|
||||
|
||||
(* ;; "Peel off the host, since that may control a later pattern. Then 2 phases: A single left-to-right parse of the string to find the component positions, and a separate phase to assemble the value. ")
|
||||
|
||||
(* ;;
|
||||
"The component positions include the identifying punctuation marks, those are stripped at the end.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(PROG NIL
|
||||
(COND
|
||||
((NULL FILE)
|
||||
(RETURN NIL))
|
||||
((OR (LITATOM FILE)
|
||||
(STRINGP FILE)
|
||||
(NUMBERP FILE)))
|
||||
((OR (STRINGP FILE)
|
||||
(LITATOM FILE)))
|
||||
((NUMBERP FILE) (* ;
|
||||
"Extraction is simpler if string pointer")
|
||||
(SETQ FILE (MKSTRING FILE)))
|
||||
((TYPEP FILE 'PATHNAME)
|
||||
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
|
||||
[(STREAMP FILE) (* ;
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
|
||||
(RETURN (COND
|
||||
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
|
||||
FILE))
|
||||
(T (LIST 'NAME FILE]
|
||||
(SETQ FILE (MKSTRING (OR (ffetch FULLFILENAME of FILE)
|
||||
(RETURN (CL:IF ONEFIELDFLG
|
||||
(AND (EQ ONEFIELDFLG 'NAME)
|
||||
FILE)
|
||||
(LIST 'NAME FILE))]
|
||||
(T (\ILLEGAL.ARG FILE)))
|
||||
(COND
|
||||
((SELCHARQ (NTHCHARCODE FILE 1)
|
||||
({ (* ; "normal use in Interlisp-D")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
|
||||
FILE 2)
|
||||
0))))
|
||||
(%[ (* ;
|
||||
"some Xerox and Arpanet systems use '[' for host")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
|
||||
FILE 2)
|
||||
0))))
|
||||
(%( (* ;
|
||||
"this is the 'proposed standard' for Xerox servers")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
|
||||
FILE 2)
|
||||
0))))
|
||||
NIL)
|
||||
(UNPACKFILE1 'HOST 2 TEM)
|
||||
[COND
|
||||
((EQ TEM -1) (* ;
|
||||
"Started with the host field delimiter, but there was no corresponding terminating delimiter .")
|
||||
|
||||
(* ;;
|
||||
"Parse the string to find marker positions. The format (parens mean optional, [ ] group, | disjoins")
|
||||
|
||||
(* ;; " ({host}) (device :) ( ([<|>]) (directory >) ) (name) (. (extension)) (; (version))")
|
||||
|
||||
(* ;; " where: if the directory field begins with < or > but doesn't end later in >, directory is the < or >")
|
||||
|
||||
(* ;;
|
||||
" name doesn't contain <, >, or ;, May begin with . (differs from original)")
|
||||
|
||||
(* ;; " extension doesn't contain . and version doesn't contain ")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "NOTE: We use FILE's block coorinate system for all markers.")
|
||||
|
||||
(RETURN
|
||||
(FOR C HOST HOSTSTART HOSTEND HOSTENDCHAR STARTPOS DEVICESTART DEVICEEND DIRSTART DIREND
|
||||
DIRBRKSTART DIRBRKEND DIRDIRTY NAMESTART NAMEEND EXTENSIONSTART EXTENSIONEND
|
||||
VERSIONSTART VERSIONEND INPNAME FILE
|
||||
FIRST
|
||||
(* ;; "Host: { for Medley, [ for some arpanet, ( proposed for Xerox. If the host doesn't end its the whole string")
|
||||
|
||||
(CL:WHEN [SETQ HOSTENDCHAR (CADR (ASSOC (\GETBASECHAR $$FATP $$BASE $$OFFSET)
|
||||
(CHARCODE (({ })
|
||||
(%( %))
|
||||
(%[ %]]
|
||||
(SETQ HOSTSTART $$OFFSET)
|
||||
[SETQ HOSTEND (FOR I CH FROM (ADD1 HOSTSTART) TO $$END
|
||||
DO (* ; "Skip the opening bracket")
|
||||
(SETQ CH (\GETBASECHAR $$FATP $$BASE I))
|
||||
(IF (EQ CH HOSTENDCHAR)
|
||||
THEN (RETURN I)
|
||||
ELSEIF (EQ CH (CHARCODE %'))
|
||||
THEN (ADD I 1)) FINALLY
|
||||
|
||||
(* ;;
|
||||
"The %"bracket%" is just past the end")
|
||||
|
||||
(RETURN (ADD1 $$END]
|
||||
(SETQ HOST (\UPF.EXTRACT (ADD1 HOSTSTART)
|
||||
(SUB1 HOSTEND))) (* ; "Needed for GETHOSTINFO")
|
||||
(CL:WHEN (IGEQ HOSTEND $$END) (* ; "Only a host")
|
||||
(GO RETURNVALUE))
|
||||
(SETQ $$OFFSET (ADD1 HOSTEND)))
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "STARTPOS starts after host, is updated after device for later fields")
|
||||
|
||||
(SETQ STARTPOS $$OFFSET) WHEN (AND (IGEQ C MINFILENAMECODE)
|
||||
(ILEQ C MAXFILENAMECODE))
|
||||
DO
|
||||
(* ;; "Test interval because SELCHARQ doesn't compile as a dispatch.")
|
||||
|
||||
COERCE
|
||||
(SELCHARQ C
|
||||
(%: (* ;
|
||||
"Device ends on the first colon before any other marker")
|
||||
(CL:UNLESS (OR DEVICESTART DIRSTART NAMESTART EXTENSIONSTART VERSIONSTART)
|
||||
(SETQ DEVICESTART STARTPOS)
|
||||
(SETQ DEVICEEND $$OFFSET)
|
||||
(SETQ STARTPOS (ADD1 $$OFFSET))))
|
||||
(< (CL:UNLESS (OR EXTENSIONSTART VERSIONSTART)
|
||||
(* ;
|
||||
"I'm not sure why the name is dealt with the host name.")
|
||||
(RETURN (DREVERSE VAL]
|
||||
(SETQ POS (IPLUS TEM 2))
|
||||
[if (EQ OSTYPE T)
|
||||
then (* ;
|
||||
"Use actual host to determine os type")
|
||||
(SETQ OSTYPE (GETHOSTINFO (CAR VAL)
|
||||
'OSTYPE]
|
||||
(SETQ HOSTP T)))
|
||||
"Ordinary character if already started directory or in an extension")
|
||||
(IF DIRSTART
|
||||
THEN
|
||||
(* ;; "DIRECTORY advances over initial duplicate brackets (but DIRSTART could be a subdirectory character instead)")
|
||||
|
||||
(* ;; "rmk: if there is a colon before the next < or /, then we must be looking at a device. A device appears to end after the last colon, i.e., a device name can have a colon inside it.")
|
||||
(CL:WHEN [AND (EQ DIRSTART (SUB1 $$OFFSET))
|
||||
(FMEMB (\GETBASECHAR $$FATP $$BASE (SUB1 $$OFFSET
|
||||
))
|
||||
(CHARCODE (> / <]
|
||||
(SETQ DIRSTART $$OFFSET))
|
||||
ELSE (SETQ DIRSTART STARTPOS)
|
||||
|
||||
(COND
|
||||
((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /))
|
||||
FILE POS))
|
||||
(EQ (CHARCODE %:)
|
||||
(NTHCHARCODE FILE TEM))) (* ;
|
||||
"all device returned have DEVICE.END on it so that NIL: will work")
|
||||
(UNPACKFILE1 'DEVICE POS (if CLFLG
|
||||
then (SUB1 TEM)
|
||||
else TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SETQ HOSTP T)))
|
||||
(COND
|
||||
((EQ DIRFLG 'RETURN) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")
|
||||
(LET ((TYPE 'DIRECTORY)
|
||||
(START (SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(NIL (* ; "just host, return")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((/ <) (* ;
|
||||
"Started with the initial directory delimiter.")
|
||||
(ADD1 POS))
|
||||
POS))
|
||||
END)
|
||||
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
|
||||
((/ >)
|
||||
[COND
|
||||
((EQ START POS) (* ;
|
||||
"Didn't start with a directory delimiter,")
|
||||
(COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
|
||||
(SETQ TYPE 'SUBDIRECTORY))
|
||||
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(COND
|
||||
((EQ LEN POS) (* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}/%").")
|
||||
(SETQ START POS)
|
||||
-1)
|
||||
(T -2)))
|
||||
(PROGN [COND
|
||||
[(EQ START POS) (* ;
|
||||
"Both of the initial and trail delimiters are omitted.")
|
||||
(COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
|
||||
(SETQ TYPE 'SUBDIRECTORY))
|
||||
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(T (COND
|
||||
((EQ LEN POS)
|
||||
(* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}<%").")
|
||||
(SETQ START POS]
|
||||
-1)))
|
||||
(UNPACKFILE1.DIRECTORY TYPE START END))
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(/ (* ;
|
||||
"unix and the 'xerox standard' use / for delimiter")
|
||||
(* ;
|
||||
"In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (/ >))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
T)
|
||||
((< >) (* ;
|
||||
"Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
|
||||
(* ;
|
||||
"In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
T)
|
||||
NIL)
|
||||
(* ;;
|
||||
"DIRSTART updates for duplicates, but NAME may want all the brackets")
|
||||
|
||||
(* ;; "allow {DSK}/etc to be a directory specification.")
|
||||
(SETQ DIRBRKSTART STARTPOS))
|
||||
[SETQ NAMESTART (SETQ NAMEEND (SETQ EXTENSIONSTART (SETQ VERSIONSTART
|
||||
NIL]))
|
||||
((> /) (* ; "Preceding string is for sure a directory that maybe ends here (unless we're already in an extension")
|
||||
(IF DIRSTART
|
||||
THEN
|
||||
(* ;;
|
||||
"Advance over initial duplicate brackets (but DIRSTART could be a subdirectory character)")
|
||||
|
||||
(if TEM
|
||||
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
|
||||
(SUB1 TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
else
|
||||
(* ;; "{DSK}/foo: the directory is /, the name is foo")
|
||||
(CL:WHEN [AND (EQ DIRSTART (SUB1 $$OFFSET))
|
||||
(FMEMB (\GETBASECHAR $$FATP $$BASE (SUB1 $$OFFSET))
|
||||
(CHARCODE (> / <]
|
||||
(SETQ DIRSTART $$OFFSET))
|
||||
ELSE (SETQ DIRSTART STARTPOS)
|
||||
(SETQ DIRBRKSTART STARTPOS))
|
||||
(IF DIREND
|
||||
THEN (CL:UNLESS (EQ DIREND (SUB1 $$OFFSET))
|
||||
(CL:WHEN [OR (EQ (\GETBASECHAR $$FATP $$BASE DIREND)
|
||||
(CHARCODE /))
|
||||
(FMEMB (\GETBASECHAR $$FATP $$BASE (ADD1 DIREND)
|
||||
)
|
||||
(CHARCODE (> /]
|
||||
|
||||
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
|
||||
(SETQ POS (ADD1 POS)))
|
||||
(SETQ HOSTP T))
|
||||
((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
|
||||
FILE POS)) (* ; " {eris}abc> relative")
|
||||
(* ;;
|
||||
"Previous end may have started an internal duplicate run that needs to be cleaned up")
|
||||
|
||||
(* ;;
|
||||
" This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
|
||||
(SETQ DIRDIRTY T))
|
||||
(SETQ DIREND $$OFFSET))
|
||||
ELSE
|
||||
(* ;;
|
||||
"If this is the last bracket, it will be thrown out so it doesn't matter if it is /")
|
||||
|
||||
[COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
|
||||
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
|
||||
then 'DIRECTORY
|
||||
else 'SUBDIRECTORY)
|
||||
POS
|
||||
(SUB1 TEM)))
|
||||
(T (* ; "True %"relative pathname%".")
|
||||
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
|
||||
then 'DIRECTORY
|
||||
else 'RELATIVEDIRECTORY)
|
||||
POS
|
||||
(SUB1 TEM]
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SETQ HOSTP T)))
|
||||
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(if (EQ OSTYPE T)
|
||||
then (* ;
|
||||
"There wasn't a host field in the name, so we have no clue")
|
||||
(SETQ OSTYPE NIL))
|
||||
NAMELP
|
||||
|
||||
(SETQ DIREND $$OFFSET))
|
||||
|
||||
(* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.")
|
||||
(* ;; "NAME keeps duplicates, may want all the brackets.")
|
||||
|
||||
(SELCHARQ CODE
|
||||
(%. (* ;
|
||||
"Note position for later--we only want to deal with the last set of dots")
|
||||
(if BEYONDNAME
|
||||
then (* ;
|
||||
"no longer of interest (probably a bad name, too)")
|
||||
elseif FIRSTDOT
|
||||
then (* ; "We're recording the second dot")
|
||||
(if SECONDDOT
|
||||
then (* ;
|
||||
"Note only the two most recent dots")
|
||||
(SETQ FIRSTDOT SECONDDOT))
|
||||
(SETQ SECONDDOT TEM)
|
||||
else (SETQ FIRSTDOT TEM)))
|
||||
((! ; NIL) (* ;
|
||||
"SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
|
||||
(if (SELCHARQ CODE
|
||||
(! (* ;
|
||||
"! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
|
||||
(AND OSTYPE (NEQ OSTYPE 'IFS)))
|
||||
(; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S")
|
||||
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
|
||||
NIL)
|
||||
then (GO NEXTCHAR))
|
||||
(if FIRSTDOT
|
||||
then (* ;
|
||||
"Have a name and/or extension to parse now")
|
||||
(if
|
||||
[AND SECONDDOT
|
||||
(NOT (if OSTYPE
|
||||
then (* ;
|
||||
"Known OS type must be Tops20 for second dot to mean version")
|
||||
(EQ OSTYPE 'TOPS20)
|
||||
else (* ;
|
||||
"Unknown OS type, so check that %"version%" is numeric or wildcard")
|
||||
(AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM)
|
||||
bind CH
|
||||
always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I
|
||||
)))
|
||||
(EQ CH (CHARCODE *]
|
||||
(SELCHARQ CODE
|
||||
(NIL (* ; "end of file name, ok")
|
||||
T)
|
||||
(; (* ;
|
||||
"This semi-colon better not be introducing a version")
|
||||
(\UPF.TEMPFILEP FILE (ADD1 TEM)))
|
||||
NIL]
|
||||
then (* ;
|
||||
"Second dot is not intoducing a version")
|
||||
(SETQ FIRSTDOT SECONDDOT)
|
||||
(SETQ SECONDDOT NIL))
|
||||
(UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
|
||||
(SETQ POS (ADD1 (if SECONDDOT
|
||||
then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
|
||||
(SUB1 SECONDDOT))
|
||||
(SETQ BEYONDEXT T)
|
||||
SECONDDOT
|
||||
else FIRSTDOT)))
|
||||
(SETQ BEYONDNAME T)
|
||||
(SETQ FIRSTDOT NIL))
|
||||
(UNPACKFILE1 (COND
|
||||
((NOT BEYONDNAME)
|
||||
(SETQQ BEYONDNAME NAME))
|
||||
((NOT BEYONDEXT)
|
||||
'EXTENSION)
|
||||
((AND (EQ BEYONDEXT (CHARCODE ";"))
|
||||
(\UPF.TEMPFILEP FILE POS)))
|
||||
(T (* ;
|
||||
"Everything after the semi was version")
|
||||
'VERSION))
|
||||
POS
|
||||
(SUB1 TEM))
|
||||
(if (NULL CODE)
|
||||
then (* ; "End of string")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(SETQ BEYONDEXT CODE) (* ;
|
||||
"Note the character that terminated the name/ext")
|
||||
(SETQ POS (ADD1 TEM)))
|
||||
(%' (* ; "Quoter")
|
||||
(add TEM 1))
|
||||
NIL)
|
||||
NEXTCHAR
|
||||
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
|
||||
(GO NAMELP])
|
||||
(SETQ DIRBRKEND $$OFFSET)
|
||||
|
||||
(* ;; "Toss all prior guesses")
|
||||
|
||||
[SETQ NAMESTART (SETQ NAMEEND (SETQ EXTENSIONSTART (SETQ VERSIONSTART NIL])
|
||||
(%. (CL:UNLESS NAMESTART
|
||||
(SETQ NAMESTART (IF DIREND
|
||||
THEN (ADD1 DIRBRKEND)
|
||||
ELSE STARTPOS)))
|
||||
(CL:UNLESS (EQ NAMESTART $$OFFSET) (* ;
|
||||
"Allow . in first NAME position : .git")
|
||||
(SETQ NAMEEND (SUB1 $$OFFSET))
|
||||
(SETQ EXTENSIONSTART $$OFFSET)))
|
||||
(; (CL:WHEN VERSIONSTART (* ; "What about x;1;2")
|
||||
|
||||
(* ;; "This gives old behavior is NAME=x, VERSION=1;2")
|
||||
|
||||
(* ;;
|
||||
"If take this out: NAME=x;1, VERSION=2. I.e. move the previous version to an earlier field")
|
||||
|
||||
(GO $$ITERATE))
|
||||
|
||||
(* ;; "Starting a version, close up preceders")
|
||||
|
||||
(CL:UNLESS NAMESTART (* ; "We haven't seen a directory")
|
||||
(SETQ NAMESTART (IF DIREND
|
||||
THEN (ADD1 DIRBRKEND)
|
||||
ELSE STARTPOS)))
|
||||
(CL:IF EXTENSIONSTART
|
||||
(SETQ EXTENSIONEND (SUB1 $$OFFSET))
|
||||
(SETQ NAMEEND (SUB1 $$OFFSET)))
|
||||
(SETQ VERSIONSTART $$OFFSET))
|
||||
(%'
|
||||
(* ;;
|
||||
"Quote the next character (if there is one: original returns empty string in this case).")
|
||||
|
||||
(* ;; "But this is odd: Shouldn't quotes be removed from our value, and reinserted by PACKFILENAME ? Do devices know about our quoting conventions? What about back-slash quoting?")
|
||||
|
||||
(ADD $$OFFSET 1))
|
||||
(!
|
||||
(* ;; "! is a Xerox IFS version marker, coerce to ;")
|
||||
|
||||
(CL:WHEN (FMEMB OSTYPE '(T NIL))
|
||||
(SETQ OSTYPE (OR (GETHOSTINFO HOST 'OSTYPE)
|
||||
'IFS)))
|
||||
(CL:WHEN (EQ OSTYPE 'IFS)
|
||||
(SETQ C (CHARCODE ;))
|
||||
(GO COERCE)))
|
||||
NIL)
|
||||
FINALLY
|
||||
|
||||
(* ;; "Adjudicate directory and name. Empty NAME uses DIRBRKSTART and DIRBRKEND, since names retain duplicate brackets.")
|
||||
|
||||
(IF DIREND
|
||||
THEN
|
||||
(* ;;
|
||||
"NAME is squeezed between directory and extension, version, or end. ")
|
||||
|
||||
(CL:UNLESS NAMESTART
|
||||
(CL:WHEN (OR NAMEEND (ILESSP DIRBRKEND $$END))
|
||||
(SETQ NAMESTART (ADD1 DIRBRKEND))))
|
||||
ELSEIF DIRSTART
|
||||
THEN (* ; "DIR ran off the end")
|
||||
(IF (FMEMB (\GETBASECHAR $$FATP $$BASE DIRSTART)
|
||||
(CHARCODE (< /)))
|
||||
THEN (SETQ DIREND DIRSTART) (* ; "<aaa -> DIR < NAME aaa")
|
||||
(CL:UNLESS (EQ DIRSTART $$END)
|
||||
(SETQ NAMESTART (ADD1 DIRBRKSTART)))
|
||||
ELSE (SETQ NAMESTART DIRBRKSTART)
|
||||
(* ; "aaaa<xxx --> NAME aaa<xxx")
|
||||
(SETQ DIRSTART NIL))
|
||||
ELSEIF (ILEQ STARTPOS $$END)
|
||||
THEN
|
||||
(* ;; "Host/device were not exhaustive")
|
||||
|
||||
(SETQ NAMESTART STARTPOS))
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " DIRFLG is RETURN on calls (\UPFDirectoryNameP CL:USER-HOMEDIR-PATHNAME) where FILE is known to have no more than a directory, but the directory might not end with / or > (e.g. %"{DSK}/Users/kaplan%". If we don't do something, %"kaplan%" would be seen as the NAME. ")
|
||||
|
||||
(CL:WHEN [AND (EQ DIRFLG 'RETURN)
|
||||
(NOT (FMEMB (\GETBASECHAR $$FATP $$BASE $$END)
|
||||
(CHARCODE (> / <]
|
||||
(SETQ DIRSTART STARTPOS)
|
||||
(SETQ DIREND (ADD1 $$END))
|
||||
(SETQ DIRDIRTY T)
|
||||
(SETQ NAMESTART (SETQ EXTENSIONSTART (SETQ VERSIONSTART NIL))))
|
||||
|
||||
(* ;;
|
||||
"Construct the return value. DIRFLG=FIELD on calls from FILENAMEFIELD, with a ONEFIELDFLG.")
|
||||
|
||||
(* ;; "Fields are interrogated backwards so no need to reverse")
|
||||
|
||||
RETURNVALUE
|
||||
(RETURN (FOR F FVAL
|
||||
INSIDE (OR ONEFIELDFLG
|
||||
'(VERSION EXTENSION NAME RELATIVEDIRECTORY SUBDIRECTORY
|
||||
DIRECTORY DEVICE HOST))
|
||||
WHEN (SETQ FVAL
|
||||
(SELECTQ F
|
||||
(HOST HOST)
|
||||
(DEVICE (CL:WHEN DEVICESTART
|
||||
|
||||
(* ;;
|
||||
"Unless CLFLG, include the colon so NIL: works as atom")
|
||||
|
||||
(\UPF.EXTRACT DEVICESTART (CL:IF CLFLG
|
||||
(SUB1 DEVICEEND)
|
||||
DEVICEEND))))
|
||||
(DIRECTORY
|
||||
(* ;; "Subtypes move up to DIRECTORY if FIELD")
|
||||
|
||||
(CL:WHEN [AND DIRSTART (OR (EQ 'DIRECTORY
|
||||
(\UPF.DIRTYPE
|
||||
DIRSTART))
|
||||
(EQ DIRFLG
|
||||
'FIELD]
|
||||
(\UPF.DIRECTORY DIRSTART DIREND DIRDIRTY
|
||||
$$BASE $$FATP $$READONLY)))
|
||||
((SUBDIRECTORY RELATIVEDIRECTORY)
|
||||
(CL:WHEN (AND DIRSTART (EQ F (\UPF.DIRTYPE DIRSTART))
|
||||
(NEQ DIRFLG 'FIELD))
|
||||
(\UPF.DIRECTORY DIRSTART DIREND DIRDIRTY $$BASE
|
||||
$$FATP $$READONLY)))
|
||||
(NAME (CL:WHEN NAMESTART
|
||||
(OR (\UPF.EXTRACT NAMESTART (OR NAMEEND $$END))
|
||||
"")))
|
||||
(EXTENSION (CL:WHEN EXTENSIONSTART
|
||||
(OR (\UPF.EXTRACT (ADD1 EXTENSIONSTART)
|
||||
(OR EXTENSIONEND $$END))
|
||||
"")))
|
||||
(VERSION (CL:WHEN VERSIONSTART
|
||||
(OR (\UPF.EXTRACT (ADD1 VERSIONSTART)
|
||||
$$END)
|
||||
"")))
|
||||
NIL)) DO (CL:WHEN PACKFLG
|
||||
(SETQ FVAL (CL:UNLESS (EQ 0 (NCHARS FVAL))
|
||||
|
||||
(* ;;
|
||||
"Empty string goes to NIL, not empty atom")
|
||||
|
||||
(MKATOM FVAL))))
|
||||
(CL:WHEN ONEFIELDFLG (RETURN FVAL))
|
||||
(PUSH $$VAL F FVAL])
|
||||
|
||||
(\UPF.DIRECTORY
|
||||
[LAMBDA (DIRSTART DIREND DIRDIRTY $$BASE $$FATP $$READONLY)(* ; "Edited 28-Apr-2022 09:15 by rmk")
|
||||
(* ; "Edited 27-Apr-2022 08:50 by rmk")
|
||||
(* ; "Edited 23-Apr-2022 17:09 by rmk")
|
||||
|
||||
(* ;; "Relative directory {abc}<foo or {abc}< with no >, subdirectory >foo or > with no host or device (DIRSTART=1). ")
|
||||
|
||||
(* ;; "Advance DIRSTART through initial duplicates")
|
||||
|
||||
(LET ((BRACKET (SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
|
||||
((< /)
|
||||
"<")
|
||||
(> ">")
|
||||
NIL)))
|
||||
(IF (EQ DIREND DIRSTART)
|
||||
THEN
|
||||
(* ;; "If EQ, the directory is just the bracket, the rest is must be the name.")
|
||||
|
||||
BRACKET
|
||||
ELSE (CL:WHEN BRACKET (* ; "Skip the < or /")
|
||||
(ADD DIRSTART 1))
|
||||
|
||||
(* ;;
|
||||
"Convert / to >, remove all // /> >> duplicate sequences (keep the first, skip the others)")
|
||||
|
||||
(IF DIRDIRTY
|
||||
THEN (FOR DIROFF C DEST DESTBASE (DESTPOS _ -1) FROM DIRSTART TO DIREND
|
||||
FIRST (SETQ DEST (ALLOCSTRING (ADD1 (IDIFFERENCE DIREND DIRSTART))
|
||||
NIL NIL $$FATP))
|
||||
(SETQ DESTBASE (FETCH (STRINGP BASE) OF DEST))
|
||||
DO (ADD DESTPOS 1)
|
||||
(SETQ C (\GETBASECHAR $$FATP $$BASE DIROFF))
|
||||
(SELCHARQ C
|
||||
((> /)
|
||||
(\PUTBASECHAR $$FATP DESTBASE DESTPOS (CHARCODE >))
|
||||
|
||||
(* ;; "Advance past duplicates")
|
||||
|
||||
(FIND I FROM (ADD1 DIROFF) TO DIREND
|
||||
WHILE (FMEMB (\GETBASECHAR $$FATP $$BASE I)
|
||||
(CHARCODE (> /)))
|
||||
FINALLY (SETQ DIROFF (SUB1 I))))
|
||||
(\PUTBASECHAR $$FATP DESTBASE DESTPOS C))
|
||||
FINALLY (REPLACE (STRINGP LENGTH) OF DEST WITH DESTPOS)
|
||||
(RETURN DEST))
|
||||
ELSE (\UPF.EXTRACT DIRSTART (SUB1 DIREND])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \UPF.EXTRACT MACRO ((STARTOFFSET ENDOFFSET) (* ; "Substring in base coordinates")
|
||||
(CREATE STRINGP
|
||||
OFFST _ STARTOFFSET
|
||||
LENGTH _ (ADD1 (IDIFFERENCE ENDOFFSET STARTOFFSET))
|
||||
BASE _ $$BASE
|
||||
READONLY _ $$READONLY)))
|
||||
|
||||
(PUTPROPS \UPF.DIRTYPE MACRO [(DIRSTART) (* ; "Edited 20-Apr-2022 20:14 by rmk")
|
||||
(SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
|
||||
((< > /) (* ; "Seems to match the old version")
|
||||
'DIRECTORY)
|
||||
(CL:IF (OR HOST DEVICESTART)
|
||||
'RELATIVEDIRECTORY
|
||||
'SUBDIRECTORY)])
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ FILENAMECODES (CHARCODE (%: < > / %. ; ! %')))
|
||||
|
||||
(RPAQ MINFILENAMECODE (APPLY (FUNCTION IMIN)
|
||||
FILENAMECODES))
|
||||
|
||||
(RPAQ MAXFILENAMECODE (APPLY (FUNCTION IMAX)
|
||||
FILENAMECODES))
|
||||
|
||||
|
||||
(CONSTANTS (FILENAMECODES (CHARCODE (%: < > / %. ; ! %')))
|
||||
(MINFILENAMECODE (APPLY (FUNCTION IMIN)
|
||||
FILENAMECODES))
|
||||
(MAXFILENAMECODE (APPLY (FUNCTION IMAX)
|
||||
FILENAMECODES)))
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(UNPACKFILENAME
|
||||
[LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:")
|
||||
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])
|
||||
|
||||
(LASTCHPOS
|
||||
[LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER")
|
||||
@@ -564,26 +724,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(add START 1))
|
||||
(RETURN RESULT])
|
||||
|
||||
(\UPF.NEXTPOS
|
||||
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
|
||||
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND
|
||||
((EQMEMB NCH CHAR)
|
||||
(RETURN POS))
|
||||
((EQ NCH (CHARCODE %'))
|
||||
(add POS 1)))
|
||||
(add POS 1])
|
||||
|
||||
(\UPF.TEMPFILEP
|
||||
[LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:")
|
||||
|
||||
(* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.")
|
||||
|
||||
(SELCHARQ (NTHCHARCODE FILENAME START)
|
||||
((T S) (* ; "Funny temp stuff")
|
||||
(AND (EQ START (NCHARS FILENAME))
|
||||
'TEMPORARY))
|
||||
NIL])
|
||||
|
||||
(FILENAMEFIELD
|
||||
[LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm")
|
||||
(UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME
|
||||
@@ -626,94 +766,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS CANONICAL.DIRECTORY MACRO
|
||||
[OPENLAMBDA (SRCSTRING)
|
||||
(AND
|
||||
SRCSTRING
|
||||
(LET
|
||||
((LEN (NCHARS SRCSTRING)))
|
||||
(COND
|
||||
((EQ LEN 1)
|
||||
(if (STREQUAL SRCSTRING "/")
|
||||
then "<"
|
||||
else SRCSTRING))
|
||||
(T
|
||||
(LET*
|
||||
((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
|
||||
(DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
|
||||
(DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
|
||||
(DSTPOS 0)
|
||||
(NEXTPOS -1))
|
||||
(if (NOT FATP)
|
||||
then [for SRCPOS from 1 to LEN bind CODE
|
||||
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
|
||||
(CHARCODE (< / >))) do (add SRCPOS 1))
|
||||
(if (> SRCPOS LEN)
|
||||
then (RETURN "<"))
|
||||
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
|
||||
((> /)
|
||||
(if (> DSTPOS NEXTPOS)
|
||||
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
|
||||
(SETQ NEXTPOS (add DSTPOS 1))))
|
||||
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)
|
||||
(if (NEQ SRCPOS LEN)
|
||||
then (\PUTBASETHIN DSTBASE DSTPOS
|
||||
(NTHCHARCODE SRCSTRING (add SRCPOS 1)))
|
||||
(add DSTPOS 1)))
|
||||
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)))
|
||||
finally (RETURN (if (EQ DSTPOS LEN)
|
||||
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 -2)
|
||||
else DSTSTRING)
|
||||
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
|
||||
else (SUBSTRING DSTSTRING 1 DSTPOS]
|
||||
else (for SRCPOS from 1 to LEN bind CODE
|
||||
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
|
||||
(CHARCODE (< / >))) do (add SRCPOS 1))
|
||||
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
|
||||
((> /)
|
||||
(if (> DSTPOS NEXTPOS)
|
||||
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
|
||||
(SETQ NEXTPOS (add DSTPOS 1))))
|
||||
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)
|
||||
(if (NEQ SRCPOS LEN)
|
||||
then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE
|
||||
SRCSTRING
|
||||
(add SRCPOS 1)))
|
||||
(add DSTPOS 1)))
|
||||
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)))
|
||||
finally (RETURN (if (EQ DSTPOS LEN)
|
||||
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 -2)
|
||||
else DSTSTRING)
|
||||
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
|
||||
else (SUBSTRING DSTSTRING 1 DSTPOS])
|
||||
|
||||
(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
|
||||
(LET* ((OLDDIR (SUBSTRING FILE ST END))
|
||||
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (AND NEWDIR
|
||||
(MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR "")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR ""])
|
||||
|
||||
(PUTPROPS PACKFILENAME.ASSEMBLE MACRO
|
||||
[NIL
|
||||
(PROG ((BLIP "")
|
||||
@@ -925,20 +977,6 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
((%. ! ;)
|
||||
(SUBSTRING VERSION 2 -1))
|
||||
VERSION])
|
||||
|
||||
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
"")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
""])
|
||||
)
|
||||
)
|
||||
|
||||
@@ -1188,15 +1226,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1991 1992 1920 2017 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2837 13962 (DELFILE 2847 . 3008) (FULLNAME 3010 . 3377) (INFILE 3379 . 3527) (INFILEP
|
||||
3529 . 3664) (IOFILE 3666 . 3806) (OPENFILE 3808 . 4208) (OPENSTREAM 4210 . 8550) (OUTFILE 8552 . 8703
|
||||
) (OUTFILEP 8705 . 8841) (RENAMEFILE 8843 . 9149) (SIMPLE.FINDFILE 9151 . 9561) (VMEMSIZE 9563 . 9730)
|
||||
(\COPYSYS 9732 . 12681) (\FLUSHVM 12683 . 13755) (\LOGOUT0 13757 . 13960)) (14334 35147 (
|
||||
UNPACKFILENAME 14344 . 14530) (UNPACKFILENAME.STRING 14532 . 31445) (LASTCHPOS 31447 . 32141) (
|
||||
\UPF.NEXTPOS 32143 . 32788) (\UPF.TEMPFILEP 32790 . 33367) (FILENAMEFIELD 33369 . 33854) (
|
||||
FILENAMEFIELD.STRING 33856 . 34435) (PACKFILENAME 34437 . 34780) (PACKFILENAME.STRING 34782 . 35145))
|
||||
(56669 57582 (FILEDIRCASEARRAY 56679 . 57580)) (57749 64929 (LOGOUT 57759 . 58676) (MAKESYS 58678 .
|
||||
60307) (SYSOUT 60309 . 61861) (SAVEVM 61863 . 62663) (HERALD 62665 . 62825) (INTERPRET.REM.CM 62827 .
|
||||
64552) (\USEREVENT 64554 . 64927)) (65111 66838 (USERNAME 65121 . 66077) (SETUSERNAME 66079 . 66836)))
|
||||
))
|
||||
(FILEMAP (NIL (3179 14304 (DELFILE 3189 . 3350) (FULLNAME 3352 . 3719) (INFILE 3721 . 3869) (INFILEP
|
||||
3871 . 4006) (IOFILE 4008 . 4148) (OPENFILE 4150 . 4550) (OPENSTREAM 4552 . 8892) (OUTFILE 8894 . 9045
|
||||
) (OUTFILEP 9047 . 9183) (RENAMEFILE 9185 . 9491) (SIMPLE.FINDFILE 9493 . 9903) (VMEMSIZE 9905 . 10072
|
||||
) (\COPYSYS 10074 . 13023) (\FLUSHVM 13025 . 14097) (\LOGOUT0 14099 . 14302)) (14676 36581 (
|
||||
UNPACKFILENAME.STRING 14686 . 33960) (\UPF.DIRECTORY 33962 . 36579)) (38109 40781 (UNPACKFILENAME
|
||||
38119 . 38305) (LASTCHPOS 38307 . 39001) (FILENAMEFIELD 39003 . 39488) (FILENAMEFIELD.STRING 39490 .
|
||||
40069) (PACKFILENAME 40071 . 40414) (PACKFILENAME.STRING 40416 . 40779)) (55251 56164 (
|
||||
FILEDIRCASEARRAY 55261 . 56162)) (56331 63511 (LOGOUT 56341 . 57258) (MAKESYS 57260 . 58889) (SYSOUT
|
||||
58891 . 60443) (SAVEVM 60445 . 61245) (HERALD 61247 . 61407) (INTERPRET.REM.CM 61409 . 63134) (
|
||||
\USEREVENT 63136 . 63509)) (63693 65420 (USERNAME 63703 . 64659) (SETUSERNAME 64661 . 65418)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Jan-2022 10:18:51" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;15 56955
|
||||
(FILECREATED " 5-Jun-2022 00:14:07"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>COREIO.;17 57355
|
||||
|
||||
:CHANGES-TO (VARS COREIOCOMS)
|
||||
:CHANGES-TO (FNS \CORE.OPENFILE)
|
||||
|
||||
:PREVIOUS-DATE "18-Jan-2022 11:22:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;14)
|
||||
:PREVIOUS-DATE " 4-Jun-2022 16:30:20"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>COREIO.;16)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -411,7 +412,8 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(LIST NAME])
|
||||
|
||||
(\CORE.OPENFILE
|
||||
[LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (* ; "Edited 13-Jan-88 19:23 by bvm")
|
||||
[LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (* ; "Edited 5-Jun-2022 00:14 by rmk")
|
||||
(* ; "Edited 13-Jan-88 19:23 by bvm")
|
||||
(PROG (STREAM INFOBLK EOL)
|
||||
(AND OLDSTREAM (RETURN OLDSTREAM))
|
||||
|
||||
@@ -420,26 +422,26 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(COND
|
||||
[(type? STREAM NAME)
|
||||
(COND
|
||||
((NULL (fetch ACCESS of NAME))
|
||||
[(NULL (fetch ACCESS of NAME))
|
||||
|
||||
(* ;; "A closed file to be re-opened by its stream")
|
||||
|
||||
(SETQ INFOBLK (fetch INFOBLK of NAME))
|
||||
[if (EQ ACCESS 'OUTPUT)
|
||||
then (* ;
|
||||
"Open for OUTPUT implies no content, so smash any existing pages")
|
||||
(replace IOEOFFSET of INFOBLK with 0)
|
||||
(replace IOEPAGE of INFOBLK with 0)
|
||||
(replace IOFILEPAGES of INFOBLK
|
||||
with (LIST (create CORE.PAGEENTRY
|
||||
PAGENUMBER _ 0]
|
||||
(SETQ STREAM (create CORESTREAM
|
||||
smashing NAME DEVICE _ FDEV INFOBLK _ INFOBLK FULLFILENAME _
|
||||
(fetch IOFILEFULLNAME of INFOBLK)
|
||||
EOFFSET _ (fetch IOEOFFSET of INFOBLK)
|
||||
EPAGE _ (fetch IOEPAGE of INFOBLK)
|
||||
EOLCONVENTION _ (fetch COREEOLC of INFOBLK)
|
||||
CBUFMAXSIZE _ BYTESPERPAGE)))
|
||||
then (* ;
|
||||
"Open for OUTPUT implies no content, so smash any existing pages")
|
||||
(replace IOEOFFSET of INFOBLK with 0)
|
||||
(replace IOEPAGE of INFOBLK with 0)
|
||||
(replace IOFILEPAGES of INFOBLK with (LIST (create CORE.PAGEENTRY
|
||||
PAGENUMBER _ 0]
|
||||
(SETQ STREAM (create CORESTREAM smashing NAME DEVICE _ FDEV INFOBLK _ INFOBLK
|
||||
FULLFILENAME _ (fetch IOFILEFULLNAME
|
||||
of INFOBLK)
|
||||
EOFFSET _ (fetch IOEOFFSET of INFOBLK)
|
||||
EPAGE _ (fetch IOEPAGE of INFOBLK)
|
||||
EOLCONVENTION _ (fetch COREEOLC of INFOBLK)
|
||||
CBUFMAXSIZE _ BYTESPERPAGE OTHERPROPS _
|
||||
(fetch OTHERPROPS of NAME]
|
||||
((\IOMODEP NAME ACCESS T)
|
||||
|
||||
(* ;; "hdj - need we ever worry about being passed an already-open stream?")
|
||||
@@ -451,14 +453,14 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
((NEQ ACCESS 'INPUT)
|
||||
(\COREFILE.SETPARAMETERS STREAM PARAMETERS))
|
||||
((SETQ EOL (ASSOC 'EOL PARAMETERS)) (* ;
|
||||
"Set EOL for the input stream, in contradiction of whatever the file might have said.")
|
||||
"Set EOL for the input stream, in contradiction of whatever the file might have said.")
|
||||
(replace EOLCONVENTION of STREAM with (SELECTQ (CADR EOL)
|
||||
((CR NIL)
|
||||
((CR NIL)
|
||||
(* ; "default")
|
||||
CR.EOLC)
|
||||
(LF LF.EOLC)
|
||||
(CRLF CRLF.EOLC)
|
||||
(\ILLEGAL.ARG EOL]
|
||||
CR.EOLC)
|
||||
(LF LF.EOLC)
|
||||
(CRLF CRLF.EOLC)
|
||||
(\ILLEGAL.ARG EOL]
|
||||
(T
|
||||
(* ;; "Head for not-found error in \OPENFILE")
|
||||
|
||||
@@ -870,7 +872,8 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(RETURN FDEV])
|
||||
|
||||
(\NODIRCORE.OPENFILE
|
||||
[LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV) (* lmm "24-May-85 11:59")
|
||||
[LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV) (* ; "Edited 4-Jun-2022 16:27 by rmk")
|
||||
(* lmm "24-May-85 11:59")
|
||||
(* ; "Open function for NODIRCORE")
|
||||
(COND
|
||||
[(type? STREAM NAME)
|
||||
@@ -882,13 +885,13 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
|
||||
(* ;; "We'll return the stream that was given us, but we make sure that all its fields are back to their initial settings")
|
||||
|
||||
(create CORESTREAM smashing NAME DEVICE _ FDEV INFOBLK _ INFOBLK
|
||||
FULLFILENAME _ (fetch IOFILEFULLNAME
|
||||
of INFOBLK)
|
||||
EOFFSET _ (fetch IOEOFFSET of INFOBLK)
|
||||
EPAGE _ (fetch IOEPAGE of INFOBLK)
|
||||
EOLCONVENTION _ (fetch COREEOLC of INFOBLK)
|
||||
CBUFMAXSIZE _ BYTESPERPAGE]
|
||||
(create CORESTREAM smashing NAME DEVICE _ FDEV INFOBLK _ INFOBLK FULLFILENAME _
|
||||
(fetch IOFILEFULLNAME of INFOBLK)
|
||||
EOFFSET _ (fetch IOEOFFSET of INFOBLK)
|
||||
EPAGE _ (fetch IOEPAGE of INFOBLK)
|
||||
EOLCONVENTION _ (fetch COREEOLC of INFOBLK)
|
||||
CBUFMAXSIZE _ BYTESPERPAGE OTHERPROPS _
|
||||
(fetch OTHERPROPS of NAME]
|
||||
(T (SELECTQ RECOG
|
||||
((NEW OLD/NEW)
|
||||
(SETQ NAME (create CORESTREAM
|
||||
@@ -997,16 +1000,16 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1993 1999 2018))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1703 46161 (\CORE.CLOSEFILE 1713 . 2486) (\CORE.DELETEFILE 2488 . 4474) (
|
||||
\CORE.DIRECTORYNAMEP 4476 . 6157) (\CORE.FINDPAGE 6159 . 9388) (\CORE.GENERATEFILES 9390 . 11977) (
|
||||
\CORE.NEXTFILEFN 11979 . 12478) (\CORE.FILEINFOFN 12480 . 12709) (\CORE.GETFILEHANDLE 12711 . 14865) (
|
||||
\CORE.GETFILEINFO 14867 . 15830) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15832 . 17369) (\CORE.GETFILENAME
|
||||
17371 . 19660) (\CORE.GETINFOBLOCK 19662 . 22285) (\CORE.NAMESCAN 22287 . 23834) (\CORE.NAMESEGMENT
|
||||
23836 . 24273) (\CORE.OPENFILE 24275 . 27394) (\COREFILE.SETPARAMETERS 27396 . 29577) (
|
||||
\CORE.PACKFILENAME 29579 . 29974) (\CORE.RELEASEPAGES 29976 . 30577) (\CORE.SETFILEPTR 30579 . 31678)
|
||||
(\CORE.UPDATEOF 31680 . 33309) (\CORE.BACKFILEPTR 33311 . 35519) (\CORE.SETEOFPTR 35521 . 37390) (
|
||||
\CORE.SETACCESSTIME 37392 . 38017) (\CORE.SETFILEINFO 38019 . 40321) (\CORE.GETNEXTBUFFER 40323 .
|
||||
44279) (\CORE.UNPACKFILENAME 44281 . 46159)) (46162 49795 (COREDEVICE 46172 . 46343) (
|
||||
\CREATECOREDEVICE 46345 . 49793)) (49796 52097 (\NODIRCOREFDEV 49806 . 50403) (\NODIRCORE.OPENFILE
|
||||
50405 . 52095)))))
|
||||
(FILEMAP (NIL (1717 46448 (\CORE.CLOSEFILE 1727 . 2500) (\CORE.DELETEFILE 2502 . 4488) (
|
||||
\CORE.DIRECTORYNAMEP 4490 . 6171) (\CORE.FINDPAGE 6173 . 9402) (\CORE.GENERATEFILES 9404 . 11991) (
|
||||
\CORE.NEXTFILEFN 11993 . 12492) (\CORE.FILEINFOFN 12494 . 12723) (\CORE.GETFILEHANDLE 12725 . 14879) (
|
||||
\CORE.GETFILEINFO 14881 . 15844) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15846 . 17383) (\CORE.GETFILENAME
|
||||
17385 . 19674) (\CORE.GETINFOBLOCK 19676 . 22299) (\CORE.NAMESCAN 22301 . 23848) (\CORE.NAMESEGMENT
|
||||
23850 . 24287) (\CORE.OPENFILE 24289 . 27681) (\COREFILE.SETPARAMETERS 27683 . 29864) (
|
||||
\CORE.PACKFILENAME 29866 . 30261) (\CORE.RELEASEPAGES 30263 . 30864) (\CORE.SETFILEPTR 30866 . 31965)
|
||||
(\CORE.UPDATEOF 31967 . 33596) (\CORE.BACKFILEPTR 33598 . 35806) (\CORE.SETEOFPTR 35808 . 37677) (
|
||||
\CORE.SETACCESSTIME 37679 . 38304) (\CORE.SETFILEINFO 38306 . 40608) (\CORE.GETNEXTBUFFER 40610 .
|
||||
44566) (\CORE.UNPACKFILENAME 44568 . 46446)) (46449 50082 (COREDEVICE 46459 . 46630) (
|
||||
\CREATECOREDEVICE 46632 . 50080)) (50083 52497 (\NODIRCOREFDEV 50093 . 50690) (\NODIRCORE.OPENFILE
|
||||
50692 . 52495)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "17-Mar-2022 12:05:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>MACHINEINDEPENDENT.;24 113260
|
||||
(FILECREATED "22-May-2022 13:19:56"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;34 117192
|
||||
|
||||
:CHANGES-TO (FNS FINDFILE-WITH-EXTENSIONS)
|
||||
:CHANGES-TO (FNS LISPFILETYPE LISPSOURCEFILEP)
|
||||
(VARS MACHINEINDEPENDENTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "15-Mar-2022 11:50:25"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>MACHINEINDEPENDENT.;23)
|
||||
:PREVIOUS-DATE "19-May-2022 16:22:57"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;27)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -48,7 +49,7 @@ with the terms of said license.
|
||||
"Functions for retrieving and remembering FILEMAPs and file reader environments")
|
||||
(FNS FILEMAP \PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP
|
||||
LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \FILEMAP-HASHOVERFLOW
|
||||
FLUSHFILEMAPS LISPSOURCEFILEP GETFILEMAP PUTFILEMAP UPDATEFILEMAP)
|
||||
FLUSHFILEMAPS LISPSOURCEFILEP LISPFILETYPE GETFILEMAP PUTFILEMAP UPDATEFILEMAP)
|
||||
[INITVARS (*FILEMAP-LIMIT* 20)
|
||||
(*FILEMAP-VERSIONS* 2)
|
||||
(*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \FILEMAP-HASHOVERFLOW)
|
||||
@@ -288,11 +289,15 @@ with the terms of said license.
|
||||
|
||||
(DOFILESLOAD
|
||||
[LAMBDA (FILES)
|
||||
(DECLARE (USEDFREE LDFLG)) (* ; "Edited 15-Mar-2022 00:48 by rmk")
|
||||
(* ; "Edited 4-May-88 14:23 by bvm")
|
||||
(DECLARE (USEDFREE LDFLG))
|
||||
|
||||
(* ;; "Edited 19-May-2022 16:22 by rmk: (FROM LISPUSERS) tries LISPUSERSDIRECTORY as well as LISPUSERSDIRECTORIES")
|
||||
|
||||
(* ;; "Edited 15-Mar-2022 00:48 by rmk")
|
||||
|
||||
(* ;; "Edited 4-May-88 14:23 by bvm")
|
||||
(* ; "does the work of FILESLOAD")
|
||||
(for FILE inside FILES bind DIRS LOADOPTIONSFLG FORCEDEXT? NOERRORFLG WORD FULL
|
||||
(FN _ 'LOAD?)
|
||||
(for FILE inside FILES bind DIRS LOADOPTIONSFLG FORCEDEXT? NOERRORFLG FULL (FN _ 'LOAD?)
|
||||
(EXT _ :COMPILED)
|
||||
first [COND
|
||||
((BOUNDP 'LDFLG)
|
||||
@@ -351,7 +356,7 @@ with the terms of said license.
|
||||
"already weeded out the ones with filedates")
|
||||
(LOAD FULL LOADOPTIONSFLG))
|
||||
(CL:FUNCALL FN FULL LOADOPTIONSFLG]
|
||||
(T (while (LISTP FILE)
|
||||
(T (bind WORD PACKED while (LISTP FILE)
|
||||
do (SELECTQ (CAR FILE)
|
||||
(LOADCOMP (SETQQ FN LOADCOMP?)
|
||||
(SETQ LOADOPTIONSFLG NIL)
|
||||
@@ -374,8 +379,13 @@ with the terms of said license.
|
||||
(({ <)
|
||||
NIL)
|
||||
T)
|
||||
[BOUNDP (SETQ WORD (PACK* WORD 'DIRECTORIES]
|
||||
(SETQ WORD (EVALV WORD)))
|
||||
[OR [BOUNDP (SETQ PACKED (PACK* WORD
|
||||
|
||||
'DIRECTORIES
|
||||
]
|
||||
(BOUNDP (SETQ PACKED (PACK* WORD
|
||||
'DIRECTORY]
|
||||
(SETQ WORD (EVALV PACKED)))
|
||||
(* ;
|
||||
"KLUDGE: Turns, e.g., (FROM LISPUSERS) into (FROM VALUEOF LISPUSERSDIRECTORIES)")
|
||||
WORD)
|
||||
@@ -1638,25 +1648,81 @@ WRITEFILE OF ")
|
||||
ROOTNAME])
|
||||
|
||||
(LISPSOURCEFILEP
|
||||
[LAMBDA (FILE) (* ; "Edited 9-Jul-2021 22:12 by rmk:")
|
||||
[LAMBDA (FILE)
|
||||
|
||||
(* ;;; "If the first few characters of FILE `look like' those output by MAKEFILE then return the alleged address in the file of its FILEMAP expression.")
|
||||
(* ;; "Edited 22-May-2022 09:49 by rmk: If FILE is a stream but not open for input, open it")
|
||||
|
||||
(* ;; "Edited 9-Jul-2021 22:12 by rmk:")
|
||||
|
||||
(* ;;; "If the first few characters of FILE `look like' those output by MAKEFILE then return the alleged address in the file of its FILEMAP expression.")
|
||||
|
||||
(RESETLST
|
||||
(CL:UNLESS (STREAMP FILE)
|
||||
(CL:UNLESS (AND (STREAMP FILE)
|
||||
(GETSTREAM FILE 'INPUT T))
|
||||
[RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT])
|
||||
(CL:WHEN (RANDACCESSP FILE)
|
||||
(LET ((HERE (GETFILEPTR FILE)))
|
||||
(CL:MULTIPLE-VALUE-BIND (ENV MAP)
|
||||
[\PARSE-FILE-HEADER FILE (FUNCTION (LAMBDA (STREAM)
|
||||
(* ;
|
||||
"Pointed now right after the FILECREATED expression")
|
||||
(CAR (NLSETQ (SKREAD STREAM)
|
||||
(SKREAD STREAM)
|
||||
(FIXP (READ STREAM]
|
||||
(* ;
|
||||
"Pointed now right after the FILECREATED expression")
|
||||
(CAR (NLSETQ (SKREAD STREAM)
|
||||
(SKREAD STREAM)
|
||||
(FIXP (READ STREAM]
|
||||
(SETFILEPTR FILE HERE)
|
||||
(CL:VALUES ENV MAP)))))])
|
||||
|
||||
(LISPFILETYPE
|
||||
[LAMBDA (FILE) (* ; "Edited 22-May-2022 13:18 by rmk")
|
||||
|
||||
(* ;; "If FILE is a Lisp file, returns values TYPE FILEDATE SOURCEDATE, where TYPE is SOURCE, COMPILED, or NIL, DATE is the filedate of FILE and SOURCEDATE is the date of the source file for a compiled file (if it can be determined).")
|
||||
|
||||
(* ;; "Could be extended to return a subtypes (MANAGED/UNMANAGED for source files, LCOM or DFASL for compiled.")
|
||||
|
||||
(* ;; "If not RANDACCESSP, this depends on the fact that another stream can be opened on the file. (MULTIPLE-STREAM-PER-FILE.ALLOWED ?)")
|
||||
|
||||
(CL:WHEN FILE
|
||||
(LET (TYPE DATE SDATE) (* ;
|
||||
"VALUES has to be outside of the NLSETQ")
|
||||
[NLSETQ (RESETLST
|
||||
[LET (STREAM)
|
||||
[COND
|
||||
[(AND (SETQ STREAM (\GETSTREAM FILE 'INPUT T))
|
||||
(RANDACCESSP STREAM))
|
||||
(RESETSAVE NIL `(SETFILEPTR ,STREAM ,(GETFILEPTR STREAM]
|
||||
(T (RESETSAVE NIL `(CLOSEF ,(SETQ STREAM (OPENSTREAM FILE
|
||||
'INPUT]
|
||||
(SETFILEPTR STREAM 0)
|
||||
(SETQ TYPE
|
||||
(COND
|
||||
((SETQ DATE (FASL-FILEDATE STREAM T))
|
||||
|
||||
(* ;; " Aha, a Dfasl file")
|
||||
|
||||
(* ;; " Having decided it's a DFASL, FASL-FILEDATE T returned the compiled date, calling again with NIL returns the source date. Better would be for FASL-FILEDATE to return both in a single call, as a multiple value.")
|
||||
|
||||
(SETFILEPTR STREAM 0)
|
||||
(SETQ SDATE (FASL-FILEDATE STREAM NIL))
|
||||
'COMPILED)
|
||||
(T (* ; "Any other filetype")
|
||||
(SETFILEPTR STREAM 0) (* ; "Reset: don't know what FASL did")
|
||||
(CL:MULTIPLE-VALUE-BIND
|
||||
(ENV FORM)
|
||||
(\PARSE-FILE-HEADER STREAM 'RETURN)
|
||||
(CL:WHEN (EQ (CAR (LISTP FORM))
|
||||
'FILECREATED)
|
||||
|
||||
(* ;; "Compiled if 2 dates, otherwise source")
|
||||
|
||||
[SETQ DATE (CAR (LISTP (CDR FORM]
|
||||
(SETQ FORM (WITH-READER-ENVIRONMENT ENV (READ STREAM)))
|
||||
(IF (EQ (CAR (LISTP FORM))
|
||||
'FILECREATED)
|
||||
THEN [SETQ SDATE (CAR (LISTP (CDR FORM]
|
||||
'COMPILED
|
||||
ELSE 'SOURCE))])]
|
||||
(CL:VALUES TYPE DATE SDATE)))])
|
||||
|
||||
(GETFILEMAP
|
||||
[LAMBDA (STREAM FL) (* bvm%: "27-Aug-86 15:48")
|
||||
|
||||
@@ -2388,23 +2454,23 @@ This has little hope of working any more.")
|
||||
(PUTPROPS MACHINEINDEPENDENT COPYRIGHT ("Venue & Xerox Corporation" T 1983 1984 1985 1986 1987 1988
|
||||
1989 1990 1991 2021 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (12853 25784 (LOAD? 12863 . 14714) (FILESLOAD 14716 . 15005) (DOFILESLOAD 15007 . 22139)
|
||||
(FINDFILE-WITH-EXTENSIONS 22141 . 25340) (READ-FILECREATED 25342 . 25782)) (25901 31222 (DMPHASH
|
||||
25911 . 27505) (HASHOVERFLOW 27507 . 31220)) (31978 63315 (BKBUFS 31988 . 33107) (CHANGENAME 33109 .
|
||||
33370) (CHNGNM 33372 . 35220) (CLBUFS 35222 . 36495) (DEFINE 36497 . 37221) (FNS.PUTDEF 37223 . 40638)
|
||||
(EQMEMB 40640 . 40822) (EQUALN 40824 . 41653) (FNCHECK 41655 . 43662) (FNTYP1 43664 . 43761) (LCSKIP
|
||||
43763 . 44607) (MAPRINT 44609 . 45555) (MKLIST 45557 . 45707) (NAMEFIELD 45709 . 47234) (NLIST 47236
|
||||
. 47571) (PRINTBELLS 47573 . 47699) (PROMPTCHAR 47701 . 49591) (RAISEP 49593 . 49854) (READFILE 49856
|
||||
. 52200) (READLINE 52202 . 57642) (REMPROPLIST 57644 . 58532) (RESETBUFS 58534 . 58984) (TAB 58986 .
|
||||
59582) (UNSAVED1 59584 . 60689) (WRITEFILE 60691 . 62433) (CLOSE-AND-MAYBE-DELETE 62435 . 62779) (
|
||||
UNSAFE.TO.MODIFY 62781 . 63313)) (65639 68583 (FILEDATE 65649 . 68581)) (68813 92552 (FILEMAP 68823 .
|
||||
69293) (\PARSE-FILE-HEADER 69295 . 73110) (GET-ENVIRONMENT-AND-FILEMAP 73112 . 75339) (
|
||||
LOOKUP-ENVIRONMENT-AND-FILEMAP 75341 . 77532) (GET-FILEMAP-FROM-FILECREATED 77534 . 78358) (
|
||||
\FILEMAP-HASHOVERFLOW 78360 . 83024) (FLUSHFILEMAPS 83026 . 83649) (LISPSOURCEFILEP 83651 . 84830) (
|
||||
GETFILEMAP 84832 . 85251) (PUTFILEMAP 85253 . 87444) (UPDATEFILEMAP 87446 . 92550)) (93218 96804 (
|
||||
LVLPRINT 93228 . 93401) (LVLPRIN1 93403 . 93585) (LVLPRIN2 93587 . 93819) (LVLPRIN 93821 . 94835) (
|
||||
LVLPRIN0 94837 . 96802)) (96838 101755 (FLUSHRIGHT 96848 . 97663) (PRINTPARA 97665 . 98763) (
|
||||
PRINTPARA1 98765 . 101753)) (101791 104076 (SUBLIS 101801 . 102409) (SUBPAIR 102411 . 103639) (DSUBLIS
|
||||
103641 . 104074)) (104099 104699 (CONSTANTOK 104109 . 104697)) (106452 107157 (NLAMBDA.ARGS 106462 .
|
||||
107155)))))
|
||||
(FILEMAP (NIL (12928 26353 (LOAD? 12938 . 14789) (FILESLOAD 14791 . 15080) (DOFILESLOAD 15082 . 22708)
|
||||
(FINDFILE-WITH-EXTENSIONS 22710 . 25909) (READ-FILECREATED 25911 . 26351)) (26470 31791 (DMPHASH
|
||||
26480 . 28074) (HASHOVERFLOW 28076 . 31789)) (32547 63884 (BKBUFS 32557 . 33676) (CHANGENAME 33678 .
|
||||
33939) (CHNGNM 33941 . 35789) (CLBUFS 35791 . 37064) (DEFINE 37066 . 37790) (FNS.PUTDEF 37792 . 41207)
|
||||
(EQMEMB 41209 . 41391) (EQUALN 41393 . 42222) (FNCHECK 42224 . 44231) (FNTYP1 44233 . 44330) (LCSKIP
|
||||
44332 . 45176) (MAPRINT 45178 . 46124) (MKLIST 46126 . 46276) (NAMEFIELD 46278 . 47803) (NLIST 47805
|
||||
. 48140) (PRINTBELLS 48142 . 48268) (PROMPTCHAR 48270 . 50160) (RAISEP 50162 . 50423) (READFILE 50425
|
||||
. 52769) (READLINE 52771 . 58211) (REMPROPLIST 58213 . 59101) (RESETBUFS 59103 . 59553) (TAB 59555 .
|
||||
60151) (UNSAVED1 60153 . 61258) (WRITEFILE 61260 . 63002) (CLOSE-AND-MAYBE-DELETE 63004 . 63348) (
|
||||
UNSAFE.TO.MODIFY 63350 . 63882)) (66208 69152 (FILEDATE 66218 . 69150)) (69382 96484 (FILEMAP 69392 .
|
||||
69862) (\PARSE-FILE-HEADER 69864 . 73679) (GET-ENVIRONMENT-AND-FILEMAP 73681 . 75908) (
|
||||
LOOKUP-ENVIRONMENT-AND-FILEMAP 75910 . 78101) (GET-FILEMAP-FROM-FILECREATED 78103 . 78927) (
|
||||
\FILEMAP-HASHOVERFLOW 78929 . 83593) (FLUSHFILEMAPS 83595 . 84218) (LISPSOURCEFILEP 84220 . 85511) (
|
||||
LISPFILETYPE 85513 . 88762) (GETFILEMAP 88764 . 89183) (PUTFILEMAP 89185 . 91376) (UPDATEFILEMAP 91378
|
||||
. 96482)) (97150 100736 (LVLPRINT 97160 . 97333) (LVLPRIN1 97335 . 97517) (LVLPRIN2 97519 . 97751) (
|
||||
LVLPRIN 97753 . 98767) (LVLPRIN0 98769 . 100734)) (100770 105687 (FLUSHRIGHT 100780 . 101595) (
|
||||
PRINTPARA 101597 . 102695) (PRINTPARA1 102697 . 105685)) (105723 108008 (SUBLIS 105733 . 106341) (
|
||||
SUBPAIR 106343 . 107571) (DSUBLIS 107573 . 108006)) (108031 108631 (CONSTANTOK 108041 . 108629)) (
|
||||
110384 111089 (NLAMBDA.ARGS 110394 . 111087)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user