1
0
mirror of synced 2026-03-16 07:07:05 +00:00

Compare commits

..

9 Commits

Author SHA1 Message Date
Matt Heffron
13eb940538 Fixes a typo in internal/loadups/man-page/loadup.1.md & derived files. (#2542)
Resolves #2536
2026-03-15 19:05:23 -07:00
Matt Heffron
3dc2bba019 Fixes a typo in internal/loadups/man-page/loadup.1.md & derived files. 2026-03-14 21:17:15 -07:00
Larry Masinter
322b2e0fbe DFV gets FNS and/or FUNCTIONS, depending on what definitions exist (#2530)
If both exist, it brings up 2 Sedit windows.

The relative version numbers are currently mapped to Medley absolute
version numbers. It would be nice to extend VERSIONDEFS with a function
(say GEDV) that maps the relative version numbers into the definitions
on git-file versions, by looking at the history. So (GEDV 'FOO 'RECORD
-3) would find the file for FOO's record declaration from WHEREIS, and
get the definition from the version 3 commits back. But GITFNS doesn't
currently have a primitive for fetching and interpreting history.
2026-03-09 23:07:30 -07:00
rmkaplan
a24a4dffc2 READ-READER-ENVIRONMENT can take a file name in addition to an open stream (#2531) 2026-03-09 12:31:01 -07:00
rmkaplan
95e08680b8 \CORE.DIRECTORYNAMEP returns T for the {CORE} (no directory) case (#2522) 2026-03-09 12:15:33 -07:00
rmkaplan
7a7fca0bcf Add lispusers/CONVERT-TO-UTF8 (#2518)
* Add lispusers/CONVERT-TO-UTF8
* FILETYPE with no DFASL defaults to :FAKE-COMPILE-FILE
2026-03-09 12:15:14 -07:00
Matt Heffron
9e4d37efd7 Most of the --option uses were incorrectly converted when making loadup.1 from loadup.md. (#2528)
Most of the --option uses were incorrectly converted to an en-dash instead of two hyphens when making loadup.1 from loadup.md.
The en-dash didn't display correctly in the shell, typically as u with ^.
Edited loadup.md, and regenerated the other changed files using publish.sh
2026-03-09 12:14:19 -07:00
rmkaplan
b8c0c594a9 DFV gets FNS and/or FNS, depending on what definitions exist 2026-03-08 09:26:18 -07:00
rmkaplan
d9f1a78f47 GITFNS remembers user's last branch number in a {LI} file (#2526) 2026-03-07 12:56:21 -08:00
16 changed files with 287 additions and 183 deletions

View File

@@ -111,7 +111,7 @@ output directory called \f[I]gitinfo\f[R] which contains the git commit,
git branch and git status information for the directory at the time the
loadup is run.
.PP
Only one instance (per <MEDLEIDIR>) of loadup can be run at a time.
Only one instance (per <MEDLEYDIR>) of loadup can be run at a time.
There is lock file to prevent simultaneous loadups in the work directory
(named \f[B]\f[BI]lock\f[B]\f[R]) that can be manually removed.
The lock can also be automatically overridden (see the --override flag

View File

@@ -52,7 +52,7 @@ Loadup does all of its work in a work directory (\<MEDLEYDIR>/loadups/build). T
If \<MEDLEYDIR> is a git directory, then a file is created in the loadups output directory called *gitinfo* which contains the git commit, git branch and git status information for the directory at the time the loadup is run.
Only one instance (per \<MEDLEIDIR>) of loadup can be run at a time. There is lock file to prevent simultaneous loadups in the work directory (named ***lock***) that can be manually removed. The lock can also be automatically overridden (see the \-\-override flag below). Alternatively, if a lock is encountered at run time, the user will be asked to choose whether to override or simply exit the loadup.
Only one instance (per \<MEDLEYDIR>) of loadup can be run at a time. There is lock file to prevent simultaneous loadups in the work directory (named ***lock***) that can be manually removed. The lock can also be automatically overridden (see the \-\-override flag below). Alternatively, if a lock is encountered at run time, the user will be asked to choose whether to override or simply exit the loadup.
Note: **MEDLEYDIR** is an environment variable set by the loadup script. It is set to the top level directory of the Medley installation that contains the specific loadup script that
is invoked after all symbolic links are resolved. In the standard global installation this will

View File

@@ -83,7 +83,7 @@ the work directory after the loadup completes.</p>
the loadups output directory called <em>gitinfo</em> which contains the
git commit, git branch and git status information for the directory at
the time the loadup is run.</p>
<p>Only one instance (per &lt;MEDLEIDIR&gt;) of loadup can be run at a
<p>Only one instance (per &lt;MEDLEYDIR&gt;) of loadup can be run at a
time. There is lock file to prevent simultaneous loadups in the work
directory (named <strong><em>lock</em></strong>) that can be manually
removed. The lock can also be automatically overridden (see the

52
lispusers/CONVERT-TO-UTF8 Normal file
View File

@@ -0,0 +1,52 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "25-Feb-2026 09:09:57" {WMEDLEY}<lispusers>CONVERT-TO-UTF8.;16 2573
:EDIT-BY rmk
:CHANGES-TO (FNS CONVERT-TO-UTF8)
:PREVIOUS-DATE "24-Feb-2026 22:45:57" {WMEDLEY}<lispusers>CONVERT-TO-UTF8.;14)
(PRETTYCOMPRINT CONVERT-TO-UTF8COMS)
(RPAQQ CONVERT-TO-UTF8COMS ((FNS CONVERT-TO-UTF8)))
(DEFINEQ
(CONVERT-TO-UTF8
[LAMBDA (FILENAME FILETYPE) (* ; "Edited 25-Feb-2026 09:09 by rmk")
(* ;; "This produces a new version of the source FILENAME with :UTF-8 external format.")
(* ;; "If we had a list of problematic functions (multiple definitions on multiple files, MOVD's), we could check that against the functions in FILENAME, and at least produce a warning.")
(* ;; "Compiling may be tricky: some files have CL:COMPILE-FILE FILETYPE properties that don't correspond to the fact that they actually have only an LCOM. This tries to revert the filetype back to FAKE-COMPILE-FILE so that we don't get confused when a DFASL mysteriously appears.")
(SETQ FILENAME (PSEUDOFILENAME FILENAME))
(SETQ FILENAME (OR (FINDFILE FILENAME T)
(ERROR "FILE NOT FOUND" FILENAME)))
(if [EQ :UTF-8 (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :INPUT)
(fetch (READER-ENVIRONMENT REFORMAT) of (GET-ENVIRONMENT-AND-FILEMAP STREAM
T]
then (PRINTOUT T FILENAME " is already " .P2 :UTF-8 T)
NIL
else (LOAD? (MEDLEYDIR "loadups" 'EXPORTS.ALL)) (* ; "Maybe this should load SYSEDIT ?")
(LOAD FILENAME 'PROP)
(LOADCOMP FILENAME)
(SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY FILENAME))
(CL:WHEN [AND (EQ 'CL:COMPILE-FILE (GETPROP (ROOTFILENAME FILENAME)
'FILETYPE))
(FINDFILE (PACKFILENAME 'EXTENSION 'LCOM 'BODY FILENAME))
(NOT (FINDFILE (PACKFILENAME 'EXTENSION 'DFASL 'BODY FILENAME]
(CL:UNLESS FILETYPE (SETQ FILETYPE :FAKE-COMPILE-FILE))
(PRINTOUT T "Changing FILETYPE back to " .P2 FILETYPE T)
(PUTPROP (ROOTFILENAME FILENAME)
'FILETYPE FILETYPE))
[SETQ FILENAME (MAKEFILE FILENAME '(NEW :UTF-8]
(MAKEFILE1 FILENAME NIL '(F))
FILENAME])
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (406 2550 (CONVERT-TO-UTF8 416 . 2548)))))
STOP

Binary file not shown.

Binary file not shown.

View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
(FILECREATED "28-Oct-2025 14:10:06" {WMEDLEY}<lispusers>GITFNS.;569 131593
(FILECREATED " 2-Mar-2026 14:00:13" {WMEDLEY}<lispusers>GITFNS.;576 133513
:EDIT-BY rmk
:CHANGES-TO (FNS GIT-WORKING-COMPARE-DIRECTORIES GIT-BRANCHES-COMPARE-DIRECTORIES)
:CHANGES-TO (FNS GIT-MY-NEXT-BRANCH)
:PREVIOUS-DATE "28-Oct-2025 13:32:16" {WMEDLEY}<lispusers>GITFNS.;568)
:PREVIOUS-DATE "26-Feb-2026 00:39:22" {WMEDLEY}<lispusers>GITFNS.;575)
(PRETTYCOMPRINT GITFNSCOMS)
@@ -74,7 +74,7 @@
(* ;; "Differences")
(FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS)
(FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS GIT-MODIFIED)
(* ;; "")
@@ -169,6 +169,7 @@
(GIT-MAKE-PROJECT
[LAMBDA (PROJECTNAME CLONEPATH WORKINGPATH EXCLUSIONS DEFAULTSUBDIRS)
(* ; "Edited 25-Feb-2026 23:25 by rmk")
(* ; "Edited 25-Oct-2025 16:53 by rmk")
(* ; "Edited 22-Oct-2025 12:45 by rmk")
(* ; "Edited 20-Oct-2025 18:10 by rmk")
@@ -234,9 +235,8 @@
(CL:WHEN (SETQ GITIGNORE (INFILEP (PACKFILENAME.STRING 'NAME ".gitignore" 'BODY
CLONEPATH)))
(SETQ GITIGNORE (CL:WITH-OPEN-FILE (STREAM GITIGNORE :EXTERNAL-FORMAT :UTF-8)
(bind L until (EOFP STREAM)
while (SETQ L (CL:READ-LINE STREAM :EOF-ERROR-P NIL
:EOF-VALUE NIL))
(bind L until (EOFP STREAM) while (SETQ L (CL:READ-LINE
STREAM NIL))
unless (OR (EQ 0 (NCHARS L))
(STRPOS "#" L)) collect L))))
(SETQ EXCLUSIONS (CL:REMOVE-DUPLICATES (APPEND (for E inside EXCLUSIONS
@@ -274,16 +274,16 @@
"")
"for " PROJECTNAME]
(SETQ PROJECT (create GIT-PROJECT
PROJECTNAME _ PROJECTNAME
GITHOST _ (PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH)
PROJECTNAME PROJECTNAME
GITHOST (PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH)
"}")
WHOST _ (AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W"
WHOST (AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W"
PROJECTNAME)
WORKINGPATH)
"}"))
EXCLUSIONS _ EXCLUSIONS
DEFAULTSUBDIRS _ (MKLIST DEFAULTSUBDIRS)
CLONEPATH _ CLONEPATH))
EXCLUSIONS EXCLUSIONS
DEFAULTSUBDIRS (MKLIST DEFAULTSUBDIRS)
CLONEPATH CLONEPATH))
(/RPLACD [OR (ASSOC PROJECTNAME GIT-PROJECTS)
(CAR (push GIT-PROJECTS (CONS PROJECTNAME]
PROJECT)
@@ -358,7 +358,7 @@
(FIND-ANCESTOR-DIRECTORY
[LAMBDA (STARTDIR PREDFN) (* ; "Edited 8-May-2022 12:17 by rmk")
(BIND POS (A _ STARTDIR) WHILE (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T))
(BIND POS (A STARTDIR) WHILE (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T))
DO (SETQ A (SUBSTRING A 1 POS))
(CL:WHEN (APPLY* PREDFN A)
(RETURN A])
@@ -372,7 +372,7 @@
(GIT-CLONEP (GIT-PROJECT-PATH PROJECTNAME PROJECTPATH)
T T)
[FIND-ANCESTOR-DIRECTORY PROJECTPATH (FUNCTION (LAMBDA (A)
(BIND D (GEN _ (\GENERATEFILES A NIL NIL 1))
(BIND D (GEN (\GENERATEFILES A NIL NIL 1))
WHILE (SETQ D (\GENERATENEXTFILE GEN))
WHEN (GIT-CLONEP D T)
DO (RETFROM (FUNCTION
@@ -684,7 +684,7 @@
(GIT-MAINBRANCH? (GIT-WHICH-BRANCH PROJECT)
PROJECT)
(FOR MF GF DEST (MEDLEYSUBDIRS _ (MEDLEYSUBDIRS PROJECT)) INSIDE MFILES
(FOR MF GF DEST (MEDLEYSUBDIRS (MEDLEYSUBDIRS PROJECT)) INSIDE MFILES
COLLECT (SETQ MF (OR (FINDFILE MF NIL MEDLEYSUBDIRS)
(ERROR "FILE NOT FOUND" MF)))
(CL:UNLESS (STRING.EQUAL MF (INFILEP (PACKFILENAME 'VERSION NIL 'BODY MF))
@@ -709,7 +709,7 @@
(* ;; "Does anybody call this?")
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
(FOR GF MF DEST (GITSUBDIRS _ (GITSUBDIRS PROJECT)) INSIDE GFILES
(FOR GF MF DEST (GITSUBDIRS (GITSUBDIRS PROJECT)) INSIDE GFILES
COLLECT (SETQ GF (OR (FINDFILE GF NIL GITSUBDIRS)
(ERROR "FILE NOT FOUND" GF)))
(SETQ MF (MFILE4GFILE GF))
@@ -742,8 +742,8 @@
"")])
(STRIPDIR
[LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk")
(* ; "Edited 8-Nov-2021 11:50 by rmk:")
[LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk")
(* ; "Edited 8-Nov-2021 11:50 by rmk:")
(IF (STRPOS DIRECTORY FILE 1 NIL T NIL FILEDIRCASEARRAY)
THEN (SUBSTRING FILE (ADD1 (NCHARS DIRECTORY)))
ELSE FILE])
@@ -1023,7 +1023,7 @@
": ")
(IF (EQ (CAR X)
'Comments)
THEN (FOR CC (POS _ (POSITION T)) IN (CDR X)
THEN (FOR CC (POS (POSITION T)) IN (CDR X)
DO (IF (EQ CC T)
THEN (TERPRI T)
ELSE (PRINTOUT T .TAB0 POS CC)))
@@ -1163,7 +1163,7 @@
(* ;; "Returns the identifiers for commits in BRANCH1 but not in BUTNOTBRANCH2")
(GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"­" BUTNOTBRANCH2 "%"")
(GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"^" BUTNOTBRANCH2 "%"")
NIL NIL PROJECT])
(GIT-BRANCH-RELATIONS
@@ -1227,6 +1227,16 @@
then (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
else (SORT DATUM]
(RETURN (LIST SUPERSETS EQUALS])
(GIT-MODIFIED
[LAMBDA (PROJECT) (* ; "Edited 25-Dec-2025 13:39 by rmk")
(* ;;
 "A list of files that have been modified M or introduced but not committed ??. see git help status")
(for X POS in (GIT-COMMAND "git status --porcelain")
when (SETQ POS (OR (STRPOS " M " X NIL NIL NIL T)
(STRPOS "?? " X NIL NIL NIL T))) collect (SUBSTRING X POS])
)
@@ -1353,7 +1363,7 @@
(CL:WHEN (thereis B in BRANCHES suchthat (STRPOS "HEAD detached" B))
(PRINTOUT T "Execute %"git gc%" to eliminate a branch with a detached HEAD" T))
(CL:WHEN EXCLUDEMERGED
(SETQ BRANCHES (for B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES
(SETQ BRANCHES (for B (MAINBRANCH (GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES
when (EQUAL (GIT-COMMAND (CONCAT "git merge-base %"" B "%" %""
MAINBRANCH "%""))
(GIT-COMMAND (CONCAT "git rev-parse %"" B "%"")))
@@ -1392,11 +1402,11 @@
(CL:WHEN PIN?
[SETQ BRANCHES (APPEND BRANCHES '((" Pin menu" 'PinMenu])
(create MENU
TITLE _ (OR TITLE (CONCAT (LENGTH BRANCHES)
TITLE (OR TITLE (CONCAT (LENGTH BRANCHES)
" branches"))
ITEMS _ BRANCHES
MENUFONT _ DEFAULTFONT
WHENSELECTEDFN _ (FUNCTION GIT-BRANCH-WHENSELECTEDFN)))])
ITEMS BRANCHES
MENUFONT DEFAULTFONT
WHENSELECTEDFN (FUNCTION GIT-BRANCH-WHENSELECTEDFN)))])
(GIT-BRANCH-WHENSELECTEDFN
[LAMBDA (ITEM MENU BUTTON) (* ; "Edited 2-Oct-2025 23:08 by rmk")
@@ -1446,20 +1456,20 @@
eachtime [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] when (OR INCLUDEDRAFTS
(NOT DRAFT))
collect [SETQ PR (create PULLREQUEST
PRNUMBER _ (JSON-GET JSOBJ 'number)
PRNAME _ (JSON-GET JSOBJ 'headRefName)
PRDESCRIPTION _ (JSON-GET JSOBJ 'title)
PRSTATUS _ (CL:IF DRAFT
PRNUMBER (JSON-GET JSOBJ 'number)
PRNAME (JSON-GET JSOBJ 'headRefName)
PRDESCRIPTION (JSON-GET JSOBJ 'title)
PRSTATUS (CL:IF DRAFT
'D
(SELECTQ (MKATOM (JSON-GET JSOBJ 'reviewDecision))
(CHANGES¬REQUESTED
(CHANGES_REQUESTED
'C)
(REVIEW¬REQUIRED
(REVIEW_REQUIRED
" ")
'A))
PRPROJECT _ PROJECT
PRURL _ (JSON-GET JSOBJ 'url)
PRLOGIN _ (JSON-GET JSOBJ '(headRepositoryOwner login]
PRPROJECT PROJECT
PRURL (JSON-GET JSOBJ 'url)
PRLOGIN (JSON-GET JSOBJ '(headRepositoryOwner login]
(CL:WHEN (STRPOS ":" (fetch (PULLREQUEST PRNAME) of PR))
(* ;; "From Nick: Git commands to bring install and deal with the remotes:")
@@ -1510,8 +1520,8 @@
(LET ((RELATIONS (GIT-BRANCH-RELATIONS (for PR in PRS
collect (GITORIGIN (fetch PRNAME of PR)))
NIL T PROJECT)))
(SORT (for PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS))
(EQUALS _ (CADR RELATIONS)) in PRS
(SORT (for PR REL LABEL PRNAME STATUS (SUPERSETS (CAR RELATIONS))
(EQUALS (CADR RELATIONS)) in PRS
eachtime (SETQ PRNAME (fetch PRNAME of PR))
(SETQ LABEL (CONCAT "#" (fetch (PULLREQUEST PRNUMBER) of PR)
" "
@@ -1558,15 +1568,33 @@
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT T])
(GIT-MY-NEXT-BRANCH
[LAMBDA (PROJECT) (* ; "Edited 19-May-2022 14:08 by rmk")
[LAMBDA (PROJECT) (* ; "Edited 2-Mar-2026 14:00 by rmk")
(* ; "Edited 19-May-2022 14:08 by rmk")
(* ; "Edited 8-Jan-2022 09:43 by rmk")
(* ;; "Figures out the number of my next incremental branch would be. ")
(PACK* (GIT-INITIALS)
(ADD1 (OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH PROJECT)
PROJECT)
0])
(LET (PROJECTLIST PROJECTENTRY NEXTNUM)
(CL:WITH-OPEN-FILE (STRM "{LI}GIT-MY-CURRENT-BRANCH-NUMS;1" :DIRECTION :IO
:IF-DOES-NOT-EXIST :CREATE :IF-EXISTS :OVERWRITE)
(SETQ PROJECTLIST (CL:UNLESS (EQ 0 (GETEOFPTR STRM))
(READ STRM)))
(SETQ PROJECTENTRY (ASSOC (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
PROJECTLIST))
(CL:UNLESS PROJECTENTRY
(SETQ PROJECTENTRY (LIST (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
(OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH
PROJECT)
PROJECT)
0)))
(push PROJECTLIST PROJECTENTRY))
(SETQ NEXTNUM (ADD1 (CADR PROJECTENTRY)))
(RPLACA (CDR PROJECTENTRY)
NEXTNUM)
(SETFILEPTR STRM 0)
(PRINT PROJECTLIST STRM)
NEXTNUM])
(GIT-MY-BRANCHES
[LAMBDA (PROJECT EXCLUDEMERGED INITS) (* ; "Edited 19-May-2022 19:10 by rmk")
@@ -1647,14 +1675,14 @@
(CL:WHEN (STRPOS "fatal: " (CAR LINES)
1 NIL T)
(ERROR "Could not remove worktree for " BRANCH))
(* (DELFILE (CONCAT PATH "/.DS_Store"))
(* (DELFILE (CONCAT PATH "/.DSStore"))
 (GIT-COMMAND (CONCAT "rmdir " DIR) NIL
 NIL PROJECT))
BRANCH])
(GIT-LIST-WORKTREES
[LAMBDA NIL (* ; "Edited 12-Dec-2021 12:13 by rmk")
(* ; "Edited 19-Nov-2021 18:53 by rmk:")
[LAMBDA NIL (* ; "Edited 12-Dec-2021 12:13 by rmk")
(* ; "Edited 19-Nov-2021 18:53 by rmk:")
(* ;; "The git command tells us what the clone thinks about it, but then we look to see what is actually in our worktrees directory, to make sure that the subdirectory wasn't deleted in a wy that the clone didn't know about.")
@@ -1880,14 +1908,14 @@
(replace (CDENTRY INFO2) of CDE
with (create CDINFO
FULLNAME _ (CADR MAP)
DATE _ (CL:IF (EQ 'R (CADDR MAP))
FULLNAME (CADR MAP)
DATE (CL:IF (EQ 'R (CADDR MAP))
" <-"
" ==")
LENGTH _ ""
AUTHOR _ ""
TYPE _ ""
EOL _ ""))
LENGTH ""
AUTHOR ""
TYPE ""
EOL ""))
(replace (CDENTRY DATEREL) of CDE
with (CADDR MAP]
(TERPRI T)
@@ -1957,10 +1985,10 @@
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
"ALL subdirectories"
else SUBDIRS)))
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
(for SUBDIR TITLE CDVAL (WPROJ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
T)))
(NENTRIES _ 0)
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
(NENTRIES 0)
(BRANCH2 (GIT-WHICH-BRANCH PROJECT T))
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
(BKSYSBUF " ") inside SUBDIRS
collect (TERPRI T)
@@ -2132,12 +2160,12 @@
NIL]
(CL:WHEN (OR COPYITEM COMPAREITEMS)
(SELECTQ (MENU (CREATE MENU
TITLE _ (CONCAT (WINDOWPROP WINDOW 'SUBDIR)
TITLE (CONCAT (WINDOWPROP WINDOW 'SUBDIR)
"/"
(FETCH MATCHNAME OF CDENTRY))
ITEMS _ (APPEND COPYITEM COMPAREITEMS)
MENUFONT _ FONT
MENUTITLEFONT _ FONT))
ITEMS (APPEND COPYITEM COMPAREITEMS)
MENUFONT FONT
MENUTITLEFONT FONT))
(TOGIT (CL:WHEN (TOGIT (FETCH (CDINFO FULLNAME) OF INFO1)
WINDOW)
(IMAGEOBJPROP OBJ 'COPIED T)
@@ -2162,18 +2190,18 @@
NIL)))])
(GIT-CD-LABELFN
[LAMBDA (FILE1 FILE2 USERDATA) (* ; "Edited 5-Jan-2022 15:10 by rmk")
(* ; "Edited 16-Dec-2021 12:25 by rmk")
[LAMBDA (FILE1 FILE2 USERDATA) (* ; "Edited 5-Jan-2022 15:10 by rmk")
(* ; "Edited 16-Dec-2021 12:25 by rmk")
(* ; "Edited 13-Dec-2021 22:13 by rmk")
(DECLARE (USEDFREE CDVALUE))
(LET (NC B LABEL1 LABEL2)
(CL:WHEN (SETQ NC (FETCH NCDIR OF (FETCH CDMAXNC1 OF CDVALUE)))
(SETQ LABEL1 (SLASHIT (SUBSTRING FILE1 (ADD1 NC))
(SETQ LABEL1 (SLASHIT (SUBSTRING FILE1 (ADD1 NC))
T))
(CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH1))
(SETQ LABEL1 (CONCAT B "/" LABEL1))))
(CL:WHEN (SETQ NC (FETCH NCDIR OF (FETCH CDMAXNC2 OF CDVALUE)))
(SETQ LABEL2 (SLASHIT (SUBSTRING FILE2 (ADD1 NC))
(SETQ LABEL2 (SLASHIT (SUBSTRING FILE2 (ADD1 NC))
T))
(CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH2))
(SETQ LABEL2 (CONCAT B "/" LABEL2))))
@@ -2367,15 +2395,15 @@
NIL])
(GIT-RESULT-TO-LINES
[LAMBDA (FILE ALL) (* ; "Edited 31-Mar-2025 15:19 by rmk")
[LAMBDA (FILE ALL) (* ; "Edited 25-Feb-2026 23:24 by rmk")
(* ; "Edited 31-Mar-2025 15:19 by rmk")
(* ; "Edited 16-Jul-2022 22:21 by rmk")
(* ;; "Suppress .git lines unless ALL SYSTEM-EXTERNALFORMAT may make the wrong guess, but at least we ensure here that lines get broken.")
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT (LIST (SYSTEM-EXTERNALFORMAT)
'ANY))
(bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P
NIL :EOF-VALUE NIL))
(bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM NIL))
(OR ALL (NOT (STRPOS ".git" LINE 1]
collect LINE])
@@ -2394,32 +2422,33 @@
(PUTPROPS GITFNS FILETYPE :TCOMPL)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4196 21002 (GIT-CLONEP 4206 . 5637) (GIT-INIT 5639 . 6269) (GIT-MAKE-PROJECT 6271 .
14060) (GIT-GET-PROJECT 14062 . 15987) (GIT-PUT-PROJECT-FIELD 15989 . 17630) (GIT-PROJECT-PATH 17632
. 18676) (FIND-ANCESTOR-DIRECTORY 18678 . 19027) (GIT-FIND-CLONE 19029 . 20110) (GIT-MAINBRANCH 20112
. 20507) (GIT-MAINBRANCH? 20509 . 21000)) (26465 31394 (PRC-COMMAND 26475 . 31392)) (31450 34238 (
ALLSUBDIRS 31460 . 32746) (MEDLEYSUBDIRS 32748 . 33441) (GITSUBDIRS 33443 . 34236)) (34239 36640 (
TOGIT 34249 . 35655) (FROMGIT 35657 . 36638)) (36641 39644 (MYMEDLEYSUBDIR 36651 . 37107) (GITSUBDIR
37109 . 37552) (STRIPDIR 37554 . 37925) (STRIPHOST 37927 . 38167) (STRIPNAME 38169 . 38922) (
STRIPWHERE 38924 . 39642)) (39645 41880 (GFILE4MFILE 39655 . 40351) (MFILE4GFILE 40353 . 40922) (
GIT-REPO-FILENAME 40924 . 41878)) (41929 52184 (GIT-COMMIT 41939 . 42765) (GIT-PUSH 42767 . 43527) (
GIT-PULL 43529 . 44281) (GIT-APPROVAL 44283 . 44632) (GIT-GET-FILE 44634 . 46549) (GIT-FILE-EXISTS?
46551 . 46825) (GIT-REMOTE-UPDATE 46827 . 47662) (GIT-REMOTE-ADD 47664 . 47971) (GIT-FILE-DATE 47973
. 49020) (GIT-FILE-HISTORY 49022 . 50956) (GIT-PRINT-FILE-HISTORY 50958 . 52008) (GIT-FETCH 52010 .
52182)) (52214 63694 (GIT-BRANCH-DIFF 52224 . 59113) (GIT-COMMIT-DIFFS 59115 . 60006) (
GIT-BRANCH-RELATIONS 60008 . 63692)) (63739 82478 (GIT-BRANCH-NUM 63749 . 64322) (GIT-CHECKOUT 64324
. 65610) (GIT-WHICH-BRANCH 65612 . 66019) (GIT-MAKE-BRANCH 66021 . 68600) (GIT-BRANCHES 68602 . 71197
) (GIT-BRANCH-EXISTS? 71199 . 72070) (GIT-PICK-BRANCH 72072 . 72562) (GIT-BRANCH-MENU 72564 . 73445) (
GIT-BRANCH-WHENSELECTEDFN 73447 . 74986) (GIT-PULL-REQUESTS 74988 . 78859) (GIT-SHORT-BRANCH-NAME
78861 . 79152) (GIT-LONG-NAME 79154 . 79471) (GIT-PRC-BRANCHES 79473 . 82476)) (82508 85956 (
GIT-MY-CURRENT-BRANCH 82518 . 82888) (GIT-MY-BRANCHP 82890 . 83508) (GIT-MY-NEXT-BRANCH 83510 . 84004)
(GIT-MY-BRANCHES 84006 . 85954)) (86002 90077 (GIT-ADD-WORKTREE 86012 . 87619) (GIT-REMOVE-WORKTREE
87621 . 88551) (GIT-LIST-WORKTREES 88553 . 89357) (WORKTREEDIR 89359 . 90075)) (90125 123133 (
GIT-GET-DIFFERENT-FILES 90135 . 97043) (GIT-BRANCHES-COMPARE-DIRECTORIES 97045 . 104672) (
GIT-WORKING-COMPARE-DIRECTORIES 104674 . 110470) (GIT-COMPARE-WORKTREE 110472 . 114450) (
GITCDOBJBUTTONFN 114452 . 118942) (GIT-CD-LABELFN 118944 . 120026) (GIT-CD-MENUFN 120028 . 121114) (
GIT-WORKING-COMPARE-FILES 121116 . 121736) (GIT-BRANCHES-COMPARE-FILES 121738 . 122902) (
GIT-PR-COMPARE 122904 . 123131)) (123203 131526 (CDGITDIR 123213 . 123900) (GIT-COMMAND 123902 .
125460) (GITORIGIN 125462 . 126159) (GIT-INITIALS 126161 . 126465) (GIT-COMMAND-TO-FILE 126467 .
129952) (GIT-RESULT-TO-LINES 129954 . 130859) (STRIPLOCAL 130861 . 131524)))))
(FILEMAP (NIL (4178 21056 (GIT-CLONEP 4188 . 5619) (GIT-INIT 5621 . 6251) (GIT-MAKE-PROJECT 6253 .
14110) (GIT-GET-PROJECT 14112 . 16037) (GIT-PUT-PROJECT-FIELD 16039 . 17680) (GIT-PROJECT-PATH 17682
. 18726) (FIND-ANCESTOR-DIRECTORY 18728 . 19079) (GIT-FIND-CLONE 19081 . 20164) (GIT-MAINBRANCH 20166
. 20561) (GIT-MAINBRANCH? 20563 . 21054)) (26519 31448 (PRC-COMMAND 26529 . 31446)) (31504 34292 (
ALLSUBDIRS 31514 . 32800) (MEDLEYSUBDIRS 32802 . 33495) (GITSUBDIRS 33497 . 34290)) (34293 36698 (
TOGIT 34303 . 35711) (FROMGIT 35713 . 36696)) (36699 39709 (MYMEDLEYSUBDIR 36709 . 37165) (GITSUBDIR
37167 . 37610) (STRIPDIR 37612 . 37990) (STRIPHOST 37992 . 38232) (STRIPNAME 38234 . 38987) (
STRIPWHERE 38989 . 39707)) (39710 41945 (GFILE4MFILE 39720 . 40416) (MFILE4GFILE 40418 . 40987) (
GIT-REPO-FILENAME 40989 . 41943)) (41994 52251 (GIT-COMMIT 42004 . 42830) (GIT-PUSH 42832 . 43592) (
GIT-PULL 43594 . 44346) (GIT-APPROVAL 44348 . 44697) (GIT-GET-FILE 44699 . 46614) (GIT-FILE-EXISTS?
46616 . 46890) (GIT-REMOTE-UPDATE 46892 . 47727) (GIT-REMOTE-ADD 47729 . 48036) (GIT-FILE-DATE 48038
. 49085) (GIT-FILE-HISTORY 49087 . 51021) (GIT-PRINT-FILE-HISTORY 51023 . 52075) (GIT-FETCH 52077 .
52249)) (52281 64233 (GIT-BRANCH-DIFF 52291 . 59180) (GIT-COMMIT-DIFFS 59182 . 60073) (
GIT-BRANCH-RELATIONS 60075 . 63759) (GIT-MODIFIED 63761 . 64231)) (64278 83045 (GIT-BRANCH-NUM 64288
. 64861) (GIT-CHECKOUT 64863 . 66149) (GIT-WHICH-BRANCH 66151 . 66558) (GIT-MAKE-BRANCH 66560 . 69139
) (GIT-BRANCHES 69141 . 71738) (GIT-BRANCH-EXISTS? 71740 . 72611) (GIT-PICK-BRANCH 72613 . 73103) (
GIT-BRANCH-MENU 73105 . 73994) (GIT-BRANCH-WHENSELECTEDFN 73996 . 75535) (GIT-PULL-REQUESTS 75537 .
79422) (GIT-SHORT-BRANCH-NAME 79424 . 79715) (GIT-LONG-NAME 79717 . 80034) (GIT-PRC-BRANCHES 80036 .
83043)) (83075 87829 (GIT-MY-CURRENT-BRANCH 83085 . 83455) (GIT-MY-BRANCHP 83457 . 84075) (
GIT-MY-NEXT-BRANCH 84077 . 85877) (GIT-MY-BRANCHES 85879 . 87827)) (87875 91959 (GIT-ADD-WORKTREE
87885 . 89492) (GIT-REMOVE-WORKTREE 89494 . 90426) (GIT-LIST-WORKTREES 90428 . 91239) (WORKTREEDIR
91241 . 91957)) (92007 125045 (GIT-GET-DIFFERENT-FILES 92017 . 98925) (
GIT-BRANCHES-COMPARE-DIRECTORIES 98927 . 106566) (GIT-WORKING-COMPARE-DIRECTORIES 106568 . 112370) (
GIT-COMPARE-WORKTREE 112372 . 116350) (GITCDOBJBUTTONFN 116352 . 120850) (GIT-CD-LABELFN 120852 .
121938) (GIT-CD-MENUFN 121940 . 123026) (GIT-WORKING-COMPARE-FILES 123028 . 123648) (
GIT-BRANCHES-COMPARE-FILES 123650 . 124814) (GIT-PR-COMPARE 124816 . 125043)) (125115 133446 (CDGITDIR
125125 . 125812) (GIT-COMMAND 125814 . 127372) (GITORIGIN 127374 . 128071) (GIT-INITIALS 128073 .
128377) (GIT-COMMAND-TO-FILE 128379 . 131864) (GIT-RESULT-TO-LINES 131866 . 132779) (STRIPLOCAL 132781
. 133444)))))
STOP

Binary file not shown.

View File

@@ -1,22 +1,21 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
(FILECREATED "27-Jan-2025 08:49:34" {WMEDLEY}<lispusers>VERSIONDEFS.;12 5880
(FILECREATED " 7-Mar-2026 22:55:43" {WMEDLEY}<lispusers>VERSIONDEFS.;18 6534
:EDIT-BY rmk
:CHANGES-TO (FNS GETVINFO)
:PREVIOUS-DATE "12-Dec-2024 15:07:45" {WMEDLEY}<lispusers>VERSIONDEFS.;11)
:PREVIOUS-DATE " 6-Mar-2026 22:47:25" {WMEDLEY}<lispusers>VERSIONDEFS.;17)
(PRETTYCOMPRINT VERSIONDEFSCOMS)
(RPAQQ VERSIONDEFSCOMS [(FNS FINDFILEVERSION GETVINFO VERSIONP)
(FNS EDV DFV)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DFV EDV)
(NLAML)
(LAMA])
(RPAQQ VERSIONDEFSCOMS
[(FNS FINDFILEVERSION GETVINFO VERSIONP)
(FNS EDV DFV)
(PROP ARGNAMES EDV DFV)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DFV EDV)
(NLAML)
(LAMA])
(DEFINEQ
(FINDFILEVERSION
@@ -119,16 +118,26 @@
(CAR VINFO])
(DFV
[NLAMBDA ARGS (* ; "Edited 6-Dec-2024 21:29 by rmk")
[NLAMBDA ARGS (* ; "Edited 6-Mar-2026 22:42 by rmk")
(* ; "Edited 6-Dec-2024 21:29 by rmk")
(* ; "Edited 2-Dec-2024 00:08 by rmk")
(SETQ ARGS (MKLIST ARGS))
(APPLY (FUNCTION EDV)
(LIST (POP ARGS)
NIL
(POP ARGS)
(POP ARGS)
(POP ARGS])
(LET ((NAME (POP ARGS))) (* ; "If FNS and FUNCTIONS, show both")
(CL:WHEN (HASDEF NAME 'FUNCTIONS '?)
(APPLY (FUNCTION EDV)
(LIST NAME 'FUNCTIONS (POP ARGS)
(POP ARGS)
(POP ARGS))))
(CL:WHEN (HASDEF NAME 'FNS '?)
(APPLY (FUNCTION EDV)
(LIST NAME 'FNS (POP ARGS)
(POP ARGS)
(POP ARGS))))])
)
(PUTPROPS EDV ARGNAMES (NAME TYPE FILE VERSION DIRLST . VINFO))
(PUTPROPS DFV ARGNAMES (NAME FILE VERSION DIRLST . VINFO))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DFV EDV)
@@ -138,6 +147,6 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (671 4570 (FINDFILEVERSION 681 . 2128) (GETVINFO 2130 . 4253) (VERSIONP 4255 . 4568)) (
4571 5717 (EDV 4581 . 5281) (DFV 5283 . 5715)))))
(FILEMAP (NIL (706 4605 (FINDFILEVERSION 716 . 2163) (GETVINFO 2165 . 4288) (VERSIONP 4290 . 4603)) (
4606 6230 (EDV 4616 . 5316) (DFV 5318 . 6228)))))
STOP

Binary file not shown.

Binary file not shown.

View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "25-Feb-2026 15:03:24" {WMEDLEY}<sources>BOOTSTRAP.;69 47041
(FILECREATED " 2-Mar-2026 12:03:05" {WMEDLEY}<sources>BOOTSTRAP.;71 47856
:EDIT-BY rmk
:CHANGES-TO (FNS MAKE-DEFINE-FILE-INFO-ENV READ-READER-ENVIRONMENT)
:CHANGES-TO (FNS READ-READER-ENVIRONMENT)
:PREVIOUS-DATE "25-Feb-2026 13:52:00" {WMEDLEY}<sources>BOOTSTRAP.;66)
:PREVIOUS-DATE "25-Feb-2026 15:03:24" {WMEDLEY}<sources>BOOTSTRAP.;69)
(PRETTYCOMPRINT BOOTSTRAPCOMS)
@@ -800,7 +800,9 @@
(TERPRI STREAM)))])
(READ-READER-ENVIRONMENT
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 25-Feb-2026 14:15 by rmk")
[LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 2-Mar-2026 12:03 by rmk")
(* ; "Edited 1-Mar-2026 10:49 by rmk")
(* ; "Edited 25-Feb-2026 14:15 by rmk")
(* ; "Edited 26-Sep-2021 23:31 by rmk:")
(* ;; "Starting environment is the old interlisp file, just for the seprchar scans.")
@@ -809,42 +811,49 @@
(* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE")
(CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*))
(LET ((START (GETFILEPTR STREAM))
ARGS
(ENV DEFAULTENV)
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF *OLD-INTERLISP-READ-ENVIRONMENT*)))
(DECLARE (SPECVARS *READTABLE*))
(SETFILEPTR STREAM 0) (* ; "Hope we are RANDACCESSP")
(SELCHARQ (SKIPSEPRCODES STREAM)
(";" (* ; "Assume it's a common lisp file")
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
(if (\GETSTREAM STREAM 'INPUT T)
then (CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*))
(LET ((START (GETFILEPTR STREAM))
ARGS
(ENV DEFAULTENV)
(*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF
*OLD-INTERLISP-READ-ENVIRONMENT*
)))
(DECLARE (SPECVARS *READTABLE*))
(SETFILEPTR STREAM 0) (* ; "Hope we are RANDACCESSP")
(SELCHARQ (SKIPSEPRCODES STREAM)
(";" (* ; "Assume it's a common lisp file")
(\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
*COMMON-LISP-READ-ENVIRONMENT*
))
*COMMON-LISP-READ-ENVIRONMENT*)
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
))
*COMMON-LISP-READ-ENVIRONMENT*)
("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF
*DEFINE-FILE-INFO-ENV*
)) (* ;
))(* ;
 "Should we reset the format if we fail?")
(READCCODE STREAM)
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
(if (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
then
(* ;;
(READCCODE STREAM)
(WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV*
(if (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM))
then
(* ;;
 "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.")
(SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")")
STREAM))
(SETQ ENV (\DO-DEFINE-FILE-INFO STREAM ARGS))
else (SETFILEPTR STREAM START))
(SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")")
STREAM))
(SETQ ENV (\DO-DEFINE-FILE-INFO STREAM ARGS))
else (SETFILEPTR STREAM START))
(* ;;
(* ;;
 "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.")
(CL:IF (AND RETURNFORM ARGS)
(CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS))
ENV)))
DEFAULTENV])
(CL:IF (AND RETURNFORM ARGS)
(CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS))
ENV)))
DEFAULTENV))
else (CL:WITH-OPEN-FILE (STRM (OR (FINDFILE STREAM T)
STREAM)
:DIRECTION :INPUT)
(READ-READER-ENVIRONMENT STRM DEFAULTENV RETURNFORM])
(MAKE-DEFINE-FILE-INFO-ENV
[LAMBDA NIL (* ; "Edited 25-Feb-2026 15:03 by rmk")
@@ -969,13 +978,13 @@
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4621 14293 (GETPROP 4631 . 5203) (SETATOMVAL 5205 . 5334) (RPAQQ 5336 . 5389) (RPAQ
5391 . 5703) (RPAQ? 5705 . 6075) (MOVD 6077 . 7941) (MOVD? 7943 . 8373) (SELECTQ 8375 . 8562) (
SELECTQ1 8564 . 8906) (NCONC1 8908 . 9104) (PUTPROP 9106 . 10590) (PROPNAMES 10592 . 10783) (ADDPROP
10785 . 12848) (REMPROP 12850 . 13704) (MEMB 13706 . 13965) (CLOSEF? 13967 . 14291)) (14366 34343 (
LOAD 14376 . 15545) (\LOAD-STREAM 15547 . 28034) (FILECREATED 28036 . 29454) (FILECREATED1 29456 .
30564) (PRETTYCOMPRINT 30566 . 31051) (BOOTSTRAP-NAMEFIELD 31053 . 32013) (PUTPROPS 32015 . 32383) (
DECLARE%: 32385 . 32517) (DECLARE%:1 32519 . 33391) (ROOTFILENAME 33393 . 34341)) (34381 44987 (
DEFINE-FILE-INFO 34391 . 34826) (\DO-DEFINE-FILE-INFO 34828 . 38971) (PRINT-READER-ENVIRONMENT 38973
. 40725) (READ-READER-ENVIRONMENT 40727 . 43553) (MAKE-DEFINE-FILE-INFO-ENV 43555 . 44985)))))
(FILEMAP (NIL (4595 14267 (GETPROP 4605 . 5177) (SETATOMVAL 5179 . 5308) (RPAQQ 5310 . 5363) (RPAQ
5365 . 5677) (RPAQ? 5679 . 6049) (MOVD 6051 . 7915) (MOVD? 7917 . 8347) (SELECTQ 8349 . 8536) (
SELECTQ1 8538 . 8880) (NCONC1 8882 . 9078) (PUTPROP 9080 . 10564) (PROPNAMES 10566 . 10757) (ADDPROP
10759 . 12822) (REMPROP 12824 . 13678) (MEMB 13680 . 13939) (CLOSEF? 13941 . 14265)) (14340 34317 (
LOAD 14350 . 15519) (\LOAD-STREAM 15521 . 28008) (FILECREATED 28010 . 29428) (FILECREATED1 29430 .
30538) (PRETTYCOMPRINT 30540 . 31025) (BOOTSTRAP-NAMEFIELD 31027 . 31987) (PUTPROPS 31989 . 32357) (
DECLARE%: 32359 . 32491) (DECLARE%:1 32493 . 33365) (ROOTFILENAME 33367 . 34315)) (34355 45802 (
DEFINE-FILE-INFO 34365 . 34800) (\DO-DEFINE-FILE-INFO 34802 . 38945) (PRINT-READER-ENVIRONMENT 38947
. 40699) (READ-READER-ENVIRONMENT 40701 . 44368) (MAKE-DEFINE-FILE-INFO-ENV 44370 . 45800)))))
STOP

Binary file not shown.

View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "11-Sep-2025 16:49:07" {WMEDLEY}<sources>COREIO.;18 56903
(FILECREATED "28-Feb-2026 12:09:38" {WMEDLEY}<sources>COREIO.;20 57201
:EDIT-BY rmk
:CHANGES-TO (FNS \CORE.DIRECTORYNAMEP)
:PREVIOUS-DATE " 5-Jun-2022 00:14:07" {WMEDLEY}<sources>COREIO.;17)
:PREVIOUS-DATE "11-Sep-2025 16:49:07" {WMEDLEY}<sources>COREIO.;18)
(PRETTYCOMPRINT COREIOCOMS)
@@ -89,6 +89,8 @@
(\CORE.DIRECTORYNAMEP
[LAMBDA (DIRNAME DEV)
(* ;; "Edited 28-Feb-2026 12:08 by rmk")
(* ;; "Edited 11-Sep-2025 16:48 by rmk")
(* ;; "Edited 18-Jan-2022 11:17 by rmk")
@@ -106,18 +108,21 @@
(* ;; "Returns NIL for a DIRNAME of just {CORE}, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.")
[LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY]
(CL:WHEN DIR
(SETQ DIR (CONCAT DIR ">"))
(LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY]
(if DIR
then (SETQ DIR (CONCAT DIR ">"))
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
FIRST (CL:UNLESS (EQ DIRPOS 1)
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
IN (CDR (FETCH COREDIRECTORY OF DEV))
WHEN (STRPOS DIRNAME (CAR ENTRY)
1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T)))])])
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
FIRST (CL:UNLESS (EQ DIRPOS 1)
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
IN (CDR (FETCH COREDIRECTORY OF DEV))
WHEN (STRPOS DIRNAME (CAR ENTRY)
1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T))
else (* ;
 "Top level: does the device exist at al. The cd {CORE}case")
T)))])
(\CORE.FINDPAGE
[LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32")
@@ -997,16 +1002,16 @@
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1572 46115 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) (
\CORE.DIRECTORYNAMEP 4345 . 5838) (\CORE.FINDPAGE 5840 . 9069) (\CORE.GENERATEFILES 9071 . 11658) (
\CORE.NEXTFILEFN 11660 . 12159) (\CORE.FILEINFOFN 12161 . 12390) (\CORE.GETFILEHANDLE 12392 . 14546) (
\CORE.GETFILEINFO 14548 . 15511) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15513 . 17050) (\CORE.GETFILENAME
17052 . 19341) (\CORE.GETINFOBLOCK 19343 . 21966) (\CORE.NAMESCAN 21968 . 23515) (\CORE.NAMESEGMENT
23517 . 23954) (\CORE.OPENFILE 23956 . 27348) (\COREFILE.SETPARAMETERS 27350 . 29531) (
\CORE.PACKFILENAME 29533 . 29928) (\CORE.RELEASEPAGES 29930 . 30531) (\CORE.SETFILEPTR 30533 . 31632)
(\CORE.UPDATEOF 31634 . 33263) (\CORE.BACKFILEPTR 33265 . 35473) (\CORE.SETEOFPTR 35475 . 37344) (
\CORE.SETACCESSTIME 37346 . 37971) (\CORE.SETFILEINFO 37973 . 40275) (\CORE.GETNEXTBUFFER 40277 .
44233) (\CORE.UNPACKFILENAME 44235 . 46113)) (46116 49749 (COREDEVICE 46126 . 46297) (
\CREATECOREDEVICE 46299 . 49747)) (49750 52164 (\NODIRCOREFDEV 49760 . 50357) (\NODIRCORE.OPENFILE
50359 . 52162)))))
(FILEMAP (NIL (1572 46413 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) (
\CORE.DIRECTORYNAMEP 4345 . 6136) (\CORE.FINDPAGE 6138 . 9367) (\CORE.GENERATEFILES 9369 . 11956) (
\CORE.NEXTFILEFN 11958 . 12457) (\CORE.FILEINFOFN 12459 . 12688) (\CORE.GETFILEHANDLE 12690 . 14844) (
\CORE.GETFILEINFO 14846 . 15809) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15811 . 17348) (\CORE.GETFILENAME
17350 . 19639) (\CORE.GETINFOBLOCK 19641 . 22264) (\CORE.NAMESCAN 22266 . 23813) (\CORE.NAMESEGMENT
23815 . 24252) (\CORE.OPENFILE 24254 . 27646) (\COREFILE.SETPARAMETERS 27648 . 29829) (
\CORE.PACKFILENAME 29831 . 30226) (\CORE.RELEASEPAGES 30228 . 30829) (\CORE.SETFILEPTR 30831 . 31930)
(\CORE.UPDATEOF 31932 . 33561) (\CORE.BACKFILEPTR 33563 . 35771) (\CORE.SETEOFPTR 35773 . 37642) (
\CORE.SETACCESSTIME 37644 . 38269) (\CORE.SETFILEINFO 38271 . 40573) (\CORE.GETNEXTBUFFER 40575 .
44531) (\CORE.UNPACKFILENAME 44533 . 46411)) (46414 50047 (COREDEVICE 46424 . 46595) (
\CREATECOREDEVICE 46597 . 50045)) (50048 52462 (\NODIRCOREFDEV 50058 . 50655) (\NODIRCORE.OPENFILE
50657 . 52460)))))
STOP

Binary file not shown.