From b796727165ebc0ad910ae6398a37f55f604a5585 Mon Sep 17 00:00:00 2001 From: rmkaplan <69548581+rmkaplan@users.noreply.github.com> Date: Wed, 11 May 2022 18:40:13 -0700 Subject: [PATCH] Rmk37 prc menu shows superset relations (#764) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * PSEUDOHOSTS: GETHOSTINFO of pseudohost goes to true host * CMLPATHNAME: Remove unused PARSE-NAMESTRING1 Avoid stumbling on it in future maintenance. Also, remake filemap for functions and defmacros * SAMEDIR, COMPAREDIRECTORIES: FILENAMEFIELD → FILENAMEFIELD.STRING in a few places. No need to hash atoms * LLCHAR: expose $$READONLY in inpname I.s.opr * GITFNS: prc menu shows superset relations * GITFNS: Sort the prc menu * EDITINTERFACE: Better edit-date management * PRETTYFILEINDEX: Destination can be any imagestream, not just display * TEDIT-PF-SEE: Use SEE instead of COPYTO IMAGESTREAM to get better formatting of PRETTYFILEINDEX --- library/SAMEDIR | 63 ++-- library/SAMEDIR.LCOM | Bin 3484 -> 3496 bytes lispusers/COMPAREDIRECTORIES | 329 +++++++++--------- lispusers/COMPAREDIRECTORIES.LCOM | Bin 40150 -> 40396 bytes lispusers/GITFNS | 298 +++++++++------- lispusers/GITFNS.LCOM | Bin 31689 -> 32559 bytes lispusers/PRETTYFILEINDEX | 547 +++++++++++++++++------------- lispusers/PRETTYFILEINDEX.LCOM | Bin 41751 -> 41934 bytes lispusers/PSEUDOHOSTS | 52 ++- lispusers/PSEUDOHOSTS.LCOM | Bin 8239 -> 8521 bytes lispusers/TEDIT-PF-SEE | 38 ++- lispusers/TEDIT-PF-SEE.LCOM | Bin 3878 -> 4056 bytes sources/CMLPATHNAME | 247 ++------------ sources/CMLPATHNAME.LCOM | Bin 21996 -> 20153 bytes sources/EDITINTERFACE | 130 +++---- sources/EDITINTERFACE.LCOM | Bin 16579 -> 16456 bytes sources/LLCHAR | 90 +++-- sources/LLCHAR.LCOM | Bin 22466 -> 22467 bytes 18 files changed, 883 insertions(+), 911 deletions(-) diff --git a/library/SAMEDIR b/library/SAMEDIR index 94ed4049..a6e0d202 100644 --- a/library/SAMEDIR +++ b/library/SAMEDIR @@ -1,14 +1,15 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 1-Sep-2020 11:40:26" {DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;9 5511 - changes to%: (FNS CHECKSAMEDIR) +(FILECREATED "25-Apr-2022 09:23:16" {DSK}kaplan>Local>medley3.5>my-medley>library>SAMEDIR.;3 5583 - previous date%: "25-Aug-2020 07:42:08" -{DSK}kaplan>Local>medley3.5>lispcore>library>SAMEDIR.;6) + :CHANGES-TO (FNS HOST&DIRECTORYFIELD CHECKSAMEDIR) + + :PREVIOUS-DATE " 1-Sep-2020 11:40:26" +{DSK}kaplan>Local>medley3.5>my-medley>library>SAMEDIR.;1) (* ; " -Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1982, 1984-1987, 1990, 2018, 2020 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT SAMEDIRCOMS) @@ -24,41 +25,40 @@ Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Co (DEFINEQ (CHECKSAMEDIR - [LAMBDA (FILE) (* ; "Edited 1-Sep-2020 11:40 by rmk:") + [LAMBDA (FILE) (* ; "Edited 25-Apr-2022 09:16 by rmk") + (* ; "Edited 1-Sep-2020 11:40 by rmk:") - (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") + (* ;; "Check (a) that we are writing FILE to the same directory we last read/wrote it and (b) that a version newer than the current one has not since appeared.") - (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") + (* ;; " OKHOST/DIRS is a list of places it's OK for the file to be winding up, so if your'e migrating code from one place ot another, you can do it gracefully.") [RESETSAVE (DIRECTORYNAME T) - '(PROGN (CNDIR OLDVALUE] (* ; - "Assumes that MAKEFILE has RESETLST") + '(PROGN (CNDIR OLDVALUE] (* ; + "Assumes that MAKEFILE has RESETLST") (PROG ((*UPPER-CASE-FILE-NAMES* NIL) - (DATES (GET (SETQ FILE (MKATOM (U-CASE FILE))) + (DATES (GET (SETQ FILE (ROOTFILENAME FILE)) 'FILEDATES)) HOST/DIR HOST DIR NEWV OKHOST/DIRS) AGAIN (OR (LISTP DATES) - (RETURN)) (* ; - "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") + (RETURN)) (* ; + "RMK: Use HOST&DIRECTORYFIELD to canonicalize both file and connected directory") [SETQ OKHOST/DIRS (CONS (SETQ HOST/DIR (HOST&DIRECTORYFIELD (DIRECTORYNAME T))) (MKLIST (CDR (ASSOC HOST/DIR MIGRATIONS :TEST 'STRING-EQUAL] (COND - ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER - (HOST&DIRECTORYFIELD - (CDR OLDFILE)) - OKHOST/DIRS :TEST - 'STRING-EQUAL)) + ((for OLDFILE in DATES bind HOST DIR never (CL:MEMBER (HOST&DIRECTORYFIELD (CDR OLDFILE) + ) + OKHOST/DIRS :TEST 'STRING-EQUAL)) - (* ;; "The file is going somewhere it has never been before. ") + (* ;; "The file is going somewhere it has never been before. ") - (* ;; "Check that that is really what the user wants.") + (* ;; "Check that that is really what the user wants.") (SELECTQ (ASKUSER SAMEDIRWAIT SAMEDIRDEFAULT (LIST "You haven't loaded or written" FILE "in your connected directory" HOST/DIR "-- write it out anyway") `[[O ,(CONCAT "Oops! Make file on " (SETQ HOST/DIR ( - HOST&DIRECTORYFIELD + HOST&DIRECTORYFIELD (CDAR DATES] (C "Make file on other directory: ") (Y ,(CONCAT "Yes, write it here") @@ -76,13 +76,13 @@ Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Co ([AND [SETQ NEWV (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR DATES] (NOT (STRING-EQUAL NEWV (CDAR DATES] - (* ;; "A newer version appeared while the user was editing this file.") + (* ;; "A newer version appeared while the user was editing this file.") - (* ;; "Ask if he should over-write it.") + (* ;; "Ask if he should over-write it.") (SELECTQ (ASKUSER 15 'Y (LIST (CDAR DATES) "is not the most recent version (version" - (MKSTRING (FILENAMEFIELD NEWV 'VERSION)) + (FILENAMEFIELD.STRING NEWV 'VERSION) "has since appeared)." "Do you want to make the file anyway")) (Y) @@ -90,15 +90,16 @@ Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Co (SHOULDNT]) (HOST&DIRECTORYFIELD - [LAMBDA (FILENAME) (* ; "Edited 15-Apr-2018 19:05 by rmk:") + [LAMBDA (FILENAME) (* ; "Edited 25-Apr-2022 09:22 by rmk") + (* ; "Edited 15-Apr-2018 19:05 by rmk:") - (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") + (* ;; "Returns the host&dir fields packed together. HOST and device are upper cased") - (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD FILENAME 'DEVICE)) + (PACKFILENAME.STRING 'DEVICE (U-CASE (FILENAMEFIELD.STRING FILENAME 'DEVICE)) 'HOST - (U-CASE (FILENAMEFIELD FILENAME 'HOST)) + (U-CASE (FILENAMEFIELD.STRING FILENAME 'HOST)) 'DIRECTORY - (FILENAMEFIELD FILENAME 'DIRECTORY]) + (FILENAMEFIELD.STRING FILENAME 'DIRECTORY]) ) (RPAQ? SAMEDIRWAIT 10) @@ -106,7 +107,7 @@ Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Co (RPAQ? SAMEDIRDEFAULT 'O) (ADDTOVAR MAKEFILEFORMS (OR (NLSETQ (CHECKSAMEDIR FILE)) - (RETFROM 'MAKEFILE))) + (RETFROM 'MAKEFILE))) (ADDTOVAR MIGRATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -115,5 +116,5 @@ Copyright (c) 1982, 1984, 1985, 1986, 1987, 1990, 2018, 2020 by Venue & Xerox Co ) (PUTPROPS SAMEDIR COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1990 2018 2020)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (817 5124 (CHECKSAMEDIR 827 . 4681) (HOST&DIRECTORYFIELD 4683 . 5122))))) + (FILEMAP (NIL (802 5200 (CHECKSAMEDIR 812 . 4623) (HOST&DIRECTORYFIELD 4625 . 5198))))) STOP diff --git a/library/SAMEDIR.LCOM b/library/SAMEDIR.LCOM index d91baba9939c301cd1f73838cf59738c07e0269b..164bd499ba50682e9d2d6102a30730e41ff06924 100644 GIT binary patch delta 1411 zcmah}OK;mo5RRNUuo>kLAblXOj#wlmi%{V1lA_2KZW(eVG3G-iDHkeop<|{|Yg-Pj zG}X!H-V*TALxEm%D~jBD>A8QPf1%g(+C$NyEGcdfq&zH#%bjn&`DSK+y!!m=)2<;1 zQpfYT6LUM|E{IfD?88E#Dy5*B7G)MOM3BV$cYmtv=ev9P zbYpL{Q)I<-Be4VSdU5j;CL3Ppit_&_P-eAT+S|y2pzCc0meaGtE>Dy+0;v-wGg{Z29(Ok9iOFE~ zW4`T0gG6yru+p!+Uz>?><1P3^7D}@64j$~TJQD?pw!sRcIIw*rFAJvwfaSJ@7k{tZ ztJVH2zc_dO#q?ZRD=(dgSo_!5w5pTXd%Kr&K2k)|Bc? z)>Ku&i9*LtfmDujQ`eWKX3hZ4;#So~$GQsGf!s->cv$5MRD(E*(gkZEuN}Y|Xe}K= z&@hi7>O^6i$B7r=j@rf@W~gu{a?xmM%U_I9NIc65{e-7mN%H_a*dV0u3cFnt@4kxk5>g?8Yx%T8<&X*QW$Zk7j^tDq%u%dFRk?( z*NLfv7>;j4wlgj!5ZIg8CO#JhAZ=EixJED&ahM<7h9|{nlEY{M5Az}yku@uSUY9H) zfEbMrj~W0$_Dv2C@WME`F9?=YRFqea9>-uStG@R5XxK>23&;6JnJi^4)FQA8=X55ql)Oha>jAa2zZ;QzI}?oLNO$ zZ*G37E>4gW9bX?0#QprjMx&Zj49(MY=tKebF%H`NPQY&zzWnLJ1B`yYejnGb>$h-y dR(}`Q=XJpK_xb?W4=z@hfPQgjRR}#__!sf1YW)BJ delta 1336 zcma)6&yU+g6yBswo9wPZf&wKA%Uc(yQ<2D?8UKhYElh1^*NS6rZKqYGUXpCs2BmdK zb}NT}MKPId5={h2>?QX{gJFLkk_Q+hJpSs+$#5_k^^$Ra zdpPKhJLBW+h_@Wu4Qtoy6^yA@`Dl!VWGrNuvSLyqLU-I>R1*4MjK-4>Ot5wxt9hCX z1FYZb?+^ROKx-;Aj)p^sjwi{{ArMyOM+Y-(wVG2CVZU>Tki@eNBAY5P85Jx4iy0F6 z>_3QrpsI=jy?dPp2mJ{gCJ0w*_|X#P3XI16hlAv3G6jSoB2iyLm35O5Q#NL8qyK)I zRuRs&f@A9ln6@FLVg9iwNW=is55gArklS+XH0)X7+}+&fi&qOPxnu=@gHpEME0=F? zmV29@OuwFedHzW*S4v;G@P7C1LFRw{q?rBv^7LC@aB*NLjlF%l{-FcMh>EATBI zqY5$a)YRmKsj@6TugU4>7vH?E0xH{Egm_b$jd=E4W_H$ z1JfAX0Y-GV<%E$N;EqCZhobjJV56bc7cNTm^!df|iNYWNij%g0=*W25&Z={>%{|

SLG+W4pwmsp zhtT3poVn+S0yf#ei1+fkk$zjcoHNoNN>W}E(%(vN=c%0jS=z`GmKImH&~}?NeM| zTkqleaQ(x}f)wuYn;*mJV{@CkC<__Ge_qd^{ITACOOUv2$H6Tgp6MJ$aG_feeAg5H E0V^L+Z2$lO diff --git a/lispusers/COMPAREDIRECTORIES b/lispusers/COMPAREDIRECTORIES index 5a2e2446..4c1cc920 100644 --- a/lispusers/COMPAREDIRECTORIES +++ b/lispusers/COMPAREDIRECTORIES @@ -1,12 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Mar-2022 11:53:34"  -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;215 123553 +(FILECREATED "25-Apr-2022 09:25:02"  +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;217 123829 - :CHANGES-TO (FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS) + :CHANGES-TO (FNS CDBROWSER-COPY COMPAREDIRECTORIES.INFOS.TYPE CDFILES FIND-UNSOURCED-FILES + FIND-SOURCE-FILES FIND-COMPILED-FILES FIND-UNLOADED-FILES FIND-LOADED-FILES + FIND-MULTICOMPILED-FILES SOURCE-FOR-COMPILED-P CDBROWSER-DELETE-FILE) - :PREVIOUS-DATE " 6-Mar-2022 19:53:40" -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;214) + :PREVIOUS-DATE "29-Mar-2022 11:53:34" +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;215) (* ; " @@ -319,18 +321,18 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp CDE]) (COMPAREDIRECTORIES.INFOS.TYPE - [LAMBDA (FULLNAME LDATE) (* ; "Edited 4-Jan-2022 13:10 by rmk") + [LAMBDA (FULLNAME LDATE) (* ; "Edited 25-Apr-2022 09:02 by rmk") + (* ; "Edited 4-Jan-2022 13:10 by rmk") (* ; "Edited 12-Dec-2021 22:50 by rmk") - (IF LDATE - THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION) - *COMPILED-EXTENSIONS*) - 'COMPILED - 'SOURCE) - ELSEIF (PRINTFILETYPE FULLNAME) - ELSE (SELECTQ (U-CASE (FILENAMEFIELD FULLNAME 'EXTENSION)) - ((TXT TEXT SH MD C) - 'TEXT) - 'OTHER]) + (LET [(EXT (FILENAMEFIELD FULLNAME 'EXTENSION] + (IF LDATE + THEN (CL:IF (MEMB EXT *COMPILED-EXTENSIONS*) + 'COMPILED + 'SOURCE) + ELSEIF (PRINTFILETYPE FULLNAME) + ELSE (CL:IF (MEMB EXT '(TXT TEXT SH MD C)) + 'TEXT + 'OTHER)]) (MATCHNAME [LAMBDA (NAME STARTPOS) (* ; "Edited 24-Feb-2022 09:10 by rmk") @@ -383,7 +385,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (DEFINEQ (CDFILES - [LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 5-Mar-2022 15:05 by rmk") + [LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 25-Apr-2022 08:42 by rmk") + (* ; "Edited 5-Mar-2022 15:05 by rmk") (* ; "Edited 16-Oct-2020 13:42 by rmk:") (* ;; "Returns a list of fullnames for files that satisfy the criteria. We generate all candidates that match INCLUDEDFILES but not EXCLUDEDFILES in DIR.") @@ -411,8 +414,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (LET ([INCLUDES (CDFILES.PATS (OR INCLUDEDFILES '*.*] (EXCLUDES (AND EXCLUDEDFILES (CDFILES.PATS EXCLUDEDFILES))) HOST ENUMPAT) - (SETQ HOST (FILENAMEFIELD DIR 'HOST)) - (SETQ DIR (FILENAMEFIELD DIR 'DIRECTORY)) + (SETQ HOST (FILENAMEFIELD.STRING DIR 'HOST)) + (SETQ DIR (FILENAMEFIELD.STRING DIR 'DIRECTORY)) (CL:UNLESS DEPTH (* ;; "DEPTH is the number of internal > or /") @@ -436,7 +439,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (* ;;  "If We don't prefix TOPDIR with <, then if TOPDIR contains a colon it is interpreted as a device.") - (SETQ ENUMPAT (PACKFILENAME 'HOST HOST 'DIRECTORY + (SETQ ENUMPAT (PACKFILENAME.STRING 'HOST HOST 'DIRECTORY (CONCAT "<" DIR ">" (OR SD "")) 'NAME N 'EXTENSION E 'VERSION (CL:IF ALLVERSIONS @@ -1141,154 +1144,144 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp CF SCREATION]) (FIND-UNSOURCED-FILES - [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 15-Sep-2020 15:32 by rmk:") - (* ; "Edited 3-Nov-94 15:17 by jds") + [LAMBDA (FILES DFASLMARGIN COMPILEEXTS) (* ; "Edited 25-Apr-2022 08:43 by rmk") + (* ; "Edited 15-Sep-2020 15:32 by rmk:") + (* ; "Edited 3-Nov-94 15:17 by jds") - (* ;; - "Produces a list of compiled FILES for which no source file can be found in the same directory.") + (* ;; + "Produces a list of compiled FILES for which no source file can be found in the same directory.") - (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") + (* ;; "The source date in at least one DFASL was off by a second, maybe some sort of IDATE rounding? So, give a margin.") - (* ;; -"We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") + (* ;; + "We want the most recent version only. Check CREATED-AS to make sure it really is a compiled file.") - (* ;; "Sort to get lcoms and dfasls next to each other.") + (* ;; "Sort to get lcoms and dfasls next to each other.") (LET (CCREATEDS) - (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS - *COMPILED-EXTENSIONS*) + (SETQ CCREATEDS (FOR CEXT FOUND CCREATED INSIDE (OR COMPILEEXTS *COMPILED-EXTENSIONS*) JOIN (FOR CF IN [OR (LISTP FILES) - (FILDIR (PACKFILENAME 'EXTENSION CEXT - 'VERSION "" 'BODY - '*] - WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) - UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) + (FILDIR (PACKFILENAME.STRING 'EXTENSION CEXT + 'VERSION "" 'BODY '*] + WHEN (CDDR (SETQ CCREATED (CREATED-AS CF))) + UNLESS (MEMBER CCREATED $$VAL) COLLECT CCREATED))) - (* ;; "CCREATEDS is now a list of CREATED-AS items") + (* ;; "CCREATEDS is now a list of CREATED-AS items") - (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME 'EXTENSION - NIL 'VERSION NIL - 'BODY - (CAR CC] - (SOURCE-FOR-COMPILED-P (SETQ SF - (CREATED-AS - SF)) - CC DFASLMARGIN)) + (FOR CC SF IN CCREATEDS UNLESS (AND [SETQ SF (INFILEP (PACKFILENAME.STRING 'EXTENSION NIL + 'VERSION NIL 'BODY (CAR CC] + (SOURCE-FOR-COMPILED-P (SETQ SF (CREATED-AS SF)) + CC DFASLMARGIN)) COLLECT [LIST (CAR CC) - (AND SF (LIST (CAR SF) - (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] + (AND SF (LIST (CAR SF) + (ROUND (COMPILE-SOURCE-DATE-DIFF CC SF] FINALLY (RETURN (SORT $$VAL (FUNCTION (LAMBDA (CF1 CF2) - (ALPHORDER (FILENAMEFIELD (CAR CF1) - 'NAME) - (FILENAMEFIELD (CAR CF2) - 'NAME]) + (ALPHORDER (FILENAMEFIELD.STRING (CAR CF1) + 'NAME) + (FILENAMEFIELD.STRING (CAR CF2) + 'NAME]) (FIND-SOURCE-FILES - [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") + [LAMBDA (CFILES SDIRS DFASLMARGIN) (* ; "Edited 25-Apr-2022 08:43 by rmk") + (* ; "Edited 9-Sep-2020 12:26 by rmk:") - (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") + (* ;; "Returns (CFILE . SFILES) pairs where CFILE is a Lisp compiled file in CFILES SFILES is a list of source files in SDIRS that CFILE was compiled on.") - (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") + (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ SDIRS (FOR SD INSIDE (OR SDIRS T) COLLECT (DIRECTORYNAME SD))) (SORT (FOR CF SFILES CNAME CCREATED IN (OR (LISTP CFILES) - (FILDIR CFILES)) + (FILDIR CFILES)) WHEN (AND (SETQ CNAME (INFILEP CF)) - (CDDR (SETQ CCREATED (CREATED-AS CF))) - (SETQ SFILES (FOR SD SF IN SDIRS - WHEN (AND (SETQ SF (INFILEP (PACKFILENAME - 'NAME - (FILENAMEFIELD - CF - 'NAME) - 'BODY SD))) - (SOURCE-FOR-COMPILED-P SF CCREATED - DFASLMARGIN)) COLLECT SF))) - COLLECT (CONS CNAME SFILES)) + (CDDR (SETQ CCREATED (CREATED-AS CF))) + (SETQ SFILES (FOR SD SF IN SDIRS + WHEN (AND (SETQ SF (INFILEP (PACKFILENAME.STRING + 'NAME + (FILENAMEFIELD.STRING + CF + 'NAME) + 'BODY SD))) + (SOURCE-FOR-COMPILED-P SF CCREATED DFASLMARGIN)) + COLLECT SF))) COLLECT (CONS CNAME SFILES)) (FUNCTION (LAMBDA (P1 P2) - (ALPHORDER (FILENAMEFIELD (CAR P1)) - (FILENAMEFIELD (CAR P2]) + (ALPHORDER (FILENAMEFIELD.STRING (CAR P1)) + (FILENAMEFIELD.STRING (CAR P2]) (FIND-COMPILED-FILES - [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 9-Sep-2020 12:26 by rmk:") + [LAMBDA (SFILES CDIRS DFASLMARGIN) (* ; "Edited 25-Apr-2022 08:44 by rmk") + (* ; "Edited 9-Sep-2020 12:26 by rmk:") - (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") + (* ;; "Returns (SFILE . CFILES) pairs where SFILE is a Lisp source file in SFILES CFILES is a list of compiled files in CDIRS that were compiled on SFILE.") - (* ;; "FILEDATE is true for source files and compiled files") + (* ;; "FILEDATE is true for source files and compiled files") - (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") + (* ;; "This suggests that one of CFILES should be copied to the SFILE directory.") (SETQ CDIRS (FOR CD INSIDE (OR CDIRS T) COLLECT (DIRECTORYNAME CD))) (SORT (FOR SF CFILES SNAME SCREATED IN (OR (LISTP SFILES) - (FILDIR SFILES)) + (FILDIR SFILES)) WHEN [AND (SETQ SNAME (INFILEP SF)) - (SETQ SCREATED (CREATED-AS SF)) - (NOT (CDDR SCREATED)) - (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD SNAME 'NAME)) - IN *COMPILED-EXTENSIONS* - JOIN (FOR CD CF IN CDIRS - WHEN (AND (SETQ CF - (INFILEP (PACKFILENAME - 'NAME ROOT - 'EXTENSION CEXT - 'BODY CD))) - (SOURCE-FOR-COMPILED-P - SCREATED CF DFASLMARGIN)) - COLLECT CF] COLLECT (CONS SNAME CFILES - )) + (SETQ SCREATED (CREATED-AS SF)) + (NOT (CDDR SCREATED)) + (SETQ CFILES (FOR CEXT (ROOT _ (FILENAMEFIELD.STRING SNAME 'NAME)) + IN *COMPILED-EXTENSIONS* + JOIN (FOR CD CF IN CDIRS + WHEN (AND (SETQ CF (INFILEP (PACKFILENAME.STRING + 'NAME ROOT 'EXTENSION + CEXT 'BODY CD))) + (SOURCE-FOR-COMPILED-P SCREATED CF + DFASLMARGIN)) COLLECT CF] + COLLECT (CONS SNAME CFILES)) (FUNCTION (LAMBDA (P1 P2) - (ALPHORDER (FILENAMEFIELD (CAR P1)) - (FILENAMEFIELD (CAR P2]) + (ALPHORDER (FILENAMEFIELD.STRING (CAR P1)) + (FILENAMEFIELD.STRING (CAR P2]) (FIND-UNLOADED-FILES - [LAMBDA (FILES) (* ; "Edited 9-Sep-2020 19:35 by rmk:") + [LAMBDA (FILES) (* ; "Edited 25-Apr-2022 08:49 by rmk") + (* ; "Edited 9-Sep-2020 19:35 by rmk:") - (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") + (* ;; "Returns the files in FILES that don't have FILECREATED properties and presumably are therefore not loaded in the current sysout.") (FOR F IN (OR (LISTP FILES) - (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) - (CAR F) - F))) - (FILEDATE F)) - UNLESS (GETP (FILENAMEFIELD F 'NAME) - 'FILEDATES) COLLECT F]) + (FILDIR FILES)) WHEN (AND (SETQ F (INFILEP (CL:IF (LISTP F) + (CAR F) + F))) + (FILEDATE F)) UNLESS (GETP (FILENAMEFIELD F 'NAME) + 'FILEDATES) COLLECT F]) (FIND-LOADED-FILES - [LAMBDA (ROOTFILENAMES) (* ; "Edited 19-Sep-2020 07:20 by rmk:") + [LAMBDA (ROOTFILENAMES) (* ; "Edited 25-Apr-2022 09:04 by rmk") + (* ; "Edited 19-Sep-2020 07:20 by rmk:") (FOR RN INSIDE ROOTFILENAMES WHEN (GETP RN 'FILEDATES) - COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD - F - 'NAME)) COLLECT - F]) + COLLECT (CONS RN (FOR F IN LOADEDFILELST WHEN (EQ RN (FILENAMEFIELD F 'NAME)) COLLECT F]) (FIND-MULTICOMPILED-FILES - [LAMBDA (FILES SHOWINFO) (* ; "Edited 20-Sep-2020 20:57 by rmk:") + [LAMBDA (FILES SHOWINFO) (* ; "Edited 25-Apr-2022 09:07 by rmk") + (* ; "Edited 20-Sep-2020 20:57 by rmk:") - (* ;; "Returns a list of names for files in FILES that have multiple compilations") + (* ;; "Returns a list of names for files in FILES that have multiple compilations") (LET (SFILES) (FOR F EXT NAME IN (OR (LISTP FILES) - (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD - F - 'EXTENSION)) - *COMPILED-EXTENSIONS*) + (FILDIR FILES)) WHEN (MEMB (SETQ EXT (FILENAMEFIELD F 'EXTENSION)) + *COMPILED-EXTENSIONS*) DO (SETQ NAME (FILENAMEFIELD F 'NAME)) - (* ;; "PUSHNEW because we haven't filtered out versions") + (* ;; "PUSHNEW because we haven't filtered out versions") - (PUSHNEW [CDR (OR (ASSOC NAME SFILES) - (CAR (PUSH SFILES (CONS NAME] - EXT)) + (PUSHNEW [CDR (OR (ASSOC NAME SFILES) + (CAR (PUSH SFILES (CONS NAME] + EXT)) (FOR S IN SFILES WHEN (CDDR S) COLLECT (IF SHOWINFO - THEN `[,(CAR S) - ,(CADAR (FIND-LOADED-FILES (CAR S))) - ,(CREATED-AS (CAR S)) - ,@(FOR EXT IN (SORT (CDR S)) - COLLECT (CREATED-AS (PACKFILENAME 'EXTENSION EXT - 'BODY - (CAR S] - ELSE (CAR S]) + THEN `[,(CAR S) + ,(CADAR (FIND-LOADED-FILES (CAR S))) + ,(CREATED-AS (CAR S)) + ,@(FOR EXT IN (SORT (CDR S)) COLLECT (CREATED-AS (PACKFILENAME.STRING + 'EXTENSION EXT + 'BODY + (CAR S] + ELSE (CAR S]) ) (DEFINEQ @@ -1383,21 +1376,22 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (LIST SOURCENAME (GDATE (IDATE SOURCEDATE))))]) (SOURCE-FOR-COMPILED-P - [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 31-Oct-2020 09:12 by rmk:") + [LAMBDA (SOURCE COMPILED DFASLMARGIN) (* ; "Edited 25-Apr-2022 08:46 by rmk") + (* ; "Edited 31-Oct-2020 09:12 by rmk:") - (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") + (* ;; "There seems to be some variation between the source dates in dfasl files and the filecreated date in the sources, they often don't match exactly. But if they are within DFASLMARGIN, we assume a match. We require exact date match for LCOMS") - (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") + (* ;; "This is needed for dfasl files created before they recorded the source filecreated name and date instead of the directory source name and date when compile took place.") - (* ;; "") + (* ;; "") - (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") + (* ;; "DFASLMARGIN is a pair (after before) where we assume a match if the compiled date is no more than after minutes after the source date and no more than before minuts before (the diff is negative then).") - (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") + (* ;; "A single positive integer x is interpreted as (x 0). A single negative integer x is interpreted as (-x x) (before or after x).") - (* ;; "Default is (20 0).") + (* ;; "Default is (20 0).") - (* ;; "T is positive or negative infinity") + (* ;; "T is positive or negative infinity") (CL:UNLESS (LISTP SOURCE) (SETQ SOURCE (CREATED-AS SOURCE))) @@ -1405,11 +1399,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (SETQ COMPILED (CREATED-AS COMPILED))) (SETQ DFASLMARGIN (IF (NULL DFASLMARGIN) THEN + (* ;; + "If compiled is later than source by less than 20 minutes, it's probably OK") - (* ;; - "If compiled is later than source by less than 20 minutes, it's probably OK") - - '(20 0) + '(20 0) ELSEIF (EQ T DFASLMARGIN) THEN '(T 0) ELSEIF (LISTP DFASLMARGIN) @@ -1417,17 +1410,17 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp THEN (ERROR "ILLEGAL DFASLMARGIN" DFASLMARGIN) ELSEIF (MINUSP DFASLMARGIN) THEN (LIST (MINUS DFASLMARGIN) - DFASLMARGIN) + DFASLMARGIN) ELSE (LIST DFASLMARGIN 0))) (OR (EQUAL (CAR SOURCE) (CADDR COMPILED)) (EQUAL (CADR SOURCE) (CADDDR COMPILED)) - (AND [EQ 'DFASL (U-CASE (FILENAMEFIELD (CAR COMPILED) - 'EXTENSION] + (AND [STREQUAL 'DFASL (U-CASE (FILENAMEFIELD.STRING (CAR COMPILED) + 'EXTENSION] (LET ((TIMEDIFF (COMPILE-SOURCE-DATE-DIFF COMPILED SOURCE))) - (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") + (* ;; "If compiled was no more than 20 minutes later, it's probably OK. Of no more than DFASLMARGIN earlier, if it is negative.") (AND (OR (EQ T (CAR DFASLMARGIN)) (LEQ TIMEDIFF (CAR DFASLMARGIN))) @@ -1972,7 +1965,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (MOVEWITH CHILDREN WINDOW]) (CDBROWSER-COPY - [LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 5-Feb-2022 17:27 by rmk") + [LAMBDA (CDBROWSER TBITEM SOURCE) (* ; "Edited 25-Apr-2022 09:24 by rmk") + (* ; "Edited 5-Feb-2022 17:27 by rmk") (* ; "Edited 2-Feb-2022 22:18 by rmk") (* ;; "Copies the file identified as SOURCE (LEFT or RIGHT) in CDENTRY to the other file of the end. If the destination file is missing, it is assumed to be a new/unversioned file of the same name as the source but with the directory prefix switched. CDVALUE needed to know what directory prefixes are involved.") @@ -2008,8 +2002,9 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp "Target is newer than source. Really copy? "] (RETURN NIL)) (CL:WHEN [AND (SETQ SOURCEVER (FILENAMEFIELD SOURCE 'VERSION)) - (ILESSP SOURCEVER (FILENAMEFIELD (INFILEP (PACKFILENAME 'VERFSION NIL - 'BODY SOURCEFILE)) + (ILESSP SOURCEVER (FILENAMEFIELD (INFILEP (PACKFILENAME.STRING + 'VERSION NIL 'BODY SOURCEFILE + )) 'VERSION)) (PROGN (FLASHWINDOW T) (EQ 'N (ASKUSER NIL NIL (CONCAT SOURCEFILE @@ -2019,7 +2014,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (CLEARW T) (CL:UNLESS DESTFILE (SETQ DESTFILE (CD-SWAPDIRS SOURCEFILE SOURCEDIR DESTDIR))) - (SETQ RESULT (COPYFILE SOURCEFILE (PACKFILENAME 'VERSION NIL 'BODY DESTFILE))) + (SETQ RESULT (COPYFILE SOURCEFILE (PACKFILENAME.STRING 'VERSION NIL 'BODY DESTFILE))) (PRIN3 (IF RESULT THEN (TB.DELETE.ITEM CDBROWSER TBITEM) (CONCAT "Copied to " RESULT) @@ -2029,7 +2024,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (RETURN RESULT)))]) (CDBROWSER-DELETE-FILE - [LAMBDA (CDBROWSER TBITEM SIDE ONLYONE SAVE) (* ; "Edited 5-Feb-2022 17:46 by rmk") + [LAMBDA (CDBROWSER TBITEM SIDE ONLYONE SAVE) (* ; "Edited 25-Apr-2022 09:06 by rmk") + (* ; "Edited 5-Feb-2022 17:46 by rmk") (* ; "Edited 18-Jan-2022 23:02 by rmk") (* ; "Edited 19-Dec-2021 23:33 by rmk") @@ -2049,10 +2045,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (CL:WHEN (EQ SIDE 'RIGHT) (SWAP FILE OTHERFILE)) (CL:WHEN FILE - (FOR F INSIDE (IF (FILENAMEFIELD FILE 'VERSION) + (FOR F INSIDE (IF (FILENAMEFIELD.STRING FILE 'VERSION) THEN [IF ONLYONE THEN FILE - ELSE (DREVERSE (FILDIR (PACKFILENAME 'VERSION '* + ELSE (DREVERSE (FILDIR (PACKFILENAME.STRING 'VERSION "*" 'BODY FILE] ELSE FILE) COLLECT @@ -2060,11 +2056,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (* ;; "Delete the earlier ones first, if it goes bad, you don't want them to persist. This preserves the original version numbers, maybe it should start fresh from 1 (or from whatever might have been deleted before).") (IF SAVE - THEN (CL:UNLESS (RENAMEFILE F (PACKFILENAME 'DIRECTORY - (CONCAT "deleted>" - (FILENAMEFIELD F + THEN (CL:UNLESS (RENAMEFILE F (PACKFILENAME.STRING + 'DIRECTORY + (CONCAT "deleted>" (FILENAMEFIELD.STRING + F 'DIRECTORY)) - 'BODY F)) + 'BODY F)) (ERROR "Could not delete " F)) ELSE (DELFILE FILE)) F FINALLY @@ -2099,24 +2096,24 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp (PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998 2018 2020 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2633 21889 (COMPAREDIRECTORIES 2643 . 7476) (COMPAREDIRECTORIES.INFOS 7478 . 10329) ( -COMPAREDIRECTORIES.CANDIDATES 10331 . 13716) (CDENTRIES.SELECT 13718 . 18493) ( -COMPAREDIRECTORIES.INFOS.TYPE 18495 . 19123) (MATCHNAME 19125 . 19805) (CD.INSURECDVALUE 19807 . 21421 -) (CD.UPDATEWIDTHS 21423 . 21887)) (21890 31429 (CDFILES 21900 . 27523) (CDFILES.MATCH 27525 . 29150) -(CDFILES.PATS 29152 . 31427)) (31430 46515 (CDPRINT 31440 . 33785) (CDPRINT.HEADER 33787 . 34684) ( -CDPRINT.LINE 34686 . 37242) (CDPRINT.MAXWIDTHS 37244 . 41359) (CDPRINT.COLHEADERS 41361 . 41999) ( -CDPRINT.COLUMNS 42001 . 45880) (CDTEDIT 45882 . 46513)) (46516 54885 (CDMAP 46526 . 47958) (CDENTRY -47960 . 48269) (CDSUBSET 48271 . 49710) (CDMERGE 49712 . 53566) (CDMERGE.COMMON 53568 . 54883)) (54886 - 62424 (BINCOMP 54896 . 59185) (EOLTYPE 59187 . 61749) (EOLTYPE.SHOW 61751 . 62422)) (62952 76159 ( -FIND-UNCOMPILED-FILES 62962 . 66605) (FIND-UNSOURCED-FILES 66607 . 69416) (FIND-SOURCE-FILES 69418 . -71122) (FIND-COMPILED-FILES 71124 . 73202) (FIND-UNLOADED-FILES 73204 . 73948) (FIND-LOADED-FILES -73950 . 74504) (FIND-MULTICOMPILED-FILES 74506 . 76157)) (76160 84362 (CREATED-AS 76170 . 80967) ( -SOURCE-FOR-COMPILED-P 80969 . 83667) (COMPILE-SOURCE-DATE-DIFF 83669 . 84360)) (84363 94669 ( -FIX-DIRECTORY-DATES 84373 . 87366) (FIX-EQUIV-DATES 87368 . 88893) (COPY-COMPARED-FILES 88895 . 90716) - (COPY-MISSING-FILES 90718 . 92875) (COMPILED-ON-SAME-SOURCE 92877 . 94667)) (94863 102209 (CDBROWSER -94873 . 98800) (CDBROWSER.STRINGS 98802 . 102207)) (102371 104107 (CD.TABLEITEM 102381 . 102601) ( -CD.TABLEITEM.PRINTFN 102603 . 102802) (CD.TABLEITEM.COPYFN 102804 . 103862) ( -CDTABLEBROWSER.HEADING.REPAINTFN 103864 . 104105)) (104108 122969 (CDTABLEBROWSER.WHENSELECTEDFN -104118 . 104586) (CD.COMMANDSELECTEDFN 104588 . 109689) (CD-MENUFN 109691 . 116054) (CDBROWSER-COPY -116056 . 119427) (CDBROWSER-DELETE-FILE 119429 . 122448) (CD-SWAPDIRS 122450 . 122967))))) + (FILEMAP (NIL (2856 22205 (COMPAREDIRECTORIES 2866 . 7699) (COMPAREDIRECTORIES.INFOS 7701 . 10552) ( +COMPAREDIRECTORIES.CANDIDATES 10554 . 13939) (CDENTRIES.SELECT 13941 . 18716) ( +COMPAREDIRECTORIES.INFOS.TYPE 18718 . 19439) (MATCHNAME 19441 . 20121) (CD.INSURECDVALUE 20123 . 21737 +) (CD.UPDATEWIDTHS 21739 . 22203)) (22206 31875 (CDFILES 22216 . 27969) (CDFILES.MATCH 27971 . 29596) +(CDFILES.PATS 29598 . 31873)) (31876 46961 (CDPRINT 31886 . 34231) (CDPRINT.HEADER 34233 . 35130) ( +CDPRINT.LINE 35132 . 37688) (CDPRINT.MAXWIDTHS 37690 . 41805) (CDPRINT.COLHEADERS 41807 . 42445) ( +CDPRINT.COLUMNS 42447 . 46326) (CDTEDIT 46328 . 46959)) (46962 55331 (CDMAP 46972 . 48404) (CDENTRY +48406 . 48715) (CDSUBSET 48717 . 50156) (CDMERGE 50158 . 54012) (CDMERGE.COMMON 54014 . 55329)) (55332 + 62870 (BINCOMP 55342 . 59631) (EOLTYPE 59633 . 62195) (EOLTYPE.SHOW 62197 . 62868)) (63398 75925 ( +FIND-UNCOMPILED-FILES 63408 . 67051) (FIND-UNSOURCED-FILES 67053 . 69437) (FIND-SOURCE-FILES 69439 . +71177) (FIND-COMPILED-FILES 71179 . 73056) (FIND-UNLOADED-FILES 73058 . 73911) (FIND-LOADED-FILES +73913 . 74341) (FIND-MULTICOMPILED-FILES 74343 . 75923)) (75926 84255 (CREATED-AS 75936 . 80733) ( +SOURCE-FOR-COMPILED-P 80735 . 83560) (COMPILE-SOURCE-DATE-DIFF 83562 . 84253)) (84256 94562 ( +FIX-DIRECTORY-DATES 84266 . 87259) (FIX-EQUIV-DATES 87261 . 88786) (COPY-COMPARED-FILES 88788 . 90609) + (COPY-MISSING-FILES 90611 . 92768) (COMPILED-ON-SAME-SOURCE 92770 . 94560)) (94756 102102 (CDBROWSER +94766 . 98693) (CDBROWSER.STRINGS 98695 . 102100)) (102264 104000 (CD.TABLEITEM 102274 . 102494) ( +CD.TABLEITEM.PRINTFN 102496 . 102695) (CD.TABLEITEM.COPYFN 102697 . 103755) ( +CDTABLEBROWSER.HEADING.REPAINTFN 103757 . 103998)) (104001 123245 (CDTABLEBROWSER.WHENSELECTEDFN +104011 . 104479) (CD.COMMANDSELECTEDFN 104481 . 109582) (CD-MENUFN 109584 . 115947) (CDBROWSER-COPY +115949 . 119509) (CDBROWSER-DELETE-FILE 119511 . 122724) (CD-SWAPDIRS 122726 . 123243))))) STOP diff --git a/lispusers/COMPAREDIRECTORIES.LCOM b/lispusers/COMPAREDIRECTORIES.LCOM index 990c0e425159c3742579537a14af430c8ec00354..82e57c687cac3f8517b6f9764a23747a190f4fe4 100644 GIT binary patch delta 1086 zcmah{J8#oa6poEVX@)9Q)lh?I50MZF$idgH<0cDn?dv2cu^m64l^B4gswyb03PLQX zEKI1h=~X*|7+7E4l!(H$#p$W}xrNyq(>0jByRdlc zR1P$K+_5gX*x@zHo`l((kTCpm8TPkGr_%|jUA;}qy0y+GQqiPQDr3#TD(7LHW_1Ba z&a-w(0VGOeVis~*Q8f$Lc6Um@bu6`z>zKj>ESnpLrBfevzj z8=G$FxMk8RkOfG3G`m^i7NMepmTLU&AMWW%yB-~0ARKpMq-{f1IXJlOZxlFbG)zLM zd(y*-#fDwKSozRCW`7;-OvrSvJyP9dpp%0rF$eZ<2gt6UCj;)||25lkNA`ex_lG+` z8oU0FL*e7w zs;`#m1A)(Ls*3@k?i-SoS~5fgc5Y4&=R3A`MK2z~AxB?|Wg4d4S*ryn0(?p6th@GfZMG%@OR6uD9_ufG& zGz$_ZI3QHf3lbKG0yl1`2LuvFME?Ou`~cQXXyd>hc2{rS?7TO#TkpAVo7|)616syv zE@vcBk^o~}k#$*FyLk;OX%M7=n3&fUMbAkB57(F5b9Zhp&fjXcVD3h9q0_#5S_k^^ z@p&@8079u=t-@exHk%co)x5{({Qut6gfyQjRjS0S5yK}%`i|?21D0e(kwG`hhCM~R zjPF3IWP5yA=-in!=x&WPDo)+Y6j>4opbi+(LL)hme&$@13r>w3*-s0JBoZmAA3YRX zjG-83yn#X|#uguLE`5+lu1pOeqaobdVf+jx{$9rWm)HGsy?;L0A;x=qETyPW&zOcs zK*11Nvki-sDx_KjIS+2FV*4TLUv>##4J=|^1T3#asjMql)WGq}qy|`&!6(x`XeyYH z&x2Kjya-+yCUGyIO5n42P6b9IwpVd%kTG~py=D@S6fhmjWkp%u9)s0L^OoV8Wu`DF zj~(2X1xXYc*ES8GRn?-JK%0yL!Ske?OR%pq1pl%ej!wA+y6S$9gE|zwe`ynq0nSNL zoNhD<^o95A--N6FN$vz-RfSnQ)W$w5a}?=pu+i8a3A!_%M$tOG(wd#H3mh^yjzhoS zng-gN_0D8_gQY)O7Z9e~&iFBmcV~u&-O!nK>ac{NSTejSYsx^2gQx8;DY~?Z>8sV3 ws1(=_zarG3!rInxCRg5Vq>_)SrOB?A05-FT2fEZPj!eQ?8gv^$oPOZ{02Pz--T(jq diff --git a/lispusers/GITFNS b/lispusers/GITFNS index 89e1eba7..359938f0 100644 --- a/lispusers/GITFNS +++ b/lispusers/GITFNS @@ -1,11 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Mar-2022 13:59:00" {DSK}kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;132 74961 +(FILECREATED "29-Apr-2022 11:37:08" {DSK}kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;147 76981 - :CHANGES-TO (FNS GIT-COMPARE-WITH-MYMEDLEY) + :CHANGES-TO (FNS GIT-PRC-MENU) - :PREVIOUS-DATE "10-Mar-2022 20:26:42" -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;131) + :PREVIOUS-DATE "29-Apr-2022 11:14:35" +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>GITFNS.;146) (PRETTYCOMPRINT GITFNSCOMS) @@ -71,7 +71,7 @@ (* ;; "Branches") (FNS GIT-CHECKOUT GIT-WHICH-BRANCH GIT-MAKE-BRANCH GIT-BRANCHES GIT-BRANCH-EXISTS? - PICK-BRANCH GIT-PULL-REQUESTS) + GIT-PICK-BRANCH GIT-PRC-MENU GIT-PULL-REQUESTS GIT-BRANCH-RELATIONS) (* ;; "My branches") @@ -200,18 +200,9 @@ (SETQ DR T)) (IF RB THEN (GIT-COMPARE-BRANCHES RB 'origin/master) - ELSE (GIT-COMPARE-BRANCHES (PICK-BRANCH - (OR [FOR PR IN (GIT-PULL-REQUESTS T DR) - COLLECT (LIST (CL:IF (MEMB 'DRAFT PR) - (CONCAT (CADDR PR) - " (draft)") - (CADDR PR)) - (CADDR PR) - (CONCAT " " (CADR PR) - " #" - (CAR PR] - 'REMOTE) - "Pull requests") + ELSE (GIT-COMPARE-BRANCHES (GIT-PICK-BRANCH (OR (GIT-PRC-MENU DR) + 'REMOTE) + "Pull requests") 'origin/master NIL)))) (DEFCOMMAND cob (BRANCH) @@ -222,7 +213,7 @@ (T (GIT-CHECKOUT (GIT-MY-CURRENT-BRANCH))) ((NEW NEXT) (GIT-MAKE-BRANCH)) - (GIT-CHECKOUT (OR BRANCH (PICK-BRANCH NIL "Branches" 'LOCAL]) + (GIT-CHECKOUT (OR BRANCH (GIT-PICK-BRANCH NIL "Branches" 'LOCAL]) (DEFCOMMAND b? (BRANCH) (GIT-WHICH-BRANCH)) @@ -481,12 +472,14 @@ (GIT-BRANCH-DIFF [LAMBDA (BRANCH1 BRANCH2) - (* ;; "Edited 6-Mar-2022 14:52 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).") + (* ;; "Edited 29-Apr-2022 07:17 by rmk: returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).") (* ;; "This returns an ALIST that classifies how the files in BRANCH1 and BRANCH2 differ (changed, renamed, added, deleted, copied).") - (CL:UNLESS BRANCH1 (SETQ BRANCH1 "origin/master")) - (CL:UNLESS BRANCH2 (SETQ BRANCH2 "origin/master")) + (CL:UNLESS BRANCH1 + (SETQ BRANCH1 'origin/master)) + (CL:UNLESS BRANCH2 + (SETQ BRANCH2 'origin/master)) (GIT-REMOTE-UPDATE) (LET ([MERGE (CAR (GIT-COMMAND (CONCAT "git merge-base " BRANCH1 " " BRANCH2] LINES POS) @@ -500,50 +493,42 @@ POS NIL T) THEN BRANCH1 ELSE BRANCH2))) - (FOR L ADDED DELETED RENAMED CHANGED COPIED IN LINES - DO (SELCHARQ (CHCON1 L) - (A (CL:IF (EQ (CHARCODE TAB) - (NTHCHARCODE L 2)) - (PUSH ADDED (SUBSTRING L 3)) - (ERROR "ADDED NOT RECOGNIZED" L))) - (D (CL:IF (EQ (CHARCODE TAB) - (NTHCHARCODE L 2)) - (PUSH DELETED (SUBSTRING L 3)) - (ERROR "DELETED NOT RECOGNIZED" L))) - (M (CL:IF (SETQ POS (STRPOS " " L)) - (PUSH CHANGED (SUBSTRING L (ADD1 POS))) - (ERROR "CHANGED NOT RECOGNIZED" L))) - (C (IF (AND (EQ (CHARCODE TAB) - (NTHCHARCODE L 5)) - (SETQ POS (STRPOS " " L 7))) - THEN [PUSH COPIED (LIST (SUBSTRING L 6 (SUB1 POS)) - (SUBSTRING L (ADD1 POS)) - (OR (FIXP (SUBATOM L 2 4)) - (HELP "C without a number" L] - ELSE (HELP "COPY NOT RECOGNIZED" L))) - (R (IF (AND (EQ (CHARCODE TAB) - (NTHCHARCODE L 5)) - (SETQ POS (STRPOS " " L 7))) - THEN [PUSH RENAMED (LIST (SUBSTRING L 6 (SUB1 POS)) - (SUBSTRING L (ADD1 POS)) - (OR (FIXP (SUBATOM L 2 4)) - (HELP "R without a number" L] - ELSE (HELP "RENAME NOT RECOGNIZED" L))) - (w (CL:UNLESS (STRPOS "warning: " L 1) - (HELP "UNRECOGNZED GIT LINE" L)) - (CL:UNLESS (EQ 'Y (ASKUSER NIL NIL (CONCAT L " Ignore remaining files? "))) - (ERROR!))) - (HELP "Unrecognized git-diff code" (NTHCHAR L 1))) - FINALLY (CL:WHEN ADDED - (PUSH $$VAL (CONS 'ADDED ADDED))) - (CL:WHEN DELETED - (PUSH $$VAL (CONS 'DELETED DELETED))) - (CL:WHEN RENAMED - (PUSH $$VAL (CONS 'RENAMED RENAMED))) - (CL:WHEN CHANGED - (PUSH $$VAL (CONS 'CHANGED CHANGED))) - (CL:WHEN COPIED - (PUSH $$VAL (CONS 'COPIED COPIED)))]) + (SORT [FOR L IN LINES + COLLECT (SELCHARQ (CHCON1 L) + (A (CL:IF (EQ (CHARCODE TAB) + (NTHCHARCODE L 2)) + (LIST 'ADDED (SUBSTRING L 3)) + (ERROR "ADDED NOT RECOGNIZED" L))) + (D (CL:IF (EQ (CHARCODE TAB) + (NTHCHARCODE L 2)) + (LIST 'DELETED (SUBSTRING L 3)) + (ERROR "DELETED NOT RECOGNIZED" L))) + (M (CL:IF (SETQ POS (STRPOS " " L)) + (LIST 'CHANGED (SUBSTRING L (ADD1 POS))) + (ERROR "CHANGED NOT RECOGNIZED" L))) + (C (IF (AND (EQ (CHARCODE TAB) + (NTHCHARCODE L 5)) + (SETQ POS (STRPOS " " L 7))) + THEN (LIST 'COPIED (SUBSTRING L 6 (SUB1 POS)) + (OR (FIXP (SUBATOM L 2 4)) + (HELP "C without a number" L))) + ELSE (HELP "COPY NOT RECOGNIZED" L))) + (R (IF (AND (EQ (CHARCODE TAB) + (NTHCHARCODE L 5)) + (SETQ POS (STRPOS " " L 7))) + THEN (LIST 'RENAMED (SUBSTRING L 6 (SUB1 POS)) + (SUBSTRING L (ADD1 POS)) + (OR (FIXP (SUBATOM L 2 4)) + (HELP "R without a number" L))) + ELSE (HELP "RENAME NOT RECOGNIZED" L))) + (w (CL:UNLESS (STRPOS "warning: " L 1) + (HELP "UNRECOGNZED GIT LINE" L)) + (CL:UNLESS (EQ 'Y (ASKUSER NIL NIL (CONCAT L + " Ignore remaining files? " + ))) + (ERROR!))) + (HELP "Unrecognized git-diff code" (NTHCHAR L 1] + T]) (GIT-APPROVAL [LAMBDA (BRANCH) (* ; "Edited 19-Nov-2021 15:08 by rmk:") @@ -734,7 +719,7 @@ ELSEIF (NOT NOERROR) THEN (ERROR "Unknown branch" BRANCH]) -(PICK-BRANCH +(GIT-PICK-BRANCH [LAMBDA (BRANCHES TITLE WHERE) (* ; "Edited 6-Mar-2022 08:55 by rmk") (* ; "Edited 25-Feb-2022 09:02 by rmk") (MENU (CREATE MENU @@ -743,6 +728,28 @@ (GIT-BRANCHES WHERE)) MENUFONT _ DEFAULTFONT]) +(GIT-PRC-MENU + [LAMBDA (DRAFT) (* ; "Edited 29-Apr-2022 11:36 by rmk") + (LET* [(PRS (GIT-PULL-REQUESTS T DRAFT)) + (SUPERSETS (CAR (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (CADDR PR] + + (* ;; "Reverse on the theory that rmknnn's should be ordered from nnn highest to lowest") + + (DREVERSE (SORT [FOR PR SUP LABEL IN PRS + COLLECT (SETQ LABEL (CL:IF [SETQ SUP (CAR (CDR (ASSOC (CADDR PR) + SUPERSETS] + (CONCAT (CADDR PR) + " > " SUP) + (CADDR PR))) + (LIST (CL:IF (MEMB 'DRAFT PR) + (CONCAT LABEL " (draft)") + LABEL) + (GITORIGIN (CADDR PR)) + (CONCAT " " (CADR PR) + " #" + (CAR PR] + T]) + (GIT-PULL-REQUESTS [LAMBDA (ALLINFO INCLUDEDRAFTS) (* ; "Edited 25-Feb-2022 09:26 by rmk") (FOR LINE TAB1 TAB2 TAB3 VAL IN (GIT-COMMAND "gh pr list" T) @@ -759,6 +766,53 @@ ,(SUBATOM LINE (ADD1 TAB3] ELSE (SUBATOM LINE (ADD1 TAB2) (SUB1 TAB3]) + +(GIT-BRANCH-RELATIONS + [LAMBDA (BRANCHES BRANCH2) (* ; "Edited 29-Apr-2022 11:05 by rmk") + + (* ;; "Returns a pair (SUPERSETS EQUALS), where each item in SUPERSETS is a list of the form (B0 B1 B2...) where each Bi is a superset of Bj for i < j and EQUALS is a list of branch equivalence classes. ") + + (CL:WHEN BRANCH2 + (SETQ BRANCHES (LIST BRANCHES BRANCH2))) + (FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS ON [FOR B IN BRANCHES + COLLECT (CONS B (GIT-BRANCH-DIFF (GITORIGIN + B) + 'origin/master] + DO (SETQ D1 (CAR DTAIL)) + [FOR D2 IN (CDR DTAIL) + DO (SETQ MORE1 (CL:SET-DIFFERENCE (CDR D1) + (CDR D2) + :TEST + (FUNCTION EQUAL))) + (SETQ MORE2 (CL:SET-DIFFERENCE (CDR D2) + (CDR D1) + :TEST + (FUNCTION EQUAL))) + (IF MORE2 + THEN (CL:UNLESS MORE1 + (PUSH [CDR (OR (ASSOC (CAR D2) + SUPERSETS) + (CAR (PUSH SUPERSETS (CONS (CAR D2] + (CAR D1))) + ELSEIF MORE1 + THEN (PUSH [CDR (OR (ASSOC (CAR D1) + SUPERSETS) + (CAR (PUSH SUPERSETS (CONS (CAR D1] + (CAR D2)) + ELSE (PUSH [CDR (OR (ASSOC (CAR D1) + EQUALS) + (CAR (PUSH EQUALS (CONS (CAR D1] + (CAR D2] + FINALLY + + (* ;; "Sort the supersets so that the larger ones come before the smaller ones") + + [FOR S IN SUPERSETS + DO (CHANGE (CDR S) + (SORT DATUM (FUNCTION (LAMBDA (B1 B2) + (OR (MEMB B2 (CDR (ASSOC B1 SUPERSETS))) + (NOT (MEMB B1 (CDR (ASSOC B2 SUPERSETS] + (RETURN (LIST SUPERSETS EQUALS]) ) @@ -905,12 +959,7 @@ (DEFINEQ (GIT-GET-DIFFERENT-FILES - [LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 7-Mar-2022 08:14 by rmk") - (* ; "Edited 24-Feb-2022 23:57 by rmk") - (* ; "Edited 23-Feb-2022 18:47 by rmk") - (* ; "Edited 12-Feb-2022 18:35 by rmk") - (* ; "Edited 23-Jan-2022 21:45 by rmk") - (* ; "Edited 11-Jan-2022 11:03 by rmk") + [LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2) (* ; "Edited 29-Apr-2022 07:53 by rmk") (* ; "Edited 5-Jan-2022 08:01 by rmk") (DECLARE (USEDFREE FROMGITN)) @@ -942,26 +991,23 @@ (CL:UNLESS DIR2 (SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2) ">"))) - (FOR DLIST IN DIFFS - DO (SELECTQ (CAR DLIST) + (FOR D IN DIFFS + DO (SELECTQ (CAR D) (ADDED (* ;  "Shouldn't exist in MERGE, should exist in BRANCH1") - (FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 GFILE - )))) + (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 (CADR D)))) (DELETED (* ;; "Shouldn't exist in BRANCH1, should exist in MERGE. But maybe git is just confused in marking a file that exists in the wrong place as a delete instead of an add, or maybe it may think of a file that doesn't exist at all as having been deleted. Try for both, but don't cause an error.") - (FOR GFILE IN (CDR DLIST) DO (OR (GIT-GET-FILE MERGE GFILE - (CONCAT DIR2 GFILE) - T) - (GIT-GET-FILE BRANCH1 GFILE - (CONCAT DIR1 GFILE) - T)))) + (SETQ D (CADR D)) + (OR (GIT-GET-FILE MERGE D (CONCAT DIR2 D) + T) + (GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D) + T))) (CHANGED (* ; "Should exist in both branches") - (FOR GFILE IN (CDR DLIST) DO (GIT-GET-FILE BRANCH1 GFILE (CONCAT DIR1 - GFILE)) - (GIT-GET-FILE MERGE GFILE (CONCAT DIR2 GFILE - )))) + (SETQ D (CADR D)) + (GIT-GET-FILE BRANCH1 D (CONCAT DIR1 D)) + (GIT-GET-FILE MERGE D (CONCAT DIR2 D))) ((RENAMED COPIED) (* ;; "These entries are from-to filename pairs. If (CADDR) is 100, only need to fetch one, because it presumably has disappeared in MERGE and reappeared in BRANCH1. MAPPINGS is returned so the connection can be reestablished higher up. ") @@ -971,32 +1017,35 @@ (* ;; "For copied files, presumably 2 files are exactly the same. But we hope we can show them on the same line, by virtue of the mapping.") - (FOR GFILE F1 IN (CDR DLIST) - DO - (* ;; "F1 is the file in branch 1, if any, F2 is in branch 2") + (LET ((GFILE (CDR D)) + F1) - [SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE) - (CONCAT DIR1 (CADR GFILE] - (IF (EQ (CADDR GFILE) - 100) - THEN + (* ;; "GFILE is a triple (F2 F1 N )") + + (* ;; "F1 is the file in branch 1, if any, F2 is in branch 2") + + [SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE) + (CONCAT DIR1 (CADR GFILE] + (IF (EQ (CADDR GFILE) + 100) + THEN (* ;; "A little tricky to figure out what corresponds to the real file in the mapping, which directory it belongs to. Maybe the first one should always be one that exists, the second may just be a useful name. But we have to know whether to match against INFO1 or INFO2") - (PUSH MAPPINGS (LIST (FULLNAME F1) - (SLASHIT (U-CASE (CONCAT DIR2 - (CAR GFILE))) - T) - (NTHCHAR (CAR DLIST) - 1) - 100)) - ELSE - (* ;; + (PUSH MAPPINGS (LIST (FULLNAME F1) + (SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE)) + ) + T) + (NTHCHAR (CAR D) + 1) + 100)) + ELSE + (* ;;  "If not a perfect match, then the directory should figure it out") - (GIT-GET-FILE MERGE (CAR GFILE) - (CONCAT DIR2 (CAR GFILE)) - T)))) + (GIT-GET-FILE MERGE (CAR GFILE) + (CONCAT DIR2 (CAR GFILE)) + T)))) (HELP "UNKNOWN GIT-DIFF TAG" DLIST))) (LIST DIR1 DIR2 MAPPINGS))]) @@ -1436,22 +1485,23 @@ (ERROR "INITIALS is not set"]) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4696 5542 (GIT-CLONEP 4706 . 5540)) (7977 9957 (ALLSUBDIRS 7987 . 9155) (MEDLEYSUBDIRS -9157 . 9596) (GITSUBDIRS 9598 . 9955)) (9958 15432 (TOGIT 9968 . 12116) (FROMGIT 12118 . 13096) ( -GIT-DELETE-FILE 13098 . 13992) (MYMEDLEY-DELETE-FILES 13994 . 15430)) (15433 17582 (MYMEDLEYSUBDIR -15443 . 15889) (GITSUBDIR 15891 . 16214) (STRIPDIR 16216 . 16587) (STRIPHOST 16589 . 16825) (STRIPNAME - 16827 . 17580)) (17583 19111 (GFILE4MFILE 17593 . 17839) (MFILE4GFILE 17841 . 18183) ( -GIT-REPO-FILENAME 18185 . 19109)) (19160 30112 (GIT-COMMIT 19170 . 19748) (GIT-PUSH 19750 . 20306) ( -GIT-PULL 20308 . 20714) (GIT-BRANCH-DIFF 20716 . 24696) (GIT-APPROVAL 24698 . 24899) (GIT-GET-FILE -24901 . 27201) (GIT-FILE-EXISTS? 27203 . 28030) (GIT-REMOTE-UPDATE 28032 . 29074) (GIT-REMOTE-ADD -29076 . 29383) (GIT-FILE-DATE 29385 . 30110)) (30157 36214 (GIT-CHECKOUT 30167 . 30408) ( -GIT-WHICH-BRANCH 30410 . 30994) (GIT-MAKE-BRANCH 30996 . 32487) (GIT-BRANCHES 32489 . 33663) ( -GIT-BRANCH-EXISTS? 33665 . 34862) (PICK-BRANCH 34864 . 35314) (GIT-PULL-REQUESTS 35316 . 36212)) ( -36244 39076 (GIT-MY-CURRENT-BRANCH 36254 . 36427) (GIT-MY-BRANCHP 36429 . 37348) (GIT-MY-NEXT-BRANCH -37350 . 37791) (GIT-MY-BRANCHES 37793 . 39074)) (39122 43014 (GIT-ADD-WORKTREE 39132 . 41014) ( -GIT-REMOVE-WORKTREE 41016 . 41594) (GIT-LIST-WORKTREES 41596 . 42400) (WORKTREEDIR 42402 . 43012)) ( -43062 71199 (GIT-GET-DIFFERENT-FILES 43072 . 49507) (GIT-COMPARE-BRANCHES 49509 . 55301) ( -GIT-COMPARE-WITH-MYMEDLEY 55303 . 59061) (GIT-COMPARE-WORKTREE 59063 . 62540) (GITCDOBJBUTTONFN 62542 - . 67546) (GIT-CD-LABELFN 67548 . 68630) (GIT-CD-MENUFN 68632 . 71197)) (71269 74938 (CDGITDIR 71279 - . 71975) (GIT-COMMAND 71977 . 74051) (GITORIGIN 74053 . 74630) (GIT-INITIALS 74632 . 74936))))) + (FILEMAP (NIL (4721 5567 (GIT-CLONEP 4731 . 5565)) (7335 9315 (ALLSUBDIRS 7345 . 8513) (MEDLEYSUBDIRS +8515 . 8954) (GITSUBDIRS 8956 . 9313)) (9316 14790 (TOGIT 9326 . 11474) (FROMGIT 11476 . 12454) ( +GIT-DELETE-FILE 12456 . 13350) (MYMEDLEY-DELETE-FILES 13352 . 14788)) (14791 16940 (MYMEDLEYSUBDIR +14801 . 15247) (GITSUBDIR 15249 . 15572) (STRIPDIR 15574 . 15945) (STRIPHOST 15947 . 16183) (STRIPNAME + 16185 . 16938)) (16941 18469 (GFILE4MFILE 16951 . 17197) (MFILE4GFILE 17199 . 17541) ( +GIT-REPO-FILENAME 17543 . 18467)) (18518 29311 (GIT-COMMIT 18528 . 19106) (GIT-PUSH 19108 . 19664) ( +GIT-PULL 19666 . 20072) (GIT-BRANCH-DIFF 20074 . 23895) (GIT-APPROVAL 23897 . 24098) (GIT-GET-FILE +24100 . 26400) (GIT-FILE-EXISTS? 26402 . 27229) (GIT-REMOTE-UPDATE 27231 . 28273) (GIT-REMOTE-ADD +28275 . 28582) (GIT-FILE-DATE 28584 . 29309)) (29356 39349 (GIT-CHECKOUT 29366 . 29607) ( +GIT-WHICH-BRANCH 29609 . 30193) (GIT-MAKE-BRANCH 30195 . 31686) (GIT-BRANCHES 31688 . 32862) ( +GIT-BRANCH-EXISTS? 32864 . 34061) (GIT-PICK-BRANCH 34063 . 34517) (GIT-PRC-MENU 34519 . 35819) ( +GIT-PULL-REQUESTS 35821 . 36717) (GIT-BRANCH-RELATIONS 36719 . 39347)) (39379 42211 ( +GIT-MY-CURRENT-BRANCH 39389 . 39562) (GIT-MY-BRANCHP 39564 . 40483) (GIT-MY-NEXT-BRANCH 40485 . 40926) + (GIT-MY-BRANCHES 40928 . 42209)) (42257 46149 (GIT-ADD-WORKTREE 42267 . 44149) (GIT-REMOVE-WORKTREE +44151 . 44729) (GIT-LIST-WORKTREES 44731 . 45535) (WORKTREEDIR 45537 . 46147)) (46197 73219 ( +GIT-GET-DIFFERENT-FILES 46207 . 51527) (GIT-COMPARE-BRANCHES 51529 . 57321) (GIT-COMPARE-WITH-MYMEDLEY + 57323 . 61081) (GIT-COMPARE-WORKTREE 61083 . 64560) (GITCDOBJBUTTONFN 64562 . 69566) (GIT-CD-LABELFN +69568 . 70650) (GIT-CD-MENUFN 70652 . 73217)) (73289 76958 (CDGITDIR 73299 . 73995) (GIT-COMMAND 73997 + . 76071) (GITORIGIN 76073 . 76650) (GIT-INITIALS 76652 . 76956))))) STOP diff --git a/lispusers/GITFNS.LCOM b/lispusers/GITFNS.LCOM index 51b211feb964c7044a93031727f055604cfe9c51..f2f930440136faba2d0a3c332ea7109f14a8c7ea 100644 GIT binary patch delta 3494 zcma)9PmCK^8K1F3mN<#Cc3h`%x7C+vnywL>%zt~_sPWhyuf02-amL<;Y!sYLyu_Rwd>@B@jsDzyU4@2{`nCv=WF)AQHa!#^ZH1 zIgnLm-uwQ)_x;}Qjeq?K`;*7)yUP*%W@k?1MG*ucBc(EY`u??AS575?6Vr1$N-4u@ z8D8Mva%c6*jq5kp+N;eFtbXZc=hkZ(m@n7os!o2cVpvPCwhmlz$uwayz{!&*IcToj zUTr=%aEeQYW{YLh$UBB!PZ$NX(k9Z6YU99V1KEn43PDQM(gI}iCEc1gYIAiPW{Xzs zsY;TNsXE46WqYYMSJ3OmGcg4@BPs4V{Uf7{3)lXzlQK1F(_?3w?fiDXK}!7; zH6o=JM>g%L{iMF-zT(%ucj4L}sf;YGy{AjZ5)8tVQE_RB9`n1AsK@-G*><-3t*3KT zcjq|soE(1TUbbhGrLa1ZEwQ;W3b$En-`Vc#quDj;@}tp=u5Z|C+F|$7(HFYk$Cfh8 z=8@KB%r~bN^zpDVIB2yJ7e8DKT?7C+({{HD?vp|xgWpu@}iRFfm^a1BX7@J%NPWy3(T@*aGuc** zGr)yFQAFUp%D}SgSR`>OqZb-Wl6!V0UX-!P+&&IuSpp6#KmUxSj2-9laA)my>&Dx+ zVFlLTzJ7VNgYl)5LVYpRk7s6H$NrN@BGMY?FLrlYQB>URnMYfHd-*?+J%n|){(LIL zc75v26w;yDDpEO^dd@Hbhopa19B5E=@I~5GHJqAJui=bGVGYXoE;xFzo&@GM2N;H3 z%hF>JVVMXYEN#Y`Y#_kCzc838w-Oibl}~&S2oCwQe zNRUzVGvfia5$nfnGV#t{jGol5QAr~{^td2ObAH#3QyV(DXUC}x4d=N={TNXeEA}_vDNA^od4zxcN_JR!|Xq-q{r76lu8al;_J92$DQjhyqlM zN)Gpn_ho7tcg1*%Y!*@g1udREdc))#-O88d9K+P>W!nnYKy@PO7AGfxrnOT2v8eL;DWR=a(Y%)afGm-Q2WGOW-9|8xt zh2RI5Ba$}{#@Qv^Brw`>@hu?l%#EVJl$I1gIx{P-tNLQD{wyy96?g>HaZ0ymii=VeM#qa1h_EgdI&Z zqHH5>v37hjZHN0aI700KYe)Ga@py4Fftr}Fi6t5_wviy3L?Cf=co^#pex>*1dL__% za-P(7$bO~i)evGx{-ea?V>@ccaQUP;$j5{b5gQ0SGlNHSu23!(4P>6Y0b1%gLImza z^N2Md%Z!nY#3#zaq{#@WIco$e0ozOaiCn=$rf$^gfYj@W@B;HB2-c?v7UL$}GaE;? zJ`zLwVk#89CeM=(H*7LO#oc>)`FIM7j$OfOEJSJ=JarLaQ!vXlBpLSMRM6cxojLGz z+N^WoYrnq|c7J;MQuhGaustT*q>AnSkzw}Sbj}R06c3a&ddy#a?PrIm`LJZ>O{!j_ zU4O5~{4#6iCPh7_=exX4UB-GEaX5~UA7%LJ$ovPsTNB+Pk-gbUfX(6moobM50&Kgv z-9Kef@a8M-fj5tL50@%zzT(+=WgULU`(8We(VUNy$N$LX7sy8q0znp4|6cccH;+i5 zTPx$0H)1d;E&5k0-XF;3rd})I6(%8DEzRY1}R_)Xw{ z0pK@{|6w316JG!=!Q9ERh zvS?|&;NI%+IR9SfnEO%3U_)D>Tfx1r?XGdwb}%KC`geE1aesR^x%IERmsxtVyPx~= G#{U3NcP^p; delta 2597 zcma)8-EUK67(b^4#tJUoR)*<@d8lYwN#T6=W5%>SJzKk-k8#?G%*fd2V9Uw|Wgi;D zs$80ou$(K627(s^y;W%LVxEPBw%;sW_;kgh5xLCN;DMaIp7=YQ*-1+58mluk2 z1rN-rk7OVyKi zm#upPH_KN%RO{^3R2uKQL0S4PiAL@|1Z=51VROs)VU>_R1^jqC_ znnE$zs2;CtMVH4`i`|V+w4$5Hy8mp2zDb(UY(tr<(ANvabfX&XjK9^2$0nwGD)jUY z0s*HAMXga~>K(?ZYQHwN_?Xl%`ux*<75aFGyFwo+6y-*B7K`j{HB}v7#`+Yc6}#|k zC~B%YtQGf-E&fcjb~+rRxQCc{*nX}f>Ac_XH+=qSUxj+;m@8DZP&6CWbGyonInH*K zct@4;|19J6PkXnfoJ3n%alKJ})ln8nXP-L?nXEov(1=Pj;wF!%Q5)QEkGa*~MB4r` zQN2`9iZGB-)CrIz5%hcpZ<+~`$bw>;hIteuJ_^a)_+(B&Gtc9t)a7Iz zBsSKBF%ih+%?Tq1VuW>Uq9{RbGL_658i)dsF(j*xLRsW7d@|KkMUHQSnRa>ENGl*n z%>sfbw37(}k(+3N7dvtZ9NWqzFnntil8cXu&Nxu!rOtMEJGaw3kF$}HfoD65@C>&r z7Z(+pah%jS3McOFpA(S489Xf(Sh1CwwLbQ5qy-+%0LMjI1m|q7Hwn(hq&C6XDAy)9 zi^o9-9`Xe7@kFii;0tbvi(0n_kGLh4w;m2Y?~@n?0_!uSrG=%7aR_)oj7F^A2K^WC z(FROdUs#!6UR{A1SX#X_J68&T$fBb=076uP0Ir)epc{FtFB_wJc1lU3N8-`*Z>R?Z z7CngNBQcDy+qX7{`Va6z)G>1r>w}@et_Z5wxb3s*Lth*N7E3Lc7A`I^{6eVaH}9x2eh^d6NiI0UL5t*cuDwry`h zOOgFW5q|Z%+}poa=tHeI9^-;`+`f!1>x5wo2W{@%Pw1&my>25PSEyfFNCA-{8`+gG zddexIXNSb~jL{=^8f@%O73y{q`&sk-jXoy=HS71}VEIr6Ep4kaM&0nba39@pHn8ff5W5}s^~%#P zQ}UR-8gZ8h$PKbf1W5oq?C_|P50i%_h|$*O5RhoCJtJ_)U^SV`Wb=5RVlWvl%gG#) zA1T;eGy?7g``v86^S~zZuDpEIeoc~%#BV0ah;+B^6OGqZGle(q`jjU##vtna16mboeo+J4*U zM4nzQEv}U2NSw#|bXB#!DS55GR}=Qv4(+j~))edZ+EJ9gUQ=pa>+XH!&K81(iRtlY z!i22ufuMZ?yLy5=q|Fdcsj7;choDU~2+C?aI|4yX(NYjRHEG~yPTEY4b+7;c diff --git a/lispusers/PRETTYFILEINDEX b/lispusers/PRETTYFILEINDEX index 5ee1e445..06df0f1a 100644 --- a/lispusers/PRETTYFILEINDEX +++ b/lispusers/PRETTYFILEINDEX @@ -1,10 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "30-Nov-2021 22:12:37" {DSK}larry>medley>lispusers>PRETTYFILEINDEX.;2 94399 +(FILECREATED " 5-May-2022 23:33:03"  +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>PRETTYFILEINDEX.;10 96446 - :CHANGES-TO (FNS PFI.PRINT.FILECREATED) + :CHANGES-TO (FNS PFI.PRINT.COMMENTS PFI.MAYBE.NEW.PAGE PFI.MAYBE.PP.DEFINITION + PFI.PRINT.FILECREATED PFI.MAYBE.SEE.PRETTY PRETTYFILEINDEX PFI.PRINT.TO.TAB) - :PREVIOUS-DATE " 9-Jul-2021 21:55:15" {DSK}larry>medley>lispusers>PRETTYFILEINDEX.;1) + :PREVIOUS-DATE "30-Nov-2021 22:12:37" +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>PRETTYFILEINDEX.;6) (* ; " @@ -39,7 +42,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST PFI.MERGE.INDICES)) (COMS (* ; - "Hooks for seeing files pretty elsewhere") + "Hooks for seeing files pretty elsewhere") (FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION) (INITVARS (*PRINT-PRETTY-FROM-FILES* T))) (COMS (* ; "Bitmap hack") @@ -57,7 +60,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. *KEYWORD-PACKAGE*))) (* ;; - "Properties of definers changed between Lyric and Medley (yech).") + "Properties of definers changed between Lyric and Medley (yech).") (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") (FUNCTION CL:INTERN] @@ -102,7 +105,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (READVICE ADVICE)) (*PFI-FILTERS* (VARIABLES . CONSTANTS))) (COMS (* ; - "Prettyprint augmentation to mimic system makefile dumping") + "Prettyprint augmentation to mimic system makefile dumping") (FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT MAYBE.PRETTYPRINT.BOLD) (ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM))) @@ -119,7 +122,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* *COMMON-LISP-READ-ENVIRONMENT*)) [DECLARE%: EVAL@COMPILE DOCOPY (* ; - "Public variables to declare special") + "Public variables to declare special") (P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* @@ -130,11 +133,11 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (FILESLOAD (SYSLOAD) DEFINERPRINT)) (* ; - "Get prettyprinter fixes if running in old sysout") + "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ; - "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") + "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) @@ -145,8 +148,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) - (T (* ; - "Neither one loaded, take original") + (T (* ; "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T) @@ -182,11 +184,12 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (DEFINEQ (PRETTYFILEINDEX - [LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 9-Jul-2021 21:35 by rmk:") - (* ; "Edited 11-Apr-95 00:02 by rmk:") - (* ; "Edited 11-Jun-92 15:58 by cat") + [LAMBDA (FILENAME PRINTOPTIONS OUTSTREAM DONTINDEX) (* ; "Edited 5-May-2022 14:38 by rmk") + (* ; "Edited 9-Jul-2021 21:35 by rmk:") + (* ; "Edited 11-Apr-95 00:02 by rmk:") + (* ; "Edited 11-Jun-92 15:58 by cat") - (* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.") + (* ;; "Makes an indexed file (default is the line printer pseudo-file). The index file will have a number of indices, one for each indexable type. Each type index will list all the items of that type in alphabetical order and the page number of where that item's definition is in the file. The indices will be printed last, so that this can be one-pass.") (RESETLST [PROG ((*STANDARD-OUTPUT* *STANDARD-OUTPUT*) @@ -215,146 +218,140 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (*PFI-PENDING-COMMENTS*) FILECREATED ENV WASOPEN MULTIFILEINDEX CRDATE INDICES PART# FIRSTPAGE LASTPAGE CRDATE) - (* ;; "Specials are as follows:") + (* ;; "Specials are as follows:") - (* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image") + (* ;; "*PRINT-PRETTY-BITMAPS* -- tells prettyprinter to render bitmap as its image") - (* ;; "*PFI-PAGE-COUNT* -- number of current page") + (* ;; "*PFI-PAGE-COUNT* -- number of current page") - (* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing") + (* ;; "*PFI-TWO-SIDED* -- true if preparing two-sided listing") - (* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers") + (* ;; "*PFI-TITLE* -- the file name, NIL to suppress headers") - (* ;; "*PFI-ITEM* -- function, etc currently being printed") + (* ;; "*PFI-ITEM* -- function, etc currently being printed") - (* ;; "*PFI-TYPES* -- list specifying the type associated with an expression") + (* ;; "*PFI-TYPES* -- list specifying the type associated with an expression") - (* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*") + (* ;; "*PFI-FILEVARS* -- alist of filevars we have discovered, along with their values. The first one is always mumbleCOMS. Use this in computing *PFI-FNSLST*") - (* ;; - "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF") + (* ;; + "*PFI-FNSLST* -- list of functions known on this file. Used as the FNSLST arg to PRINTDEF") - (* ;; - "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences") + (* ;; + "*PFI-LOCATIONS* -- list of (name type page#) constituting the actual index occurrences") - (* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.") + (* ;; "*PFI-MAX-WASTED-LINES* -- the maximum number of lines we're willing to waste in order to get an expression all on one page.") - (* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars") + (* ;; "*PFI-FUNNY-CHARS* -- alist of chars to translate to other chars") - (* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default") + (* ;; "*PFI-BITMAP-BASELINE* -- kludge for printing bitmaps--set to baseline of bitmap we have printed below default") - (* ;; - "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed") + (* ;; + "*PFI-PENDING-COMMENTS* -- (lineguess . bodies) of comments we have read but not yet printed") - (* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.") + (* ;; "PRETTYFLG is bound here to insulate us from parallel (MAKEFILE & 'FAST) calls.") [if (TYPENAMEP FILENAME 'STREAM) - then (* ; "Already have input stream") - [SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT] + then (* ; "Already have input stream") + [SETQ *STANDARD-INPUT* (SETQ WASOPEN (GETSTREAM FILENAME 'INPUT] else (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) - (SETQ *STANDARD-INPUT* (OPENSTREAM - FILENAME - 'INPUT - 'OLD - '((SEQUENTIAL T] + (SETQ *STANDARD-INPUT* (OPENSTREAM FILENAME 'INPUT + 'OLD + '((SEQUENTIAL T] (SETQ FILENAME (FULLNAME *STANDARD-INPUT*)) [if (LISTGET PRINTOPTIONS :COMMON) - then (* ; "Common Lisp file") - (SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*) - else (* ; - "Figure out if this is a file manager file, and if so get environment") - (CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED) - (\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T)) - (if (NULL FILECREATED) - then (* ; "Not a File Manager file") - (RETURN NIL) - elseif (NEQ (CAR (LISTP FILECREATED)) - 'FILECREATED) - then (* ; - "File started with open paren, but isn't file manager file.") - (RETURN (if WASOPEN - then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy") - (PRINTDEF FILECREATED T T NIL NIL OUTSTREAM) - (PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM) - (* ; "non-nil return says we did it") - FILENAME)) - elseif (LISTP (CADDR FILECREATED)) - then (* ; - "A compiled file--just use COPYBYTES to avoid binary hassles.") - (RETURN (if WASOPEN - then (* ; - "Print environment and filecreated before copying rest") - (PRINT-READER-ENVIRONMENT ENV OUTSTREAM) - (WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED - OUTSTREAM)) - (COPYBYTES *STANDARD-INPUT* OUTSTREAM) - (* ; "non-nil return says we did it") - FILENAME] + then (* ; "Common Lisp file") + (SETQ ENV *COMMON-LISP-READ-ENVIRONMENT*) + else (* ; + "Figure out if this is a file manager file, and if so get environment") + (CL:MULTIPLE-VALUE-SETQ (ENV FILECREATED) + (\PARSE-FILE-HEADER *STANDARD-INPUT* 'RETURN T)) + (if (NULL FILECREATED) + then (* ; "Not a File Manager file") + (RETURN NIL) + elseif (NEQ (CAR (LISTP FILECREATED)) + 'FILECREATED) + then (* ; + "File started with open paren, but isn't file manager file.") + (RETURN (if WASOPEN + then (* ; "We have already read the first expression, so can't just return now (file may not be randaccessp). So dump what we read and then finish the copy") + (PRINTDEF FILECREATED T T NIL NIL OUTSTREAM) + (PFCOPYBYTES *STANDARD-INPUT* OUTSTREAM) + (* ; "non-nil return says we did it") + FILENAME)) + elseif (LISTP (CADDR FILECREATED)) + then (* ; + "A compiled file--just use COPYBYTES to avoid binary hassles.") + (RETURN (if WASOPEN + then (* ; + "Print environment and filecreated before copying rest") + (PRINT-READER-ENVIRONMENT ENV OUTSTREAM) + (WITH-READER-ENVIRONMENT ENV (PRINT FILECREATED + OUTSTREAM)) + (COPYBYTES *STANDARD-INPUT* OUTSTREAM) + (* ; "non-nil return says we did it") + FILENAME] (CL:UNLESS DONTINDEX (CL:FORMAT PROMPTWINDOW "~%%Starting index of ~A." FILENAME)) [if OUTSTREAM then (SETQ *PFI-TITLE* FILENAME) - (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT)) + (SETQ *STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT)) else (OR (SETQ *PFI-TITLE* (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) - (push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME))) - (SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS)) - (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT) - (if NOPRINT - then - (* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually") - (\CORE.CLOSEFILE STREAM) - (replace (STREAM ACCESS) - of STREAM with NIL) - (\GENERIC-UNREGISTER-STREAM - (fetch (STREAM DEVICE) - of STREAM) - STREAM) - (\CORE.DELETEFILE - (FULLNAME STREAM) - (fetch (STREAM DEVICE) - of STREAM)) - else (CLOSEF? STREAM] - *STANDARD-OUTPUT* - (LISTGET PRINTOPTIONS :DONTPRINT] - (* ; - "Make sure printer knows original name of file") + (push PRINTOPTIONS 'DOCUMENT.NAME (SETQ *PFI-TITLE* FILENAME))) + (SETQ *STANDARD-OUTPUT* (PFI.MAKE.LPT.STREAM PRINTOPTIONS)) + (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM NOPRINT) + (if NOPRINT + then + (* ; "We only did this for the index (hack for MULTIFILEINDEX), so keep it from printing. Kludge: do it by closing the stream manually") + (\CORE.CLOSEFILE STREAM) + (replace (STREAM ACCESS) of STREAM + with NIL) + (\GENERIC-UNREGISTER-STREAM + (fetch (STREAM DEVICE) of STREAM) + STREAM) + (\CORE.DELETEFILE (FULLNAME STREAM) + (fetch (STREAM DEVICE) + of STREAM)) + else (CLOSEF? STREAM] + *STANDARD-OUTPUT* + (LISTGET PRINTOPTIONS :DONTPRINT] + (* ; + "Make sure printer knows original name of file") (RESETSAVE (LINELENGTH (IQUOTIENT (- (DSPRIGHTMARGIN) (DSPLEFTMARGIN)) (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)) *STANDARD-OUTPUT*)) - (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) + (if (NOT (IMAGESTREAMP *STANDARD-OUTPUT*)) then (PFI.SETUP.TRANSLATIONS)) [if DONTINDEX - then (* ; "This is for SEE etc") - (SETQ *PFI-MAX-WASTED-LINES* 0) - (SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother") - (SETQ *PFI-LOCATIONS* :NONE) - else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE)) - (* ; "Enable header printing") + then (* ; "This is for SEE etc") + (SETQ *PFI-MAX-WASTED-LINES* 0) + (SETQ *PFI-TYPES* NIL) (* ; "Tell add.to.index not to bother") + (SETQ *PFI-LOCATIONS* :NONE) + else (STREAMPROP *STANDARD-OUTPUT* 'AFTERNEWPAGEFN (FUNCTION PFI.AFTER.NEW.PAGE)) + (* ; "Enable header printing") - (* ;; "RMK: NOBIND here seems to be deliberate, it seems somehow to match the NOBIND that appears in PFI.HANDLE.RPAQQ.") + (* ;; "RMK: NOBIND here seems to be deliberate, it seems somehow to match the NOBIND that appears in PFI.HANDLE.RPAQQ.") - [SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND] - (* ; "Says to do something with coms") - [if (NOT (FIXP *PFI-MAX-WASTED-LINES*)) - then (* ; - "a parameter expressed as a fraction of page") - (SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES* - (- (PFI.LINES.REMAINING - ) - 2] - [SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES) - (PFI.COLLECT.DEFINERS - *PFI-TYPES*] - (* ; - "Add known record types and definers to the list.") - (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE] + [SETQ *PFI-FILEVARS* `((,(FILECOMS FILENAME) . NOBIND] + (* ; "Says to do something with coms") + [if (NOT (FIXP *PFI-MAX-WASTED-LINES*)) + then (* ; + "a parameter expressed as a fraction of page") + (SETQ *PFI-MAX-WASTED-LINES* (FIXR (TIMES *PFI-MAX-WASTED-LINES* + (- (PFI.LINES.REMAINING) + 2] + [SETQ *PFI-TYPES* (APPEND *PFI-TYPES* (CONS `(RECORD ,CLISPRECORDTYPES) + (PFI.COLLECT.DEFINERS *PFI-TYPES*] + (* ; + "Add known record types and definers to the list.") + (SETQ CRDATE (GETFILEINFO *STANDARD-INPUT* 'CREATIONDATE] [SETQ *PFI-PAGE-COUNT* (SETQ FIRSTPAGE (LOGOR (OR (LISTGET PRINTOPTIONS :FIRSTPAGE) 1) (if *PFI-TWO-SIDED* then - (* ; "Make first page odd") - 1 + (* ; "Make first page odd") + 1 else 0] (if (SETQ PART# (LISTGET PRINTOPTIONS :PART)) then (SETQ *PFI-PAGE-PREFIX* (CONCAT *PFI-PAGE-PREFIX* PART# "-"))) @@ -363,30 +360,29 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. then (PFI.PRINT.FILECREATED FILECREATED ENV)) (PFI.PROCESS.FILE DONTINDEX) (if (NOT WASOPEN) - then (* ; - "We're through with input file now, so release it") - (CLOSEF *STANDARD-INPUT*)) + then (* ; + "We're through with input file now, so release it") + (CLOSEF *STANDARD-INPUT*)) (if (SETQ MULTIFILEINDEX (LISTGET PRINTOPTIONS 'MULTIFILEINDEX)) - then (* ; - "True on calls from multifileindex-remember the date and last page#") - (SETQ LASTPAGE *PFI-PAGE-COUNT*)) + then (* ; + "True on calls from multifileindex-remember the date and last page#") + (SETQ LASTPAGE *PFI-PAGE-COUNT*)) (if (NOT DONTINDEX) - then (* ; - "Now that we've scanned whole file, print the index") - (SETQ INDICES (PFI.PRINT.INDEX CRDATE))) + then (* ; + "Now that we've scanned whole file, print the index") + (SETQ INDICES (PFI.PRINT.INDEX CRDATE))) [if (NULL OUTSTREAM) then (CL:FORMAT PROMPTWINDOW "~%%Finished indexing ~A (~D pages)" - FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE] + FILENAME (ADD1 (- *PFI-PAGE-COUNT* FIRSTPAGE] (if (NULL MULTIFILEINDEX) then FILENAME else (push INDICES (LIST FILENAME CRDATE LASTPAGE ENV)) - (if (NLISTP MULTIFILEINDEX) - then (* ; - "More to do yet, so just return this index") - INDICES - else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX - INDICES) - PRINTOPTIONS))))])]) + (if (NLISTP MULTIFILEINDEX) + then (* ; + "More to do yet, so just return this index") + INDICES + else (PFI.PRINT.MULTI.INDEX (NCONC1 MULTIFILEINDEX INDICES) + PRINTOPTIONS))))])]) (PFI.MAKE.LPT.STREAM [LAMBDA (PRINTOPTIONS) (* ; "Edited 12-Nov-93 09:53 by rmk:") @@ -458,22 +454,20 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (DEFINEQ (PFI.PRINT.FILECREATED - [LAMBDA (EXPR ENV) (* ; - "Edited 30-Nov-2021 22:08 by larry") - (* ; - "Edited 30-Nov-2021 21:40 by larry") - (* ; - "Edited 9-Jul-2021 07:59 by rmk:") + [LAMBDA (EXPR ENV) (* ; "Edited 5-May-2022 21:53 by rmk") + (* ; "Edited 30-Nov-2021 22:08 by larry") + (* ; "Edited 30-Nov-2021 21:40 by larry") + (* ; "Edited 9-Jul-2021 07:59 by rmk:") (* ;; "Display the FILECREATED expression and environment prettily") (* ;; - "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") + "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)") (pop EXPR) (CHANGEFONT ITALICFONT) - (LET* [(STRINGS '("File created:" "changes to:" "previous date:" "Read Table:" "Package:" "Base:" - "Format:")) + (LET* [(STRINGS '("File created: " "changes to: " "previous date: " "Read Table: " + "Package: " "Base: " "Format: ")) (FONT (DSPFONT)) (STRWIDTHS (for STR in STRINGS collect (STRINGWIDTH STR FONT))) (TABSTOP (+ (DSPLEFTMARGIN) @@ -486,42 +480,42 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. " " .FONT LAMBDAFONT (pop EXPR) T T) (* ; "date and file name") (if (OR (NULL (CAR EXPR)) - (FIXP (CAR EXPR))) - then (* ; "Skip over filemaploc") - (pop EXPR)) + (FIXP (CAR EXPR))) + then (* ; "Skip over filemaploc") + (pop EXPR)) (if (SELECTQ (CAR EXPR) - (changes (SETQ EXPR (CDR EXPR)) - T) - (:CHANGES-TO T) - NIL) - then (* ; "handle %"Changes to:%"") - (PFI.PRINT.TO.TAB (pop STRINGS) - (pop STRWIDTHS) - TABSTOP) - (SETQ EXPR (CDR EXPR)) - (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) - T NIL T) - (TERPRI) - (TERPRI) - else (pop STRINGS) - (pop STRWIDTHS)) - (if (SELECTQ (CAR EXPR) - (previous (SETQ EXPR (CDR EXPR)) - T) - (:PREVIOUS-DATE + (changes (SETQ EXPR (CDR EXPR)) T) - NIL) - then (* ; "Handle %"Previous date:%"") - (PFI.PRINT.TO.TAB (pop STRINGS) - (pop STRWIDTHS) - TABSTOP) - (SETQ EXPR (CDR EXPR)) - (PRINTOUT NIL (pop EXPR) - " " - (pop EXPR) - T T) + (:CHANGES-TO T) + NIL) + then (* ; "handle %"Changes to:%"") + (PFI.PRINT.TO.TAB (pop STRINGS) + (pop STRWIDTHS) + TABSTOP) + (SETQ EXPR (CDR EXPR)) + (PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR)) + T NIL T) + (TERPRI) + (TERPRI) else (pop STRINGS) - (pop STRWIDTHS)) + (pop STRWIDTHS)) + (if (SELECTQ (CAR EXPR) + (previous (SETQ EXPR (CDR EXPR)) + T) + (:PREVIOUS-DATE + T) + NIL) + then (* ; "Handle %"Previous date:%"") + (PFI.PRINT.TO.TAB (pop STRINGS) + (pop STRWIDTHS) + TABSTOP) + (SETQ EXPR (CDR EXPR)) + (PRINTOUT NIL (pop EXPR) + " " + (pop EXPR) + T T) + else (pop STRINGS) + (pop STRWIDTHS)) (* ;; "Show environment") @@ -535,9 +529,9 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (PFI.PRINT.ENVIRONMENT ENV :PACKAGE) (if (NEQ *PRINT-BASE* 10) then (PFI.PRINT.TO.TAB (pop STRINGS) - (pop STRWIDTHS) - TABSTOP) - (PFI.PRINT.ENVIRONMENT ENV :BASE) + (pop STRWIDTHS) + TABSTOP) + (PFI.PRINT.ENVIRONMENT ENV :BASE) else (pop STRINGS)) (PFI.PRINT.TO.TAB (pop STRINGS) (pop STRWIDTHS) @@ -545,8 +539,16 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (PFI.PRINT.ENVIRONMENT ENV :FORMAT]) (PFI.PRINT.TO.TAB -(LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") (CHANGEFONT ITALICFONT) (DSPXPOSITION (- TABSTOP WIDTH)) (PRIN3 STR) (RELMOVETO (TIMES 12 (DSPSCALE)) 0) (CHANGEFONT DEFAULTFONT)) -) + [LAMBDA (STR WIDTH TABSTOP) (* ; "Edited 29-Mar-88 12:44 by bvm") + + (* ;; "Print STR of specified WIDTH right-justified to xpos TABSTOP in italic font, leave a couple of spaces, then switch back to defaultfont.") + + (CHANGEFONT ITALICFONT) + (DSPXPOSITION (- TABSTOP WIDTH)) + (PRIN3 STR) + (RELMOVETO (TIMES 12 (DSPSCALE)) + 0) + (CHANGEFONT DEFAULTFONT]) (PFI.PRINT.ENVIRONMENT [LAMBDA (ENV KEYWORD) (* ; "Edited 9-Jul-2021 08:03 by rmk:") @@ -614,8 +616,19 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. ) (PFI.MAYBE.NEW.PAGE -(LAMBDA (EXPR MINLINES) (* ; "Edited 13-Apr-88 14:32 by bvm") (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") (LET (REMAINING) (if (OR (DISPLAYSTREAMP *STANDARD-OUTPUT*) (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) *PFI-MAX-WASTED-LINES*) (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR)))) then (TERPRI) else (* ; "put it on a new page") (DSPNEWPAGE)))) -) + [LAMBDA (EXPR MINLINES) (* ; "Edited 5-May-2022 23:31 by rmk") + (* ; "Edited 13-Apr-88 14:32 by bvm") + + (* ;; "Maybe start a new page if it looks like EXPR will overflow the page and we're near the end of the page. MINLINES is optional size estimate; else we guess") + + (LET (REMAINING) + (if [OR (IMAGESTREAMP *STANDARD-OUTPUT*) + (> (SETQ REMAINING (SUB1 (PFI.LINES.REMAINING))) + *PFI-MAX-WASTED-LINES*) + (>= REMAINING (OR MINLINES (PFI.ESTIMATE.SIZE EXPR] + then (TERPRI) + else (* ; "put it on a new page") + (DSPNEWPAGE]) (PFI.ESTIMATE.SIZE (LAMBDA (EXPR) (* ; "Edited 11-Apr-88 17:37 by bvm") (* ;; "Guess how many lines EXPR will take, so that we can try getting it all on one page if we're near the bottom. Heuristic is that after the first list element in any element, each subsequent element gets its own line") (+ (LET ((TEMPLATE (AND (LITATOM (CAR EXPR)) (GET (CAR EXPR) :DEFINITION-PRINT-TEMPLATE)))) (if (AND TEMPLATE (MEMB :BODY TEMPLATE)) then (* ; "Make extra space for things that have body") 2 else 1)) (PFI.ESTIMATE.SIZE1 EXPR 0))) @@ -677,8 +690,29 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. ) (PFI.PRINT.COMMENTS -(LAMBDA (EXPR) (* ; "Edited 7-Apr-88 12:27 by bvm") (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") (TERPRI) (DESTRUCTURING-BIND (LINES . BODIES) *PFI-PENDING-COMMENTS* (if (NOT (DISPLAYSTREAMP *STANDARD-OUTPUT*)) then (LET ((REMAINING (PFI.LINES.REMAINING))) (if (OR (>= LINES REMAINING) (AND (< REMAINING *PFI-MAX-WASTED-LINES*) (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) LINES)))) then (* ; "put it on a new page") (DSPNEWPAGE)))) (for B in BODIES do (PRINTDEF B T T) (if (> (DSPXPOSITION) (DSPLEFTMARGIN)) then (* ; "Go to new line for next comment. Usually this has already been done") (TERPRI))) (SETQ *PFI-PENDING-COMMENTS* NIL))) -) + [LAMBDA (EXPR) (* ; "Edited 5-May-2022 23:27 by rmk") + (* ; "Edited 7-Apr-88 12:27 by bvm") + + (* ;; "Print any pending comments we have in preparation of printing EXPR. We want to print comments on same page as EXPR, so guess EXPR's size first. This is not perfect, since a handler might end up printing things differently, but it's probably not worse than default handling.") + + (TERPRI) + (DESTRUCTURING-BIND (LINES . BODIES) + *PFI-PENDING-COMMENTS* + [if (NOT (IMAGESTREAMP *STANDARD-OUTPUT*)) + then (LET ((REMAINING (PFI.LINES.REMAINING))) + (if [OR (>= LINES REMAINING) + (AND (< REMAINING *PFI-MAX-WASTED-LINES*) + (< REMAINING (+ (PFI.ESTIMATE.SIZE EXPR) + LINES] + then (* ; "put it on a new page") + (DSPNEWPAGE] + (for B in BODIES do (PRINTDEF B T T) + (if (> (DSPXPOSITION) + (DSPLEFTMARGIN)) + then (* ; + "Go to new line for next comment. Usually this has already been done") + (TERPRI))) + (SETQ *PFI-PENDING-COMMENTS* NIL]) (PFI.HANDLE.FILEMAP (LAMBDA (EXPR) (* ; "Edited 31-Mar-88 15:28 by bvm") (* ;; "Only get here from declare: previewer (during SEE), since declare: expression handler filters out the whole thing.") (PFI.PRETTYPRINT (LIST (QUOTE *) (QUOTE ;;) "---Filemap elided by lister---") NIL T)) @@ -791,12 +825,57 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (DEFINEQ (PFI.MAYBE.SEE.PRETTY -(LAMBDA (FROMFILE TOFILE) (* ; "Edited 1-Apr-88 11:23 by bvm") (* ;; "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") (RESETLST (LET ((*UPPER-CASE-FILE-NAMES* NIL) OUTSTREAM INSTREAM) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NULL (SETQ OUTSTREAM (DISPLAYP TOFILE)))) then (* ; "Not a display window, or don't want prettyprinting") (if (STREAMP FROMFILE) then (* ; "Wanted PFCOPYBYTES") (PFCOPYBYTES FROMFILE TOFILE) else (COPYALLBYTES FROMFILE TOFILE)) else (if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ INSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT) NIL (QUOTE ((SEQUENTIAL T)))))))) (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) else (PFCOPYBYTES INSTREAM OUTSTREAM) (FULLNAME INSTREAM)))))) -) + [LAMBDA (FROMFILE TOFILE) (* ; "Edited 5-May-2022 14:29 by rmk") + (* ; "Edited 1-Apr-88 11:23 by bvm") + + (* ;; + "Replaces COPYALLBYTES and PFCOPYBYTES in various forms of SEE that want to see a whole file") + + (RESETLST + [LET ((*UPPER-CASE-FILE-NAMES* NIL) + OUTSTREAM INSTREAM) + (if [OR (NULL *PRINT-PRETTY-FROM-FILES*) + (NULL (SETQ OUTSTREAM (IMAGESTREAMP TOFILE] + then (* ; + "Not a display window, or don't want prettyprinting") + (if (STREAMP FROMFILE) + then (* ; "Wanted PFCOPYBYTES") + (PFCOPYBYTES FROMFILE TOFILE) + else (COPYALLBYTES FROMFILE TOFILE)) + else [if (NOT (SETQ INSTREAM (STREAMP FROMFILE))) + then (RESETSAVE NIL (LIST 'CLOSEF (SETQ INSTREAM (OPENSTREAM + FROMFILE + 'INPUT NIL + '((SEQUENTIAL T] + + (* ;; "Open the file, try to prettyprint it. We get NIL back from PRETTYFILEINDEX if it's not a file manager file") + + (if (PRETTYFILEINDEX INSTREAM NIL OUTSTREAM T) + else (PFCOPYBYTES INSTREAM OUTSTREAM) + (FULLNAME INSTREAM])]) (PFI.MAYBE.PP.DEFINITION -(LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 1-Apr-88 11:22 by bvm") (LET (ENV) (if (OR (NULL *PRINT-PRETTY-FROM-FILES*) (NOT (DISPLAYP OUTSTREAM)) (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) (WITH-READER-ENVIRONMENT ENV (SETFILEPTR INSTREAM START) (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) (IGNORE-ERRORS (READ INSTREAM)) (LET ((*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM (QUOTE OUTPUT)))) (if CONDITION then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) T else (PFI.PRINT.LAMBDA.BODY DEF) (TERPRI) NIL))))) then (* ;; "Punt to what we were called for in the first place") (PFCOPYBYTES INSTREAM OUTSTREAM START END)))) -) + [LAMBDA (INSTREAM OUTSTREAM START END) (* ; "Edited 5-May-2022 23:14 by rmk") + (* ; "Edited 1-Apr-88 11:22 by bvm") + (LET (ENV) + (if [OR (NULL *PRINT-PRETTY-FROM-FILES*) + (NOT (IMAGESTREAMP OUTSTREAM)) + (NULL (SETQ ENV (GET-ENVIRONMENT-AND-FILEMAP INSTREAM))) + (WITH-READER-ENVIRONMENT ENV + (SETFILEPTR INSTREAM START) + (CL:MULTIPLE-VALUE-BIND (DEF CONDITION) + (IGNORE-ERRORS (READ INSTREAM)) + (LET [(*STANDARD-OUTPUT* (GETSTREAM OUTSTREAM 'OUTPUT] + (if CONDITION + then (CL:FORMAT T "[Failed to read because: ~A]" CONDITION) + T + else (PFI.PRINT.LAMBDA.BODY DEF) + (TERPRI) + NIL))))] + then + (* ;; "Punt to what we were called for in the first place") + + (PFCOPYBYTES INSTREAM OUTSTREAM START END]) ) (RPAQ? *PRINT-PRETTY-FROM-FILES* T) @@ -821,20 +900,19 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (RPAQ? *PFI-MAX-WASTED-LINES* 12) (RPAQ? *PFI-CHARACTER-TRANSLATIONS* '((INTERPRESS (95 172) - (96 169 FAMILY CLASSIC) - (39 185 FAMILY CLASSIC)))) + (96 169 FAMILY CLASSIC) + (39 185 FAMILY CLASSIC)))) (RPAQ? *PFI-INDEX-ORDER* '(FUNCTIONS)) (RPAQ? *PFI-DEFINER-PROPS* (LET ((*PACKAGE* (if (EQ MAKESYSNAME :LYRIC) - then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*)) - ) - - (* ;; - "Properties of definers changed between Lyric and Medley (yech).") + then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))) + + (* ;; + "Properties of definers changed between Lyric and Medley (yech).") - (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") - (FUNCTION CL:INTERN)))) + (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME") + (FUNCTION CL:INTERN)))) (RPAQ? \PFI.PROCESS.COMMANDS ) @@ -885,10 +963,10 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (CL:EVAL-WHEN . PFI.HANDLE.EVAL-WHEN)) (ADDTOVAR *PFI-PREVIEWERS* (DECLARE%: . PFI.PREVIEW.DECLARE) - (DEFINEQ . PFI.PREVIEW.DEFINEQ)) + (DEFINEQ . PFI.PREVIEW.DEFINEQ)) (ADDTOVAR *PFI-PROPERTIES* (COPYRIGHT) - (READVICE ADVICE)) + (READVICE ADVICE)) (ADDTOVAR *PFI-FILTERS* (VARIABLES . CONSTANTS)) @@ -916,11 +994,11 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. ) (ADDTOVAR PRETTYPRINTMACROS (RPAQ . RPAQX.PRETTYPRINT) - (RPAQQ . RPAQX.PRETTYPRINT) - (RPAQ? . RPAQX.PRETTYPRINT) - (ADDTOVAR . RPAQX.PRETTYPRINT) - (PUTPROPS . PUTPROPS.PRETTYPRINT) - (COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT)) + (RPAQQ . RPAQX.PRETTYPRINT) + (RPAQ? . RPAQX.PRETTYPRINT) + (ADDTOVAR . RPAQX.PRETTYPRINT) + (PUTPROPS . PUTPROPS.PRETTYPRINT) + (COURIERPROGRAM . COURIERPROGRAM.PRETTYPRINT)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -960,11 +1038,11 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. DEFINERPRINT)) (* ; - "Get prettyprinter fixes if running in old sysout") + "Get prettyprinter fixes if running in old sysout") (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL")) S) (* ; - "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") + "Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.") LP (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS))) (GETD S)) @@ -975,8 +1053,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))] ((SETQ SYMS (CDR SYMS)) (GO LP)) - (T (* ; - "Neither one loaded, take original") + (T (* ; "Neither one loaded, take original") (RETURN 'LISTFILES1] 'PFI.ORIGINAL.LISTFILES1 NIL T) @@ -994,28 +1071,28 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation. ) (PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (10070 12305 (PFI.NEW.LISTFILES1 10080 . 10574) (PFI.ENQUEUE 10576 . 11200) ( -\PFI.DO.HARDCOPY 11202 . 11788) (MAYBE.PRETTYFILEINDEX 11790 . 12303)) (12306 35220 (PRETTYFILEINDEX -12316 . 26748) (PFI.MAKE.LPT.STREAM 26750 . 29801) (PFI.SETUP.TRANSLATIONS 29803 . 31317) ( -PFI.OUTCHARFN 31319 . 33293) (PFI.COLLECT.DEFINERS 33295 . 34107) (PFI.AFTER.NEW.PAGE 34109 . 35218)) -(35221 41169 (PFI.PRINT.FILECREATED 35231 . 39436) (PFI.PRINT.TO.TAB 39438 . 39803) ( -PFI.PRINT.ENVIRONMENT 39805 . 41167)) (41170 48354 (PFI.PROCESS.FILE 41180 . 42410) (PFI.PASS.COMMENT -42412 . 43382) (PFI.HANDLE.EXPR 43384 . 44051) (PFI.DEFAULT.HANDLER 44053 . 46106) (PFI.PRETTYPRINT -46108 . 46443) (PFI.LINES.REMAINING 46445 . 46772) (PFI.MAYBE.NEW.PAGE 46774 . 47277) ( -PFI.ESTIMATE.SIZE 47279 . 47810) (PFI.ESTIMATE.SIZE1 47812 . 48352)) (48391 57878 (PFI.HANDLE.RPAQQ -48401 . 49809) (PFI.HANDLE.DECLARE 49811 . 50750) (PFI.HANDLE.EVAL-WHEN 50752 . 51235) ( -PFI.HANDLE.DEFDEFINER 51237 . 52527) (PFI.HANDLE.DEFINEQ 52529 . 52773) (PFI.PRINT.LAMBDA 52775 . -53113) (PFI.PRINT.LAMBDA.BODY 53115 . 53450) (PFI.HANDLE.PUTDEF 53452 . 53949) (PFI.HANDLE.PUTPROPS -53951 . 54566) (PFI.HANDLE./DECLAREDATATYPE 54568 . 55115) (PFI.HANDLE.* 55117 . 56379) ( -PFI.PRINT.COMMENTS 56381 . 57281) (PFI.HANDLE.FILEMAP 57283 . 57571) (PFI.HANDLE.PACKAGE 57573 . 57876 -)) (57906 58898 (PFI.PREVIEW.DECLARE 57916 . 58578) (PFI.PREVIEW.DEFINEQ 58580 . 58896)) (58934 69922 -(PFI.PRINT.INDEX 58944 . 59795) (PFI.CONDENSE.INDEX 59797 . 61604) (PFI.SORT.INDICES 61606 . 62745) ( -PFI.COMPUTE.INDEX.SHAPE 62747 . 64211) (PFI.PRINT.INDICES 64213 . 68755) (PFI.CENTER.PRINT 68757 . -69327) (PFI.INDEX.BREAK 69329 . 69787) (PFI.LOOKUP.NAME 69789 . 69920)) (69923 71154 (PFI.ADD.TO.INDEX - 69933 . 70443) (PFI.VARNAME 70445 . 70855) (PFI.CONSTANTNAMES 70857 . 71152)) (71189 79502 ( -MULTIFILEINDEX 71199 . 71995) (MULTIFILEINDEX1 71997 . 73453) (PFI.PRINT.MULTI.INDEX 73455 . 78558) ( -PFI.CHOOSE.BEST 78560 . 78787) (PFI.MERGE.INDICES 78789 . 79500)) (79559 81177 (PFI.MAYBE.SEE.PRETTY -79569 . 80499) (PFI.MAYBE.PP.DEFINITION 80501 . 81175)) (81247 85082 (PFI.PRINT.BITMAP 81257 . 85080)) - (87927 91041 (PUTPROPS.PRETTYPRINT 87937 . 89348) (RPAQX.PRETTYPRINT 89350 . 90075) ( -COURIERPROGRAM.PRETTYPRINT 90077 . 90777) (MAYBE.PRETTYPRINT.BOLD 90779 . 91039))))) + (FILEMAP (NIL (10203 12438 (PFI.NEW.LISTFILES1 10213 . 10707) (PFI.ENQUEUE 10709 . 11333) ( +\PFI.DO.HARDCOPY 11335 . 11921) (MAYBE.PRETTYFILEINDEX 11923 . 12436)) (12439 34954 (PRETTYFILEINDEX +12449 . 26482) (PFI.MAKE.LPT.STREAM 26484 . 29535) (PFI.SETUP.TRANSLATIONS 29537 . 31051) ( +PFI.OUTCHARFN 31053 . 33027) (PFI.COLLECT.DEFINERS 33029 . 33841) (PFI.AFTER.NEW.PAGE 33843 . 34952)) +(34955 40868 (PFI.PRINT.FILECREATED 34965 . 39055) (PFI.PRINT.TO.TAB 39057 . 39502) ( +PFI.PRINT.ENVIRONMENT 39504 . 40866)) (40869 48384 (PFI.PROCESS.FILE 40879 . 42109) (PFI.PASS.COMMENT +42111 . 43081) (PFI.HANDLE.EXPR 43083 . 43750) (PFI.DEFAULT.HANDLER 43752 . 45805) (PFI.PRETTYPRINT +45807 . 46142) (PFI.LINES.REMAINING 46144 . 46471) (PFI.MAYBE.NEW.PAGE 46473 . 47307) ( +PFI.ESTIMATE.SIZE 47309 . 47840) (PFI.ESTIMATE.SIZE1 47842 . 48382)) (48421 58630 (PFI.HANDLE.RPAQQ +48431 . 49839) (PFI.HANDLE.DECLARE 49841 . 50780) (PFI.HANDLE.EVAL-WHEN 50782 . 51265) ( +PFI.HANDLE.DEFDEFINER 51267 . 52557) (PFI.HANDLE.DEFINEQ 52559 . 52803) (PFI.PRINT.LAMBDA 52805 . +53143) (PFI.PRINT.LAMBDA.BODY 53145 . 53480) (PFI.HANDLE.PUTDEF 53482 . 53979) (PFI.HANDLE.PUTPROPS +53981 . 54596) (PFI.HANDLE./DECLAREDATATYPE 54598 . 55145) (PFI.HANDLE.* 55147 . 56409) ( +PFI.PRINT.COMMENTS 56411 . 58033) (PFI.HANDLE.FILEMAP 58035 . 58323) (PFI.HANDLE.PACKAGE 58325 . 58628 +)) (58658 59650 (PFI.PREVIEW.DECLARE 58668 . 59330) (PFI.PREVIEW.DEFINEQ 59332 . 59648)) (59686 70674 +(PFI.PRINT.INDEX 59696 . 60547) (PFI.CONDENSE.INDEX 60549 . 62356) (PFI.SORT.INDICES 62358 . 63497) ( +PFI.COMPUTE.INDEX.SHAPE 63499 . 64963) (PFI.PRINT.INDICES 64965 . 69507) (PFI.CENTER.PRINT 69509 . +70079) (PFI.INDEX.BREAK 70081 . 70539) (PFI.LOOKUP.NAME 70541 . 70672)) (70675 71906 (PFI.ADD.TO.INDEX + 70685 . 71195) (PFI.VARNAME 71197 . 71607) (PFI.CONSTANTNAMES 71609 . 71904)) (71941 80254 ( +MULTIFILEINDEX 71951 . 72747) (MULTIFILEINDEX1 72749 . 74205) (PFI.PRINT.MULTI.INDEX 74207 . 79310) ( +PFI.CHOOSE.BEST 79312 . 79539) (PFI.MERGE.INDICES 79541 . 80252)) (80311 83380 (PFI.MAYBE.SEE.PRETTY +80321 . 82104) (PFI.MAYBE.PP.DEFINITION 82106 . 83378)) (83450 87285 (PFI.PRINT.BITMAP 83460 . 87283)) + (90054 93168 (PUTPROPS.PRETTYPRINT 90064 . 91475) (RPAQX.PRETTYPRINT 91477 . 92202) ( +COURIERPROGRAM.PRETTYPRINT 92204 . 92904) (MAYBE.PRETTYPRINT.BOLD 92906 . 93166))))) STOP diff --git a/lispusers/PRETTYFILEINDEX.LCOM b/lispusers/PRETTYFILEINDEX.LCOM index 1ad3538576dbabb6a5f63afcb022fe65eaab4d5a..d45fa9cd0b918b7bdfad35e33418c2e5fe9692e2 100644 GIT binary patch delta 2646 zcmaJ@-D@1z71xYR>uhaHioWcPagSG#B{|YC-?K9{vPZi!(%{*-)0tV1RZKVQ-NhEx zmnFB~_-#zEt`>Q|lfBBGqIh_D)sn)!|B#W{PvSKNUB`Oc@oPqj&XK#P`PIGs&xxMV~ zw3?gCTb=f1=e{Cn%Uk!C=woh15Eq~%mzV6_y}khncbk?dm7s8QuhZJu+TGafw4w8p z-M#%;i~eWA;dg(Bo)8CZOq6nt0sybMeH9J^!;-!SZyc@(&_AA0j_ze-3 zIK4N{UpwCG7F51o2IeTRYYw=enCKi~C1K(bjMxQL1X54p1o5e{r3A5OSr;QGb`qCF zwfG|A%1|Xi(vKFG$}7c5URCLLPfpHia1rBQO4dWCud9Po!|>yHCibdM=EI;(Y z@bMGBXZ*209(;uWi9Q*9_*vscr{|`+5?s)2F8U?m$ zi0khxX3Ly=WatEwuiq{fZ?}uZG%B{D1MeBeYx&H_Wu)fb{oad=(-02Qq&Jb#{UH4B zF#bUrzV>kF?bL6aMe@k&`wxdcrsApd-51)!T*iLfd;WlkzaRd^Lw=epZnST=)9~cC zm<=xtvq)2al;^qO*B*ZUQeTmKM1)*MgiN(@<)a~TMqNmKqTtogPDK;)4f^QNv(`o34R`0nNncW;tQY6+t z?))n|lLI2Zg=i2V!{y+eH&UN&jl#(wTaOOS8)Y5ne;QLGhGD{uphAL*42G((uIYjy zn^5sBR*iN7x>+7*n0`s>hJ+dlc1VL)>t^7Vo=K_^jj#5 zNC>JX0{!oq>8`4(;MHuL5m|qsL@tBx1r9dkYO;n)jC;+FQm@KZ61G_!`i`5_>}b^s zusIFJiM-XdLzbfV)34cA9l;M1A#YtpK~p4LUs+GE=M2Ln2sBlr_V~oK2$54E zQ57^%hJdV~14Kfl|L=}p1{M9-ZsJ6NlQJ_dW`m(y0SO$;OCE$lDa&B70h7%pPz;rh zOiey#iz4bN2xgU3>g*N}vN5Kp5`8rOZ(h>qpC{&c$?SbP@v{?UFR^{E;-VRxSO~LS zTdCUl(!?Rf=HAkZ9Xl5nfcxaz!$bTP{^n46ivH&OU2c>1oY)icC>6nXEiTCK@Q4_7zkAx==A>K&&uEP;~7Hso_~;*b*pM zNI9jjlg)UT|IeSF=qiWmvSJ*O?3TfVv4TMs`&FGWgggyNd$Lc$yDWDu7V2mZeuOx{%p}~B~#rFxc_B!mHVKH&(aO=Gt zYb|3ual{@YeVwS&Y(vt#xtXuSX6sJ#R=!wi?&p-dv$xf}hg<0Sg})y!1fE}*UntNI zW~O>q=iWLoIXFKS4#mAw>ibEIyO0Co=r@aH=fn} zeC&L`jy>ktJ|qhZ7y`ak=!csJbav_-{q5GDcvGX>+n2@)^Xwo3c04|AMn(3%`P+5{ e6?)S<=lD}!_DL__HMs)4f49LEdLQ3imc9V3prW(@ delta 2643 zcmZuzU2Gf25hhPbYs;c7*^=e3Zat=dL<$nY`#)X{Lnrc1x`w>H+?{k%V1%Yc!BQld z3GD<(f`W#NzT3Ez=X4l$Ej#aewiDzn zyJD6+(+JEmY+i$mwN$CVpsjp9pMggG1{!$MhbZWRmdOpv*+DCr{i4pm8)g65-(Gkk z@=XDXl2|OluwGg;oCVXL4G3f{$A^7G%z^HD=CVze{MjhfS{^phK9z?t@%k0?0 z`*}Ol`4_i*U{r%?b0si6$EaAus~Vl$A)Q+)0zHFcR86ozDgZ-=xPeVD7L@QnmI6OO zq^fi(fN$&iv}gKeK&|-GR4PK5IDzey%@sP8qIb#@oFqq|q$bWOFpWo=4OU$xLqw60Y3mv90OlP&i>IXAy+LP`X8lmf}8|m~$Bb^R|^jgrh4^r8h6S_w1 z;#;=aWt}F&a+x?_p?*9KN%4^Tq$x^jbP}qu-6@+hqPh9NB$8TxJ$X z;k_7L^v?WF)r2=mx^@AP{WFo6PEA1+JHNP0ef3}_X`(;e`kdWWmk9R|C6Z@&bwBu1 z=n#oqAbA>jnkea-LWH6FL!%^`89O-QGPTh}RxL`AF?OP@sc^|D5vL@8D)al-7O0{M zrHamqA^^3Z4CuuyGPj@uEtU=lK-HNf=Tf;&Wpn?XmpcjHgtX3J2UcAsQ(;2To8P!cIs2bja?VyCG z63<>(?2ANIh~7Usc?35ScXfU>zycKoC3<-D-Z>4)fmGcfL{LZw3W8f*sswg?R$BXt zs6>2jyse;N-8DRfLo0%A*`6P`#)66HNWfSZ>4ou_EKy|f6rNckUYW53$dUx{9Avx= zhs>i#kTeVckvA+PvAko3d1g}5L|`J6P=V#ZjHC*nJH#=O(Ud_%L`?ymauuUF5LFGL z{~t_Gh_ZwfR$8i>*cuoaib!8?jz8iAF=|ar;ZNtSiJK!c6{9*|HY~J&M2C#Z?99#^ zzB!$P}% zxj*7#pxN2_0SJ=P-z{L9=-Cu7ZJAoxY+E1{_SwkGk2mso*}aWCc9PgHPiu$uK!z&M z<0)7`e4!s&5uH44+`Ut)3Sd!HRsqY4Wp#TXt!c5?&O)5`0!#bYxH#Y{H=Lz))vtR= zQ9-8{$*KsmxAZK{Sg9a`j@_?}H&ih}K#-qk#eycoORe?xtDDVNt^-dKexRrGcmcf! z2vQ4FjTKBAJ1{DCiH3wh;2rST&+(t<#oj=JY{tUJ3#_%)=@UfHK&EfyMw8CaW9*PV zQK%s6t=Ah6)URx_sas#$s$XTp`TBMCYc*Rt^&5ILGWFSklw(&?*<336^z8A@cT@L9 zCVxyNxxPZDD}6co6Q1c^<72JpueXkM9+~dcsh$}(m&)SB+m5@0Bv9zFC;B5h$CIhZ zxH}%bzSBLC%4+OE!QK-~4rLbHh-%MW`kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;138 25865 +(FILECREATED "25-Apr-2022 09:38:17"  +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;140 26309 - :CHANGES-TO (FNS PSEUDOHOST PSEUDOHOSTP) + :CHANGES-TO (FNS EXPAND.PH) - :PREVIOUS-DATE " 5-Feb-2022 08:23:53" -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;136) + :PREVIOUS-DATE "24-Apr-2022 14:18:32" +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;139) (PRETTYCOMPRINT PSEUDOHOSTSCOMS) @@ -19,11 +19,13 @@ (* ;; "Internals") - (FNS EXPAND.PH CONTRACT.PH SLASHIT UNSLASHIT) + (FNS EXPAND.PH CONTRACT.PH SLASHIT UNSLASHIT GETHOSTINFO.PH) (FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH OPENP.PH UNREGISTERFILE.PH REGISTERFILE.PH GENERATEFILES.PH GETFILEINFO.PH SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH RENAMEFILE.PH) - (P (PSEUDOHOST 'LI LOGINHOST/DIR)) + (P (PSEUDOHOST 'LI LOGINHOST/DIR) + (MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG) + (MOVD 'GETHOSTINFO.PH 'GETHOSTINFO)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE TARGETDEVICE) (MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL) (P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE) @@ -178,7 +180,7 @@ (EXPAND.PH [LAMBDA (FILENAME PHDEV) - (* ;; "Edited 5-Feb-2022 08:23 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name") + (* ;; "Edited 25-Apr-2022 09:35 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name") (* ;; "Assumes that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name") @@ -187,7 +189,7 @@ (SETQ PHDEV (FETCH (STREAM DEVICE) OF FILENAME))) (SETQ FILENAME (FETCH (STREAM FULLNAME) OF FILENAME)) ELSEIF (NOT (TYPE? FDEV PHDEV)) - THEN (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV (FILENAMEFIELD FILENAME 'HOST] + THEN (SETQ PHDEV (\GETDEVICEFROMNAME (OR PHDEV FILENAME] (IF (TYPE? PHDEVICE PHDEV) THEN (LET (SUFFIX SUFFIXPOS) (CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME)) @@ -293,6 +295,17 @@ UNSLASHED (CONCAT (SUBSTRING X 1 (SUB1 DIRPOS)) UNSLASHED))]) + +(GETHOSTINFO.PH + [LAMBDA (HOST ATTRIBUTE) + + (* ;; "Edited 24-Apr-2022 14:16 by rmk: the info from the true host") + + (* ;; "Want the info from the true host") + + (GETHOSTINFO.ORIG (OR (TARGETHOST HOST) + HOST) + HOST ATTRIBUTE]) ) (DEFINEQ @@ -422,6 +435,10 @@ ) (PSEUDOHOST 'LI LOGINHOST/DIR) + +(MOVD? 'GETHOSTINFO 'GETHOSTINFO.ORIG) + +(MOVD 'GETHOSTINFO.PH 'GETHOSTINFO) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE @@ -478,12 +495,13 @@ (LOAD 'EXPORTS.ALL)) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1239 9187 (PSEUDOHOST 1249 . 6724) (PSEUDOHOSTP 6726 . 7239) (PSEUDOHOSTS 7241 . 7598) -(TARGETHOST 7600 . 7874) (TRUEFILENAME 7876 . 8563) (PSEUDOFILENAME 8565 . 9185)) (9215 16486 ( -EXPAND.PH 9225 . 10499) (CONTRACT.PH 10501 . 13166) (SLASHIT 13168 . 14736) (UNSLASHIT 14738 . 16484)) - (16487 23277 (OPENFILE.PH 16497 . 17058) (GETFILENAME.PH 17060 . 17349) (DIRECTORYNAMEP.PH 17351 . -17975) (CLOSEFILE.PH 17977 . 18331) (REOPENFILE.PH 18333 . 18898) (DELETEFILE.PH 18900 . 19184) ( -OPENP.PH 19186 . 19362) (UNREGISTERFILE.PH 19364 . 19669) (REGISTERFILE.PH 19671 . 19972) ( -GENERATEFILES.PH 19974 . 21014) (GETFILEINFO.PH 21016 . 21318) (SETFILEINFO.PH 21320 . 21519) ( -NEXTFILEFN.PH 21521 . 22063) (FILEINFOFN.PH 22065 . 22336) (RENAMEFILE.PH 22338 . 23275))))) + (FILEMAP (NIL (1338 9286 (PSEUDOHOST 1348 . 6823) (PSEUDOHOSTP 6825 . 7338) (PSEUDOHOSTS 7340 . 7697) +(TARGETHOST 7699 . 7973) (TRUEFILENAME 7975 . 8662) (PSEUDOFILENAME 8664 . 9284)) (9314 16853 ( +EXPAND.PH 9324 . 10577) (CONTRACT.PH 10579 . 13244) (SLASHIT 13246 . 14814) (UNSLASHIT 14816 . 16562) +(GETHOSTINFO.PH 16564 . 16851)) (16854 23644 (OPENFILE.PH 16864 . 17425) (GETFILENAME.PH 17427 . 17716 +) (DIRECTORYNAMEP.PH 17718 . 18342) (CLOSEFILE.PH 18344 . 18698) (REOPENFILE.PH 18700 . 19265) ( +DELETEFILE.PH 19267 . 19551) (OPENP.PH 19553 . 19729) (UNREGISTERFILE.PH 19731 . 20036) ( +REGISTERFILE.PH 20038 . 20339) (GENERATEFILES.PH 20341 . 21381) (GETFILEINFO.PH 21383 . 21685) ( +SETFILEINFO.PH 21687 . 21886) (NEXTFILEFN.PH 21888 . 22430) (FILEINFOFN.PH 22432 . 22703) ( +RENAMEFILE.PH 22705 . 23642))))) STOP diff --git a/lispusers/PSEUDOHOSTS.LCOM b/lispusers/PSEUDOHOSTS.LCOM index 482ceb3fceb167baec6f88b02971610cff55952a..fa7dee8fc9dd13666b870baf5a7a7bc1ef7e8c27 100644 GIT binary patch delta 776 zcmb7=zi-n(6vvYkgt#;kw5qBSu%9e7@(r>4vu!M)`r;q4QDO(%se;sn(hO;#jZy}r z4y+xiZe?L(Yo)Yv2PXIfm>C(^SvjW&EHz6#oZfw(Kkxg!cV>NUe&{b6but>)RasR* zZkXDJsjQ#w_uuO>20_(w&2`g|O<5BF?TiPn4&RK1uLrv@csCj!t(xHWyCig^t`EZl z5WHTy4S8CUBms6`zGcL$sSN=m(F@wH9lIoT9as|7S;3C|XSxjPnkF~Ew0#n`+@zjH zAbMc}=wAj5W;b@Xf~c3&9X5}7>i=J&=%%t^YU=56P;5*{=?E1+(#v^y;ou<@4-4$G zPRr^@O*T?3EFlkXL{TV}ubQIZCs7tyO~)z2;%3Jc7mbZx~f zEmF=*9~4BzfE*!3anJ$-QWF1FF$#k=5;3AbmTHs7i+9S)fbvAw$JhI!BIg$o9dXO_ zgln?u8~23%Uaagm}Qjs73%XAGe6;L X^o)PXs$cx({&dzY1E5<6n6By%2#Cg8 delta 524 zcmZutQA^uU6gFjoW(ITxQDp5QTZy*o)OV%G@e-Frj~9 z<-X4cK_4f?J@3J%y^Z~YJ?<~~WNtcr89QI9Jv&|jVKkSOE%Nu>HL)J4;;=UiyZZH7vGs8fo&jYhP3G;$%+ IP(KiF02pF~%K!iX diff --git a/lispusers/TEDIT-PF-SEE b/lispusers/TEDIT-PF-SEE index e1eec143..719e62c7 100644 --- a/lispusers/TEDIT-PF-SEE +++ b/lispusers/TEDIT-PF-SEE @@ -1,28 +1,32 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "12-Jan-2022 13:16:00"  -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;110 7695 +(FILECREATED " 5-May-2022 23:48:59"  +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;112 7835 - :CHANGES-TO (FNS PF-TEDIT) + :CHANGES-TO (COMMANDS ts tf) + (FNS PF-TEDIT) + (VARS TEDIT-PF-SEECOMS) - :PREVIOUS-DATE " 2-Jan-2022 22:03:27" -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104) + :PREVIOUS-DATE " 5-May-2022 23:26:29" +{DSK}kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;111) (PRETTYCOMPRINT TEDIT-PF-SEECOMS) -(RPAQQ TEDIT-PF-SEECOMS [(FNS PF-TEDIT) - (COMMANDS ts tf) - (FILES (SYSLOAD) - REGIONMANAGER) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS - (NLAMA) - (NLAML) - (LAMA]) +(RPAQQ TEDIT-PF-SEECOMS + [(FNS PF-TEDIT) + (COMMANDS ts tf) + (FILES (SYSLOAD) + REGIONMANAGER) + (P (MOVD? 'PFCOPYBYTES 'PFI.mAYBE.PP.DEFINITION)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA]) (DEFINEQ (PF-TEDIT - [LAMBDA (FN IFILES REPRINT) (* ; "Edited 12-Jan-2022 13:15 by rmk") + [LAMBDA (FN IFILES REPRINT) (* ; "Edited 5-May-2022 23:11 by rmk") + (* ; "Edited 12-Jan-2022 13:15 by rmk") (* ; "Edited 30-Dec-2021 23:17 by rmk") (* ;; "PF* to a read-only TEDIT window. First argument is the function name, second if given is the input file.") @@ -98,7 +102,7 @@ 3 T T NIL TSTREAM) (PRIN3 ")" TSTREAM) ELSE (PRINTDEF EXPR 3 NIL NIL NIL TSTREAM))) - ELSE (PFCOPYBYTES ISTREAM TSTREAM (POP LOC) + ELSE (PFI.MAYBE.PP.DEFINITION ISTREAM TSTREAM (POP LOC) (POP LOC))) (TERPRI TSTREAM) [TEDIT TSTREAM (OR WINDOW 'PF-TEDIT) @@ -133,6 +137,8 @@ (FILESLOAD (SYSLOAD) REGIONMANAGER) + +(MOVD? 'PFCOPYBYTES 'PFI.mAYBE.PP.DEFINITION) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) @@ -142,5 +148,5 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (947 7216 (PF-TEDIT 957 . 7214))))) + (FILEMAP (NIL (911 7309 (PF-TEDIT 921 . 7307))))) STOP diff --git a/lispusers/TEDIT-PF-SEE.LCOM b/lispusers/TEDIT-PF-SEE.LCOM index ee562f630dec19c96720ae81ea405d715adfdf4e..1a95dff5e0ef1e1d8bce89a6a63206d3962b418a 100644 GIT binary patch delta 483 zcmb7qWfSUZfQ79>miB z;9c@#>P7r3u7!eFFCOR3_uiX%-Fe@Ax!MHRjJgjdKEN2T?KvgSEl+N*w=n|!_s;cj zdGdjpKXuEpbm(=5{oY@^?dV7|Le`)`O8tzIWoTYFx_rcNT(Vv8f|?&+P+?{qjDSax z9}@w?fd<1H1V$JONJ3L4u}qF_KNT<^OsNV=r9&X_l9aX?ZwZsg(xpy(Bp=a18xc_- zpSA}5`@z}d=|nlqZFNIY9Vf4>JgZyGiu_KMT1jFN8nT#WjK}$`u&PRA`ngv7Ceix1 zP*1>!c$=Jqp*34vHYQ=flTNjhQF)EA(3o|%9Egx42n`y3O7}dNz7_WsEuR(ZN@Wqc M@c$!Ii&;ba0`0YYHvj+t delta 292 zcmca1zf5jIxQL;Vu2*87u91O}k%FPIm7$rHfx*P=C9I)=Eq02N`eaIzqim%D+2xtXP@f|av} zqo2ELux^OIf`*%4umV?rn=VkNXNabPRX~tyn5Tbeu&xWxFa;$AB(sc+tPG5;jLd;% zc`_N8Y>r{#W@Iuq*qq7S$HeLE9}wvj8R8nenTL&y2`D^Sgu??Q8^=-0%I)In?Bf{Z Xs%oXcHCc^MZL=?*HzSLmrwkaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2 41496 +(FILECREATED "25-Apr-2022 20:29:09"  +{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;3 32421 - :PREVIOUS-DATE "28-Sep-90 15:14:19" -{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;1) + :CHANGES-TO (VARS CMLPATHNAMECOMS) + + :PREVIOUS-DATE "14-Jan-2022 11:40:58" +{DSK}kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2) (* ; " @@ -21,14 +23,14 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (COMS (* ;; "useful macros") - (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) + (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT) (FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT) (FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION) (FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING %%NUMERIC-STRING-P) - (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME) + (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING CL:TRUENAME) (FUNCTIONS %%MAKE-PATHNAME) (FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL) (FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME) @@ -39,12 +41,11 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA - CL:ENOUGH-NAMESTRING - CL:MERGE-PATHNAMES - CL:MAKE-PATHNAME]) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA) + (NLAML) + (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES + PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME]) @@ -67,19 +68,6 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (DEFMACRO %%COMPONENT-STRING (COMPONENT) `(MKSTRING (OR ,COMPONENT ""))) -(DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL) - `[if (NOT ,ONEFIELDFLG) - then [SETQ ,VAL (CONS (COND - (,PACKFLG (SUBATOM ,FILE ,ST ,END)) - (T (OR (SUBSTRING ,FILE ,ST ,END) - ""))) - (CONS ,NAM ,VAL] - elseif (EQMEMB ,NAM ,ONEFIELDFLG) - then (RETURN (COND - (,PACKFLG (SUBATOM ,FILE ,ST ,END)) - (T (OR (SUBSTRING ,FILE ,ST ,END) - ""]) - (CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-) (:PRINT-FUNCTION %%PRINT-PATHNAME) (:CONSTRUCTOR %%%%MAKE-PATHNAME) @@ -359,168 +347,6 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (MKATOM VERSION)))] END))) -(CL:DEFUN PARSE-NAMESTRING1 (FILE) - -(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") - -(* ;;; "crudely hacked from UNPACKFILENAME.STRING") - - (PROG ((POS 1) - TEM TEM2 BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND PACKFLG DIRFLG ONEFIELDFLG) - (COND - ((NULL FILE) - (RETURN (CONS (SUB1 POS) - NIL))) - ((OR (LITATOM FILE) - (CL:STRINGP FILE) - (NUMBERP FILE))) - [(type? STREAM FILE) (* ; - "For streams, use full name. If anonymous, fake it") - (SETQ FILE (OR (ffetch FULLFILENAME of FILE) - (RETURN (CONS (SUB1 POS) - (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 standard for Xerox product file servers") - (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") - FILE 2) - 0)))) - NIL) - (%%UNPACKFILE1 'HOST 2 TEM FILE PACKFLG ONEFIELDFLG VAL) - [COND - ((EQ TEM -1) - (RETURN (CONS (SUB1 POS) - (DREVERSE VAL] - (SETQ POS (IPLUS TEM 2)) - (SETQ HOSTP T))) - (COND - ((SETQ TEM (LASTCHPOS (CHARCODE %:) - FILE POS)) - (SETQ TEM (SUB1 TEM)) - (%%UNPACKFILE1 'DEVICE POS TEM FILE PACKFLG ONEFIELDFLG VAL) - (SETQ POS (PLUS TEM 2)) - (SETQ HOSTP T))) - (COND - [(EQ DIRFLG 'RETURN) - (LET ((TYPE 'DIRECTORY) - (START (SELCHARQ (NTHCHARCODE FILE POS) - (NIL (RETURN (CONS (SUB1 POS) - (DREVERSE VAL)))) - ((/ <) - (ADD1 POS)) - POS)) - END) - (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) - ((/ >) - [COND - ((AND (EQ START POS) - (NOT HOSTP)) (* ; - "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory") - (SETQ TYPE 'SUBDIRECTORY] - -2) - (PROGN -1))) - (%%UNPACKFILE1 TYPE START END FILE PACKFLG ONEFIELDFLG VAL)) - (RETURN (CONS (SUB1 POS) - (DREVERSE VAL] - ((SELCHARQ (NTHCHARCODE FILE POS) - (/ (* ; - "unix and the `xerox standard' use / for delimiter") - (SETQ TEM (LASTCHPOS (CHARCODE /) - FILE - (ADD1 POS)))) - ((< >) (* ; - "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") - (SETQ TEM (LASTCHPOS (CHARCODE >) - FILE - (ADD1 POS)))) - NIL) - (%%UNPACKFILE1 'DIRECTORY (ADD1 POS) - (SUB1 TEM) - FILE PACKFLG ONEFIELDFLG VAL) - (SETQ POS (ADD1 TEM)) - (SETQ HOSTP T))) - [OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) - (RETURN (CONS (SUB1 POS) - (DREVERSE VAL] - NAMELP - (SELCHARQ CODE - ((%. ! ; NIL) (* ; - "NAME and SUBDIRECTORY fields definitely terminated by now") - (COND - ((AND (EQ CODE (CHARCODE %.)) - (NOT BEYONDNAME) - (SETQ TEM2 (STRPOS "." FILE (ADD1 TEM))) - (SETQ TEM2 (NTHCHAR FILE (ADD1 TEM2))) - (NOT (FIXP TEM2))) - - (* ;; "If there's another dot followed by something other than a numeric extension, then ignore this dot, since we'll get another chance") - - (GO NEXTCHAR))) - [COND - (SUBDIREND (%%UNPACKFILE1 'SUBDIRECTORY POS (SUB1 SUBDIREND) - FILE PACKFLG ONEFIELDFLG VAL) - (SETQ POS (ADD1 SUBDIREND)) - (SETQ SUBDIREND) - (COND - ((AND (NULL CODE) - (EQ POS TEM)) (* ; - "Nothing follows the subdirectory; null name is NOT implied") - (RETURN (CONS (SUB1 POS) - (DREVERSE VAL] - (%%UNPACKFILE1 [COND - ((NOT BEYONDNAME) - (COND - ((NEQ CODE (CHARCODE %.)) - (SETQQ BEYONDEXT ;))) - (SETQQ BEYONDNAME NAME)) - ((NOT BEYONDEXT) - (SETQ BEYONDEXT (COND - ((NEQ CODE (CHARCODE %.)) - ';) - (T T))) - 'TYPE) - (T (SELCHARQ (AND (EQ BEYONDEXT ';) - (NTHCHARCODE FILE POS)) - (P 'PROTECTION) - (A (add POS 1) - 'ACCOUNT) - ((T S) - 'TEMPORARY) - 'VERSION] - POS - (SUB1 TEM) - FILE PACKFLG ONEFIELDFLG VAL) - [COND - ((NULL CODE) (* ; "End of string") - (RETURN (CONS (SUB1 POS) - (DREVERSE VAL] - (SETQ POS (ADD1 TEM))) - (%' (* ; "Quoter") - (add TEM 1)) - ((/ >) (* ; - "Subdirectory terminating character") - (COND - ((AND (NOT HOSTP) - (NOT BEYONDNAME) - DIRFLG) (* ; - "Ok to treat this as a subdirectory") - (SETQ SUBDIREND TEM)))) - NIL) - NEXTCHAR - (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) - (GO NAMELP))) - (CL:DEFUN CL:TRUENAME (PATHNAME) (* ;;; "Return the pathname for the actual file described by the pathname. An error is signaled if no such file exists. PATHNAME can be a pathname, string, symbol, or stream. Synonym streams are followed to their sources") @@ -673,7 +499,8 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (ADDTOVAR NLAML ) -(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME) +(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME + %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME) ) (PRETTYCOMPRINT CMLPATHNAMECOMS) @@ -685,14 +512,14 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (COMS (* ;; "useful macros") - (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) + (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT) (FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT) (FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION) (FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING %%NUMERIC-STRING-P) - (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME) + (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING CL:TRUENAME) (FUNCTIONS %%MAKE-PATHNAME) (FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL) (FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME) @@ -703,33 +530,33 @@ Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation. (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - (ADDVARS (NLAMA) - (NLAML) - (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES - PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME]) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA + CL:ENOUGH-NAMESTRING + CL:MERGE-PATHNAMES + CL:MAKE-PATHNAME]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) -(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME - %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME) +(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME) ) (PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3743 9514 (%%PRINT-PATHNAME 3753 . 3914) (CL:MAKE-PATHNAME 3916 . 8666) ( -%%PRINT-DIRECTORY-COMPONENT 8668 . 9512)) (9516 9709 (CL:PATHNAME-HOST 9516 . 9709)) (9711 9910 ( -CL:PATHNAME-DEVICE 9711 . 9910)) (9912 10120 (CL:PATHNAME-DIRECTORY 9912 . 10120)) (10122 10315 ( -CL:PATHNAME-NAME 10122 . 10315)) (10317 10510 (CL:PATHNAME-TYPE 10317 . 10510)) (10512 10714 ( -CL:PATHNAME-VERSION 10512 . 10714)) (10715 16039 (PATHNAME 10725 . 10917) (CL:MERGE-PATHNAMES 10919 . -13005) (FILE-NAME 13007 . 13148) (CL:HOST-NAMESTRING 13150 . 13339) (CL:ENOUGH-NAMESTRING 13341 . -15806) (%%NUMERIC-STRING-P 15808 . 16037)) (16041 19794 (CL:NAMESTRING 16041 . 19794)) (19796 23267 ( -CL:PARSE-NAMESTRING 19796 . 23267)) (23269 31722 (PARSE-NAMESTRING1 23269 . 31722)) (31724 32727 ( -CL:TRUENAME 31724 . 32727)) (32729 32921 (%%MAKE-PATHNAME 32729 . 32921)) (32923 33560 ( -%%PATHNAME-EQUAL 32923 . 33560)) (33562 34019 (%%DIRECTORY-COMPONENT-EQUAL 33562 . 34019)) (34021 -34644 (%%INITIALIZE-DEFAULT-PATHNAME 34021 . 34644)) (34734 34901 (INTERLISP-NAMESTRING 34734 . 34901) -) (34903 37796 (UNPACKPATHNAME.STRING 34903 . 37796)) (37798 39055 (CL:FILE-NAMESTRING 37798 . 39055)) - (39057 39255 (CL:DIRECTORY-NAMESTRING 39057 . 39255))))) + (FILEMAP (NIL (2107 2238 (%%WILD-NAME 2107 . 2238)) (2240 2319 (%%COMPONENT-STRING 2240 . 2319)) (2924 + 8695 (%%PRINT-PATHNAME 2934 . 3095) (CL:MAKE-PATHNAME 3097 . 7847) (%%PRINT-DIRECTORY-COMPONENT 7849 + . 8693)) (8697 8890 (CL:PATHNAME-HOST 8697 . 8890)) (8892 9091 (CL:PATHNAME-DEVICE 8892 . 9091)) ( +9093 9301 (CL:PATHNAME-DIRECTORY 9093 . 9301)) (9303 9496 (CL:PATHNAME-NAME 9303 . 9496)) (9498 9691 ( +CL:PATHNAME-TYPE 9498 . 9691)) (9693 9895 (CL:PATHNAME-VERSION 9693 . 9895)) (9896 15220 (PATHNAME +9906 . 10098) (CL:MERGE-PATHNAMES 10100 . 12186) (FILE-NAME 12188 . 12329) (CL:HOST-NAMESTRING 12331 + . 12520) (CL:ENOUGH-NAMESTRING 12522 . 14987) (%%NUMERIC-STRING-P 14989 . 15218)) (15222 18975 ( +CL:NAMESTRING 15222 . 18975)) (18977 22448 (CL:PARSE-NAMESTRING 18977 . 22448)) (22450 23453 ( +CL:TRUENAME 22450 . 23453)) (23455 23647 (%%MAKE-PATHNAME 23455 . 23647)) (23649 24286 ( +%%PATHNAME-EQUAL 23649 . 24286)) (24288 24745 (%%DIRECTORY-COMPONENT-EQUAL 24288 . 24745)) (24747 +25370 (%%INITIALIZE-DEFAULT-PATHNAME 24747 . 25370)) (25460 25627 (INTERLISP-NAMESTRING 25460 . 25627) +) (25629 28522 (UNPACKPATHNAME.STRING 25629 . 28522)) (28524 29781 (CL:FILE-NAMESTRING 28524 . 29781)) + (29783 29981 (CL:DIRECTORY-NAMESTRING 29783 . 29981))))) STOP diff --git a/sources/CMLPATHNAME.LCOM b/sources/CMLPATHNAME.LCOM index 28c012eadef98657b4dbbaf946af64eada7cbf27..d40ce10812f1eaa04f066c9ca201aca91d52f2b9 100644 GIT binary patch delta 2568 zcmai0TWl0n7~Yve!4{elm!;5JP8We)%a)mQ&fJ!0m~N-tad&6hy|i7ep^Zh0)L^`X zL}Iuk#zaJc<0U5gAb|%$NZKwW5RC+k5%fiU>Z6$WW=tC&OvIr7nb~c(-A&wN=bZCj z&i~JUzVAQt`xW8l=fc^MAXZ}LE3d||gfYTW92;@TICr?vMxrQ;$+Aw;;))cP$hrBB zp=xGtTk-Ag#=l?^>?$=jpKfi8q6THVP`cWFPZSF5Xy;=>l67?k zTikeK0DkwxaXzqXo!yPU1tPkvvh?6p%Si>fD|0~BTd)XmhJZq1M-7(kuFgb z@3XU3BJXC4NaKopaS#kO1d@FaV3MJI2LB2CrVL~wISMr%aKDe#6EV1wZ&(=_=a zkH0YYs5g%Dg>ZyFPge<&<6I&N8~D)7AFY9iEK{CiznjgNc_d2)`yu?eElapIx=|-1 zLqfTH)^-Nq&1yX~!XAVVi8?L4u;Uw^v2bRiz^q+o+e>cf!ffEO8=UkD81P>JWGC1k zyF$V-ws!Ykl=7r*n>YCL(29Z&?LHAQDB8I*W2UTF1po*evUdPjS63eZCK^{UCDJjf zqqt*@Sh+kRQ0*meqNr61s#h(@iiK3AkrWgkvD1AJTW7Z;AyG5gx?c>QatSc6DPcH4~X%^-}ij{X)_%W9utUx+74MR~3e(Jpn z;Hy>%P^;aN)U(8t?U#bhY8m4SvQ1}>(KqpXB0?T+95uidRE^0>sg2H|e zdDo8Y-!!x~Ir+WV`qIKBPjvEb!dX$Uk*VF)i5+5Gn+MwF;2&rQ^@pMS)^!aY{1I*nmMcA9vwtf zX4}XxZ-N)s2iR%yX0}*n$AK0f@R!~4WGR(4fm^m{!8TM~PPPkm@i-Y z$7LVu5Q;xihmbQnbr@%#OV~v)%``!NfRP2b&!p zQjv<9ri)SYkSaC6P*59^s1`JpXe)acOCUm5DU}NORjK?i|628-O6`w9{Sm3EOwYZu z>m3_Q{Zk}%?mhS1bM8IoyXWD%pD_Qt#atY7@uGKl`ji)Q7$cq!iF}BYF6Fa3a4+)k zLTwFmun^+#r4{!+JH5ZZ--B|~XJ>Mo@&`P6sjN&$y{M;gD62*@il(MfNr?}zrN7mG&A4XHotZwB z^RAO;G&KYY47=6gV8d+7mrXI|Zj3$5+#6;mnfr0}O=haOtg=&1W~#NUIoT-}Gu2+! zTr4xSqkP-}|LBj_KHJ%8o9?iUTP=>}kp%E`cEZn`ZIzGdn?g&)|JL-pA`ourCreI;s>B<6Fy>G?d%!X+!n}mE6yk$^LX2dz1dKTp)zm@6 z2PBk|Guf01Lk^vtojHYgUjWIY2{~~9h60+=zcn-WHsVErY)J#yB%5%a=a802p&(up z4kD>+kViN81(cREqX@)O`BDI>S_Vl1ntK~ShOi)_9*?IN@i<5Z#;uoj_1X{va2U;M z0JP2A-)pqAzE)ao_<_@nhLC{KBtaQLQGa?u%|ym~Q62sUTl%Qu5zC~E3HMG$HoooN z$&Q7MAG`bN|L*7s@PfhbbhrBhL4ra!a};2$5@`DaqVXU1pLP?>M=~)K;CK`oR8n#@ zqopR0pFD=lL=qT%0b^QfEA_ql0{aRaWV3TPW?9CN&^PyY$Edr_>-3XiC~`iiOkydP zX(CX1nfy2%Jv``yV-0DkL?nZPKI7MDcN5sS;$1&B`gYB+{$T0qt_LhJ0xxc21m?r7 ztTDCwBKIq;ePPLQLv!WoiGoKK{>|cd%UXMdGG(FPG&I-ZIb&DX024DtyE@r1w{fQH zd^?z_t1A&1k-fww#MB4}eAI+EK+kG7Ar>UEWMuZZ#|0Ep@ zwj$UkShB5f914vo@j--x0x^9Z_KVin$CIxIOJdbVSPWJih(%oS7{=6N{TPEwsdF(8 z-b~5yNJcpXSK@(AeTz9bH&w+4jiv7Gt^my8CDm}iTdGUH>n<^E8v#f>A{i$;UTtTO zH?yo`riF3jr(2eqbT;<%^4P1!FMD$hvbtP%VTpOc=-9izalT9uvBZ34Oz*wE^Qsjb z+O=lOKj4Q7M3x+Pjh%gN=C4Mm&%Nbgyy8FOr+c>*R&UU4R8nFKaWx%MXh8&ATK)c- zJj!Smw^j6vxh+I4w$%u0yhQib7l}A3M78!VXs(}8@rxF8PCJZ$_w6X~c;kceasKB? zlq(5oAnMI%-U_ZI-*cPAAcUax4^#wS0BPf95#m-fZoK7f4T%tL5+fC%A_Rzy5+HwW zCV`WTDQ}xo1e~pH7ySMb>)p=mmPq`Jhtf(S8JE{i41unSZ%N_^2z`lVIpC|&1RvopsRM0HPzp-Ov(JMhu!;vh0*^d< zJxB}$kmp_a`u)iB4tyc>!m@~A8uB0^C>hte3Ex?O4-=+PxqTwsGWudH_Z90rVcw*q z`GHq9yz`kF<$3UBENEE_-W~t#E;@5zkles5Fh!?U7b^&-cNGcVX@RDccRkMi$atcX4GML=w%5ilHRPK>I1hVBGH(l%2p7B!&KQYMCA$_Jm*Si4EPD)n|SgF ztYArixt*10G&c52KMcWB0@w+Vy9g=;Oi?IsK{~~LAM#{XW!!^EkR}`$0|}~B%$MqY zr|S#P7mcC8Kx0oF^>Bz}{a(oR^$_5ge9L@8c)1~#e=^(Y%;kizSqhfJIqJmH0E`4@ zsVDbH12fj?8==vs801zI7YWj z-wd=FObG-z<_+IA;DtYyO-Hf*Sec>V@*jXAs=OnoDc9U!|b6!bOg5vndH%iixgI z%lbeVG+8%UbQ9H}f4})jS>InFm~4^?7y6>eP)leu*RINC4N zoW9HaJg4t77nc7(j#ca$DS0SFfYY+t;m^Xu`4zh7@ReZ!74K`#g{5b%a7=T;g{l7K z4X}chl{>Rj&a!%WY4sm5#avig{fo^*5O<-}8ia;ThK>vQF%(5>oq-=-q?(CEW04e8 z=Rp!Zl3E)1M5xd$a#S0Xkp%S_%nO8%62yRA3M8tU0ukc5eXqDqp~(4AJd(~tV?>Vt z)uL?%kh=(e@wv}I}l!q!~%{aVZZ<}~X$dlRR zP`@gVXUK62(9qbG!nG%rcw9ahiT6iR2N9%GlGSNHn}o*3FHpU;GSSD0h`0gTS|mX? zmXQ-lEfs-ALh=VuBpTJSD)dEgq+|;E9oqjQN#xN!NaZ3b&_FCfP=q!5Gz!-k4Xmm#)3xYW_d`G2mZ}aj5>H IaZZi=7yTJhEdT%j diff --git a/sources/EDITINTERFACE b/sources/EDITINTERFACE index fa5cd573..6178291a 100644 --- a/sources/EDITINTERFACE +++ b/sources/EDITINTERFACE @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Jan-2022 23:09:02"  -{DSK}kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;34 47559 +(FILECREATED " 8-May-2022 22:49:56"  +{DSK}kaplan>local>medley3.5>my-medley>sources>EDITINTERFACE.;42 47143 - :CHANGES-TO (FNS FIXEDITDATE EDITDATE?) + :CHANGES-TO (FNS FIXEDITDATE) - :PREVIOUS-DATE "19-Jan-2022 10:22:03" -{DSK}kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;31) + :PREVIOUS-DATE " 8-May-2022 17:05:15" +{DSK}kaplan>local>medley3.5>my-medley>sources>EDITINTERFACE.;41) (* ; " @@ -627,7 +627,9 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. OLDATE INITLS]) (FIXEDITDATE - [LAMBDA (EXPR) (* ; "Edited 19-Jan-2022 23:08 by rmk") + [LAMBDA (EXPR) (* ; "Edited 8-May-2022 22:49 by rmk") + + (* ;; "Edited 19-Jan-2022 23:08 by rmk") (* ;; "Edited 8-Dec-2021 16:11 by rmk: Updated to add dates to the initial undated comments that begins with current-editor initials, to provide a kind of dated change-log capability.")  (* ; "Edited 27-Sep-2018 22:04 by rmk:") @@ -733,19 +735,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. (/RPLACA E (EDITDATE (CAR E) INITLS (CADDR PARSE))) - (CL:WHEN [AND (SETQ PARSE (EDITDATE? (CADR E) - T)) - (NULL (CADDR PARSE)) - (STRING.EQUAL INITLS (CADR PARSE)) - (ILEQ (IDIFFERENCE (IDATE) - (IDATE (CAR PARSE))) - (CONSTANT (TIMES 24 3600] - (/RPLACD E (CDDR E))) ELSE (* ;; - "Different edit sequence, attach a new timestamp in front of any old ones.") + "Different edit sequence, attach a new timestamp in front of any old ones, without the rest") - (/ATTACH (EDITDATE NIL INITLS (CADDR PARSE)) + (/ATTACH (EDITDATE NIL INITLS) E)) (* ;; "If the new date has an upgraded comment-level, update all of the previous dates so that they align on the left instead of the right.") @@ -753,10 +747,22 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. (CL:UNLESS (EQ (CADR (CAR E)) ';) (FOR PREV (NEWTYPE _ (CADR (CAR E))) IN (CDR E) - WHILE (EDITDATE? PREV T) UNTIL (EQ (CADR PREV) - NEWTYPE) + WHILE (EDITDATE? PREV) UNTIL (EQ (CADR PREV) + NEWTYPE) DO (/RPLACA (CDR PREV) NEWTYPE))) + ELSEIF (AND [EQ COMMENTFLG (CAR (LISTP (CAR E] + (MEMB [CAR (LISTP (SETQ PARSE (CDAR E] + '(; ;; ;;;)) + [STRINGP (SETQ PARSE (CAR (LISTP (CDR PARSE] + (STRPOS (CONCAT INITLS ": ") + PARSE 1 NIL NIL T)) + THEN + (* ;; + "Just an ordinary comment in first position, with initials: in front. Upgrade it to an edit date.") + + (/RPLACA E (EDITDATE (CAR E) + NIL PARSE)) ELSE (* ;;  "First edit: we didn't see an old date to compare with or smash, not even an initials: xxx form.") @@ -766,26 +772,25 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. (RETURN EXPR)))]) (EDITDATE? - [LAMBDA (COMMENT RESTOK) (* ; "Edited 19-Jan-2022 22:49 by rmk") - (* ; "Edited 8-Dec-2021 18:24 by rmk") + [LAMBDA (COMMENT PARSE) (* ; "Edited 6-May-2022 23:39 by rmk") - (* ;; "Edited 6-Dec-2021 16:04 by rmk: Return will have date/initial, initial/rest, or date/initial/rest. Always an initial and something, or NIL.") - (* ; "Edited 4-Dec-2021 10:39 by rmk") + (* ;; "This determines whether this is a dated or initialed comment that is potentially reusable in the current context. It recognizes comments with edit-date strings of the following formats:") -(* ;;; "This determines whether this is a dated or initialed comment that is potentially reusable in the current context. Unless RESTOK, this only recognizes modern-format configurations of the form %"Edited by %", and returns a parsed pair (DATE INITIALS).") +(* ;;; " %"Edited by (:)%"") -(* ;;; "If RESTOK, this also parses strings with additional stuff after the INITLS (%"Edited by : xxx%") and strings that appear to begin with initials but don't have a date (: xxx). In those cases the return is a triple (DATE INITIALS REST), where DATE may be NIL. ") +(* ;;; " %"Edited >date? by : %"") + +(* ;;; "Value is NIL if the comment is not in one of these formats. Otherwise, if PARSE, then the value is a list ( ), else T. ") (* ;;; "") -(* ;;; -"The caller can compare against current time and current user to decide whether to smash or add.") +(* ;;; "The caller can compare against current time and current-user initials to decide whether to smash or add.") (* ;;; "There is no harm in not recognizing prehistoric formats, new dates will always be added on.") (LET ((TAIL COMMENT) STRING BYPOS (IPOS 1) - DATE I IENDPOS RESTPOS) + DATE I IENDPOS REST) (CL:WHEN [AND (EQ COMMENTFLG (CAR (LISTP TAIL))) (MEMB [CAR (LISTP (SETQ TAIL (CDR TAIL] '(; ;; ;;;)) @@ -799,51 +804,46 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. (* ;; "Standard format, initials should be next. ") - (SETQ IPOS (IPLUS BYPOS 4))) + (SETQ IPOS (IPLUS BYPOS 4)) - (* ;; "Chomp off the next substring--initials?") + (* ;; "The next substring may be the initials, or it may be a comment string without initials prepended. We pull off the next substring and strip the colon if any, but also return the whole trailing string.") - (CL:WHEN (IGREATERP (NCHARS STRING) - IPOS) - [SETQ IENDPOS (SUB1 (OR (STRPOS " " STRING IPOS) - (ADD1 (NCHARS STRING] - (SETQ I (SUBSTRING STRING IPOS IENDPOS)) - (CL:WHEN (ILESSP (NCHARS I) - 12) (* ; + (CL:WHEN (IGREATERP (NCHARS STRING) + IPOS) + [SETQ IENDPOS (SUB1 (OR (STRPOS " " STRING IPOS) + (ADD1 (NCHARS STRING] + (SETQ I (SUBSTRING STRING IPOS IENDPOS)) + (CL:WHEN (ILESSP (NCHARS I) + 12) (* ;  "Sanity check: Initials should be short.") - (CL:WHEN (EQ (CHARCODE %:) - (NTHCHARCODE I -1)) (* ; "Normalize out the colon") - (SETQ I (SUBSTRING I 1 -2))) - (CL:WHEN (SETQ REST (SUBSTRING STRING (ADD1 IENDPOS))) - (SETQ REST (CL:STRING-TRIM `(#\Space) - REST))) - (IF (AND REST (IGREATERP (NCHARS REST) - 0)) - THEN (CL:WHEN RESTOK - - (* ;; "Could be %": abc%" , we fill in the date") - - (LIST (DATE (DATEFORMAT NO.SECONDS)) - I REST)) - ELSEIF DATE - THEN - (* ;; "If we saw just initials") - - (LIST DATE I)))))]) + (CL:WHEN (EQ (CHARCODE %:) + (NTHCHARCODE I -1)) (* ; "Normalize out the colon") + (SETQ I (SUBSTRING I 1 -2))) + (CL:WHEN (NTHCHARCODE STRING (ADD1 IENDPOS)) + (* ; "At least one REST character") + (SETQ REST (SUBSTRING STRING IPOS))) + (OR (NOT PARSE) + (LIST DATE I REST))))))]) (EDITDATE [LAMBDA (OLDDATE INITLS REST) + (* ;; "Edited 6-May-2022 23:13 by rmk: If REST is non-NIL, assumes that it already has the correct INITLS packed onto the font.") + (* ;; "Edited 8-Dec-2021 17:58 by rmk: Upgraded to make sure that the comment includes REST") - (* ; " 20-Nov-86 23:23 by Masinter") + + (* ;; " 20-Nov-86 23:23 by Masinter") (* ;; "Generates a new date from an old one. Packs : onto INITLS if there is a REST. In the REST case we upgrade a singe semicolon to a double.") (LET ((EDITSTRING (CONCAT "Edited " (DATE (DATEFORMAT NO.SECONDS)) - " by " INITLS)) + " by " + (CL:IF REST + "" + INITLS))) NEWDATE OLDSEMI) (CL:WHEN REST - (SETQ EDITSTRING (CONCAT EDITSTRING ": " REST))) + (SETQ EDITSTRING (CONCAT EDITSTRING REST))) (CL:WHEN OLDDATE (SETQ OLDSEMI (CADR OLDDATE))) (SETQ NEWDATE (LIST (CL:IF REST @@ -929,11 +929,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation. ) (PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4089 10388 (ED 4089 . 10388)) (10390 14366 (INSTALL-PROTOTYPE-DEFN 10390 . 14366)) ( -14367 31150 (EDITDEF.FNS 14377 . 15713) (EDITF 15715 . 16595) (EDITFB 16597 . 17445) (EDITFNS 17447 . -18767) (EDITLOADFNS? 18769 . 22569) (EDITMODE 22571 . 24581) (EDITP 24583 . 25094) (EDITV 25096 . -25735) (DC 25737 . 26418) (DF 26420 . 27462) (DP 27464 . 28548) (DV 28550 . 29122) (EDITPROP 29124 . -29343) (EF 29345 . 29674) (EP 29676 . 29859) (EV 29861 . 30040) (EDITE 30042 . 30920) (EDITL 30922 . -31148)) (31500 46704 (NEW/EDITDATE 31510 . 31732) (FIXEDITDATE 31734 . 39753) (EDITDATE? 39755 . 43449 -) (EDITDATE 43451 . 44707) (SETINITIALS 44709 . 46702))))) + (FILEMAP (NIL (4079 10378 (ED 4079 . 10378)) (10380 14356 (INSTALL-PROTOTYPE-DEFN 10380 . 14356)) ( +14357 31140 (EDITDEF.FNS 14367 . 15703) (EDITF 15705 . 16585) (EDITFB 16587 . 17435) (EDITFNS 17437 . +18757) (EDITLOADFNS? 18759 . 22559) (EDITMODE 22561 . 24571) (EDITP 24573 . 25084) (EDITV 25086 . +25725) (DC 25727 . 26408) (DF 26410 . 27452) (DP 27454 . 28538) (DV 28540 . 29112) (EDITPROP 29114 . +29333) (EF 29335 . 29664) (EP 29666 . 29849) (EV 29851 . 30030) (EDITE 30032 . 30910) (EDITL 30912 . +31138)) (31490 46288 (NEW/EDITDATE 31500 . 31722) (FIXEDITDATE 31724 . 39842) (EDITDATE? 39844 . 42842 +) (EDITDATE 42844 . 44291) (SETINITIALS 44293 . 46286))))) STOP diff --git a/sources/EDITINTERFACE.LCOM b/sources/EDITINTERFACE.LCOM index 8fb4fe31ea663d3709cd185ed13561e97968595e..c04f34c5f508f707f01a3f72b34b6818127df471 100644 GIT binary patch delta 2088 zcmaJ?O>7fK6yDiQL+X^ofus!~kS7<4E$Xm8v);8$!5e#%b^MFHsriRchdN3WP=N!g zssQI!DjgxE->LG1GYN@J9y_NRVOQl|_aOsu49mkF-RpV&p&6_v#-ka}x zZy#MJ-(Mr2R{FsV=cccQRasR*Rbw<7(<3+McJy4iH1olwLvzy?=cgAA&9gH^9;9jr z0uX7l*J8RH({KK|tJba_9UToob^7v5^<{GvD;+#J0XY_OZL0z!c;k&!uwvlPBGA7Ows@6IzsDV@kuxPse4Cf z2*gucNqt|>E<%Qw-FuRJ$?o^M@=<@5)Gi44mrcCJCq6DER!%!B17|(WtKP8Y+&b&c zY{Wm^8<7>TQ)xG4kArSTm^}E#FzANCl{V;)X}CRcPT>3phC0UFg`P}J*v3fXNypgMDYc47AN?1crma6SOK zra*uTie4ADe=-n(aZq5YY?ms9QmPyRVS*5eBzRiqgevJH0#9uPoNvS@f>a-L<}*jw zSHWO+q?r<>?62U+pxVkoGhxDZc}AE(T@A@yBGu|urIX;y=G8mi)T#XtN)~cCJMWHX zC%iyp$XdCvlvU<0feHoioxB~D{i*HTC-!!|B9MxIRl2cEh7%H>`x9bA=}PdG@ROySynw_%l7_40%=`aH<4NM8Z9D!;fo|KDMk6 zEY=@5qIY-SwkEVa(6nd&6$*;4u?MpYrJU_LT6HhJuR@vqt66;=$&rjjm z6B6N$8WDKfiHsG zR?-4pY2eALNkXqCz~q``Yi&UhrX*_4s} zAt0SyL=Y2medo4R{LTjO!ru<^_FuRQzoU{IZ{aTd%ziZYjC&LiKIaUWobTd5pWr&y z)Me(LZsLEkasEnXzT=l;lYEhWwtAk0qi>TaJ02ZbygQlZTszaVX4Tdo`m(t~Pi<&u z$S(v{ibQBVlB(&Dcb%kTm6C-NJ~e{awyUTw?jp7Fo^2UlS8X#?jA(1aP+)O`e~ON` zZ`k7}purABi+EkMfl?SLnF9rT+oo5=gRwziGwMkV>X@|6Cc-;$`yEKd#WclLsdov+ySu*O*UBv;T58#MvyE@zW3hHK?sTyH4K5ZfJ z=(g4Nu;VUt5JBP?@qt6ZrLkLlx@PgOPM;!;-FC)&>~Z|9$wZdJOsmT`w~CmJyM vU5PxD+_Z;J)NHYv>doraw5Fs`@M;V{$QW)MuriRZn4=njK>fkNT^;`bEC2Pt delta 2224 zcmaJ?O>7fK6!xrL2o40Bgr9~$o(vRQt<#;^UGHuT#E!kmI{wAG!EH%J3=U12D4>EW zRaNEELvKihK>`V?9(w4Zs$}eN=qXh6P&oEfIP~6A6RAB`barfS3`O0;&YL%H-hA`k z_ul;SIeK&reN`F4dUU3`8YLnjK%{X|9~a4u<<|#huPl6Y<O$>R=8_VM_`_3~oRKOUN!v)jXw=0J0{^FJEBo1r z{{rcgWRO)w(dlh;cp8j!#!fRw6A>6Mm5no*;;a>Q6fZi);y7V=rT=k^q}CDPaeuH> zF6K*iB~wTjD=-CErk8!g+ae&G*(J342M!@LLL>`(w%?8BGL8nnq-i}2Vsu!9P;KGj((2OHrAw=D>0$^JB14D^ zqSo3yczrLsktd5hv=QDLJZkB(>|nV(E2Eq)aiSP|Good{!~ z1KSToB7pwt^LbDuu;%^ZJ{nDU`M5tJw1t5nphOK-_E1BP9vtd-fX+L=ku`rp5Z>`V z@GSu*f?O7K&qI}8wGnRH%+NZcZwLan9Q(C5}^rg)LSZA^qe+5S2irWn1u|8 z-7Spe8aQgkap*%HA+a1hzkQx1++%vthQo8upC+R);#A}5vM5@3$XkxSZKsTcoS{TPRNN>ZA1wfp7T6N`Rku zA@IPTtI_=8@Nj^ef4JG)Os@USZMY&|39!ZCfG12;4LC0G4?_-Fe6^a71m-smRObCg_z=yhlQGTX5H1Y#@VJBmhj6MFyr9X zsaRCI4(hB>n6EaWHKulH661Zi_ache;cN-m1C%%Nlk6SSyZL35U{gj=3BpcPIvu=F z9J7p6v5>YRjFl>ckIY$@s}~j`fE5iwry#_dpVFh&b*4K13HxaTLLp%OLPl+gKc>I} z?K<$YDxo{#Ri}$z^Lc1JzHczeU!EZLPTn(l$|n2i_whICoMs!XAwJf;%>(Q0CO>jJ zk>Pm{@D(q5&}L-D$uAc5PDQ6#t6=vmq}Y>0l&*wjo_=;~%wCqQ%HS93or)*jDqv9p htv6<%v1GYL1uW`uP+|~|JHeD<5E_Tpnkaplan>Local>medley3.5>my-medley>sources>LLCHAR.;12 105415 +(FILECREATED "28-Apr-2022 08:52:36" {DSK}kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;13 104756 - :CHANGES-TO (VARS LLCHARCOMS) + :CHANGES-TO (I.S.OPRS inpname) - :PREVIOUS-DATE "23-Apr-2022 07:49:25" -{DSK}kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;11) + :PREVIOUS-DATE "23-Apr-2022 17:19:02" +{DSK}kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;12) (* ; " @@ -1560,37 +1560,33 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. ,NUM)) (DECLARE%: EVAL@COMPILE -(I.S.OPR 'inpname NIL '[SUBST (GETDUMMYVAR) - '$$BODY - `(bind $$OFFSET _ 1 $$BODY _ BODY $$BASE $$END $$FATP - declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) - first [PROG NIL - $$RETRY - (COND - ((STRINGP $$BODY) - (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) - (SETQ $$OFFSET (ffetch (STRINGP OFFST) of $$BODY)) - (SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP - LENGTH) - of $$BODY))) - (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) - of $$BODY))) - ((LITATOM $$BODY) - (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) - of $$BODY)) - (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) - of $$BASE)) - (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) - of $$BODY))) - (T (SETQ $$BODY (MKSTRING $$BODY)) - (GO $$RETRY] eachtime (AND (IGREATERP $$OFFSET - $$END) - (GO $$OUT)) - (SETQ I.V. - (\GETBASECHAR $$FATP $$BASE - $$OFFSET)) - repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET)) - T] +(I.S.OPR 'inpname NIL + '[SUBST (GETDUMMYVAR) + '$$BODY + `(bind $$OFFSET _ 1 $$BODY _ BODY $$BASE $$END $$FATP $$READONLY + declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET $$READONLY) + first [PROG NIL + $$RETRY + (COND + ((STRINGP $$BODY) + (SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY)) + (SETQ $$OFFSET (ffetch (STRINGP OFFST) of $$BODY)) + (SETQ $$END (IPLUS $$OFFSET -1 (ffetch (STRINGP LENGTH) + of $$BODY))) + (SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY)) + (SETQ $$READONLY (ffetch (STRINGP READONLY) OF $$BODY))) + ((LITATOM $$BODY) + (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY)) + (SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)) + (SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY)) + (SETQ $$READONLY T)) + (T (SETQ $$BODY (MKSTRING $$BODY)) + (GO $$RETRY] eachtime (AND (IGREATERP $$OFFSET $$END) + (GO $$OUT)) + (SETQ I.V. (\GETBASECHAR $$FATP $$BASE + $$OFFSET)) + repeatwhile (PROGN (SETQ $$OFFSET (ADD1 $$OFFSET)) + T] T) (I.S.OPR 'inatom NIL '[SUBST (GETDUMMYVAR) @@ -1855,16 +1851,16 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation. (PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994 2018 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4223 74409 (ALLOCSTRING 4233 . 6256) (MKATOM 6258 . 6893) (SUBATOM 6895 . 8765) ( -CHARACTER 8767 . 9771) (\PARSE.NUMBER 9773 . 25493) (\INVALID.DOTTED.SYMBOL 25495 . 25990) ( -\INVALID.INTEGER 25992 . 27444) (\MKINTEGER 27446 . 30153) (MKSTRING 30155 . 32298) ( -\PRINDATUM.TO.STRING 32300 . 38478) (BKSYSBUF 38480 . 40014) (NCHARS 40016 . 41716) (NTHCHARCODE 41718 - . 43764) (RPLCHARCODE 43766 . 44827) (\RPLCHARCODE 44829 . 46364) (NTHCHAR 46366 . 46559) (RPLSTRING -46561 . 49772) (SUBSTRING 49774 . 52697) (GNC 52699 . 52872) (GNCCODE 52874 . 53642) (GLC 53644 . -53817) (GLCCODE 53819 . 54584) (STREQUAL 54586 . 56700) (STRING.EQUAL 56702 . 61040) (STRINGP 61042 . -61193) (CHCON1 61195 . 61982) (U-CASE 61984 . 65211) (L-CASE 65213 . 69073) (U-CASEP 69075 . 69649) ( -\SMASHABLESTRING 69651 . 70113) (\MAKEWRITABLESTRING 70115 . 70551) (\SMASHSTRING 70553 . 74259) ( -\FATTENSTRING 74261 . 74407)) (74594 79756 (\GETBASESTRING 74604 . 75258) (\PUTBASESTRING 75260 . -77999) (\PUTBASESTRINGFAT 78001 . 78747) (GetBcplString 78749 . 79414) (SetBcplString 79416 . 79754)) -(101801 104615 (%%COPY-ONED-ARRAY 101811 . 103661) (%%COPY-STRING-TO-ARRAY 103663 . 104613))))) + (FILEMAP (NIL (4224 74410 (ALLOCSTRING 4234 . 6257) (MKATOM 6259 . 6894) (SUBATOM 6896 . 8766) ( +CHARACTER 8768 . 9772) (\PARSE.NUMBER 9774 . 25494) (\INVALID.DOTTED.SYMBOL 25496 . 25991) ( +\INVALID.INTEGER 25993 . 27445) (\MKINTEGER 27447 . 30154) (MKSTRING 30156 . 32299) ( +\PRINDATUM.TO.STRING 32301 . 38479) (BKSYSBUF 38481 . 40015) (NCHARS 40017 . 41717) (NTHCHARCODE 41719 + . 43765) (RPLCHARCODE 43767 . 44828) (\RPLCHARCODE 44830 . 46365) (NTHCHAR 46367 . 46560) (RPLSTRING +46562 . 49773) (SUBSTRING 49775 . 52698) (GNC 52700 . 52873) (GNCCODE 52875 . 53643) (GLC 53645 . +53818) (GLCCODE 53820 . 54585) (STREQUAL 54587 . 56701) (STRING.EQUAL 56703 . 61041) (STRINGP 61043 . +61194) (CHCON1 61196 . 61983) (U-CASE 61985 . 65212) (L-CASE 65214 . 69074) (U-CASEP 69076 . 69650) ( +\SMASHABLESTRING 69652 . 70114) (\MAKEWRITABLESTRING 70116 . 70552) (\SMASHSTRING 70554 . 74260) ( +\FATTENSTRING 74262 . 74408)) (74595 79757 (\GETBASESTRING 74605 . 75259) (\PUTBASESTRING 75261 . +78000) (\PUTBASESTRINGFAT 78002 . 78748) (GetBcplString 78750 . 79415) (SetBcplString 79417 . 79755)) +(101142 103956 (%%COPY-ONED-ARRAY 101152 . 103002) (%%COPY-STRING-TO-ARRAY 103004 . 103954))))) STOP diff --git a/sources/LLCHAR.LCOM b/sources/LLCHAR.LCOM index 979ec6c16c31646bd5dfc75e9a6f28fad7642d3d..386e40045108234dc836adbe1e262a2de783f71f 100644 GIT binary patch delta 234 zcmX@Kp7HQ{#t9L^7P^iFMY=`?Mn(z-7FMQ4R>o!%vjgjmH5HVM%n))$Mpj0~R>meu z3S3Ig{=Na8KCZfMKq5s+Au~@w$t~2!M*&&Ao}QkPLP}yuY6>=UObnDXximofor7E* zLtI^eiclQF264$`M@9#AV+Afl0~2#oGX*PW4@W%w51bI50 delta 233 zcmX@Sp7GFn#t9L^#=4FLMY=`?Mn(#T=2nK5Rt82BvjgjmG!>MLkmL-^txOH942+c& zxRjjzeFHpwTy@=mM2eC^W}bqQTd0qZ05q`#FdJ