github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-17 17:12:43 +00:00
Code Issues Projects Releases Wiki Activity

Resolved merge conflicts by favoring main branch

Browse Source
This commit is contained in:
Frank Halasz
2026-01-18 13:30:41 -08:00
parent 87482ba788 65c482bc06
commit 5a79b56a4f
551 changed files with 15068 additions and 5829 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
sources/ADIR
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 6-Feb-2025 17:48:54" {DSK}<home>frank>il>medley>sources>ADIR.;6 70091
(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}<sources>ADIR.;62 70135
:CHANGES-TO (FNS INTERPRET.REM.CM)
:EDIT-BY rmk
:PREVIOUS-DATE "20-Jan-2025 13:37:28" {DSK}<home>frank>il>medley>sources>ADIR.;3)
:CHANGES-TO (MACROS \UPF.EXTRACT)
:PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}<sources>ADIR.;61)
(PRETTYCOMPRINT ADIRCOMS)
@@ -742,7 +744,8 @@
OFFST _ STARTOFFSET
LENGTH _ (ADD1 (IDIFFERENCE ENDOFFSET STARTOFFSET))
BASE _ $$BASE
READONLY _ $$READONLY)))
READONLY _ $$READONLY
FATSTRINGP _ $$FATP)))
(PUTPROPS \UPF.DIRTYPE MACRO [(DIRSTART) (* ; "Edited 20-Apr-2022 20:14 by rmk")
(SELCHARQ (\GETBASECHAR $$FATP $$BASE DIRSTART)
@@ -1279,14 +1282,14 @@
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3183 16010 (DELFILE 3193 . 3354) (FULLNAME 3356 . 3723) (INFILE 3725 . 3984) (INFILEP
3986 . 4121) (IOFILE 4123 . 4374) (OPENFILE 4376 . 4679) (OPENSTREAM 4681 . 9021) (OUTFILE 9023 . 9285
) (OUTFILEP 9287 . 9423) (RENAMEFILE 9425 . 9731) (SIMPLE.FINDFILE 9733 . 10143) (VMEMSIZE 10145 .
10312) (\COPYSYS 10314 . 14605) (\FLUSHVM 14607 . 15679) (\LOGOUT0 15681 . 16008)) (16509 41169 (
UNPACKFILENAME.STRING 16519 . 38355) (\UPF.DIRECTORY 38357 . 41167)) (42697 45003 (UNPACKFILENAME
42707 . 42893) (LASTCHPOS 42895 . 43589) (FILENAMEFIELD 43591 . 43885) (FILENAMEFIELD.STRING 43887 .
44291) (PACKFILENAME 44293 . 44636) (PACKFILENAME.STRING 44638 . 45001)) (59473 60386 (
FILEDIRCASEARRAY 59483 . 60384)) (60553 67850 (LOGOUT 60563 . 61608) (MAKESYS 61610 . 63239) (SYSOUT
63241 . 64793) (SAVEVM 64795 . 65595) (HERALD 65597 . 65757) (INTERPRET.REM.CM 65759 . 67473) (
\USEREVENT 67475 . 67848)) (68032 69759 (USERNAME 68042 . 68998) (SETUSERNAME 69000 . 69757)))))
(FILEMAP (NIL (3170 15997 (DELFILE 3180 . 3341) (FULLNAME 3343 . 3710) (INFILE 3712 . 3971) (INFILEP
3973 . 4108) (IOFILE 4110 . 4361) (OPENFILE 4363 . 4666) (OPENSTREAM 4668 . 9008) (OUTFILE 9010 . 9272
) (OUTFILEP 9274 . 9410) (RENAMEFILE 9412 . 9718) (SIMPLE.FINDFILE 9720 . 10130) (VMEMSIZE 10132 .
10299) (\COPYSYS 10301 . 14592) (\FLUSHVM 14594 . 15666) (\LOGOUT0 15668 . 15995)) (16496 41156 (
UNPACKFILENAME.STRING 16506 . 38342) (\UPF.DIRECTORY 38344 . 41154)) (42741 45047 (UNPACKFILENAME
42751 . 42937) (LASTCHPOS 42939 . 43633) (FILENAMEFIELD 43635 . 43929) (FILENAMEFIELD.STRING 43931 .
44335) (PACKFILENAME 44337 . 44680) (PACKFILENAME.STRING 44682 . 45045)) (59517 60430 (
FILEDIRCASEARRAY 59527 . 60428)) (60597 67894 (LOGOUT 60607 . 61652) (MAKESYS 61654 . 63283) (SYSOUT
63285 . 64837) (SAVEVM 64839 . 65639) (HERALD 65641 . 65801) (INTERPRET.REM.CM 65803 . 67517) (
\USEREVENT 67519 . 67892)) (68076 69803 (USERNAME 68086 . 69042) (SETUSERNAME 69044 . 69801)))))
STOP

BIN
sources/ADIR.LCOM
View File

Binary file not shown.

41
sources/AINTERRUPT
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "31-Mar-2024 09:38:10" |{DSK}<home>larry>il>medley>sources>AINTERRUPT.;7| 41133
(FILECREATED "12-Nov-2025 11:10:44" |{WMEDLEY}<sources>AINTERRUPT.;4| 41235
:EDIT-BY "lmm"
:EDIT-BY |rmk|
:CHANGES-TO (VARS AINTERRUPTCOMS)
:PREVIOUS-DATE "31-Mar-2024 09:27:57" |{DSK}<home>larry>il>medley>sources>AINTERRUPT.;5|)
:PREVIOUS-DATE "31-Mar-2024 09:38:10" |{WMEDLEY}<sources>AINTERRUPT.;3|)
(PRETTYCOMPRINT AINTERRUPTCOMS)
@@ -22,8 +22,8 @@
(5 ERROR MOUSE)
(7 HELP T)
(16 PRINTLEVEL)
(20 (CONTROL-T))
(127 RUBOUT T)))))
(20 (CONTROL-T))))))
(* \; "RMK2025: Removed (127 RUBOUT T)")
(GLOBALVARS LISPINTERRUPTS)
(COMS
(* |;;| "^T this is actually not very useful any more, and the percentages are wrong")
@@ -538,14 +538,17 @@
(prog1 \\interruptable (setq \\interruptable flag))))
)
(RPAQ? LISPINTERRUPTS
'((LISPINTERRUPTS (2 BREAK MOUSE)
(4 RESET MOUSE)
(5 ERROR MOUSE)
(7 HELP T)
(16 PRINTLEVEL)
(20 (CONTROL-T))
(127 RUBOUT T))))
(RPAQ? LISPINTERRUPTS '((LISPINTERRUPTS (2 BREAK MOUSE)
(4 RESET MOUSE)
(5 ERROR MOUSE)
(7 HELP T)
(16 PRINTLEVEL)
(20 (CONTROL-T)))))
(* \; "RMK2025: Removed (127 RUBOUT T)")
(DECLARE\: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS LISPINTERRUPTS)
@@ -803,10 +806,10 @@ DONTCOPY
(INTCHAR T)
)
(DECLARE\: DONTCOPY
(FILEMAP (NIL (2924 29142 (INTCHAR 2934 . 7957) (INTERRUPTCHAR 7959 . 8233) (INTERRUPTED 8235 . 15814)
(LISPINTERRUPTS 15816 . 16343) (\\DOHELPINTERRUPT 16345 . 17243) (\\DOHELPINTERRUPT1 17245 . 18643) (
\\DOINTERRUPTHERE 18645 . 19825) (\\PROC.FINDREALFRAME 19827 . 20631) (\\SETPRINTLEVEL 20633 . 22585)
(\\SETRECLAIMMIN 22587 . 23460) (GETINTERRUPT 23462 . 24818) (CURRENTINTERRUPTS 24820 . 25030) (
SETINTERRUPT 25032 . 27010) (RESET.INTERRUPTS 27012 . 28969) (INTERRUPTABLE 28971 . 29140)) (29562
35546 (CONTROL-T 29572 . 35013) (\\CONTROL-T.PRINTRATIO 35015 . 35544)))))
(FILEMAP (NIL (2939 29157 (INTCHAR 2949 . 7972) (INTERRUPTCHAR 7974 . 8248) (INTERRUPTED 8250 . 15829)
(LISPINTERRUPTS 15831 . 16358) (\\DOHELPINTERRUPT 16360 . 17258) (\\DOHELPINTERRUPT1 17260 . 18658) (
\\DOINTERRUPTHERE 18660 . 19840) (\\PROC.FINDREALFRAME 19842 . 20646) (\\SETPRINTLEVEL 20648 . 22600)
(\\SETRECLAIMMIN 22602 . 23475) (GETINTERRUPT 23477 . 24833) (CURRENTINTERRUPTS 24835 . 25045) (
SETINTERRUPT 25047 . 27025) (RESET.INTERRUPTS 27027 . 28984) (INTERRUPTABLE 28986 . 29155)) (29664
35648 (CONTROL-T 29674 . 35115) (\\CONTROL-T.PRINTRATIO 35117 . 35646)))))
STOP

BIN
sources/AINTERRUPT.LCOM
View File

Binary file not shown.

35
sources/AOFD
View File

@@ -1,10 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-May-2023 08:29:55" {DSK}<home>larry>il>medley>sources>AOFD.;5 36263
(FILECREATED "24-Apr-2025 21:46:04" {WMEDLEY}<sources>AOFD.;10 36381
:EDIT-BY "lmm"
:EDIT-BY rmk
:PREVIOUS-DATE "17-May-2023 08:05:56" {DSK}<home>larry>il>medley>sources>AOFD.;4)
:CHANGES-TO (FNS MAKE-STRING-FORMAT)
:PREVIOUS-DATE "17-May-2023 08:29:55" {WMEDLEY}<sources>AOFD.;9)
(PRETTYCOMPRINT AOFDCOMS)
@@ -558,9 +560,10 @@
STREAM])
(MAKE-STRING-FORMAT
[LAMBDA NIL (* ; "Edited 8-Aug-2021 00:10 by rmk:")
[LAMBDA NIL (* ; "Edited 24-Apr-2025 21:45 by rmk")
(* ; "Edited 8-Aug-2021 00:10 by rmk:")
(* ;; "We are looking at an in-core string, we know that EOL is CR, that the characters have the internal (XCCS) encoding, and that the string is fat. ")
(* ;; "We are looking at an in-core string, we know that EOL is CR, that the characters have the internal (MCCS) encoding, and that the string is fat. ")
(MAKE-EXTERNALFORMAT :STRING [FUNCTION (LAMBDA (STRM COUNTP)
(DECLARE (USEDFREE *BYTECOUNTER*))
@@ -761,15 +764,15 @@
(ADDTOVAR LAMA WHENCLOSE)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2363 3482 (\ADD-OPEN-STREAM 2373 . 2654) (\GENERIC-UNREGISTER-STREAM 2656 . 3480)) (
3523 10587 (CLOSEALL 3533 . 4011) (CLOSEF 4013 . 5227) (EOFCLOSEF 5229 . 5529) (INPUT 5531 . 6301) (
OPENP 6303 . 6706) (OUTPUT 6708 . 7480) (POSITION 7482 . 8290) (RANDACCESSP 8292 . 8682) (\IOMODEP
8684 . 9313) (WHENCLOSE 9315 . 10585)) (10588 10710 (STREAMADDPROP 10598 . 10708)) (11668 24521 (
\BASEBYTES.IO.INIT 11678 . 14878) (\MAKEBASEBYTESTREAM 14880 . 17808) (\MBS.OUTCHARFN 17810 . 18210) (
\BASEBYTES.NAME.FROM.STREAM 18212 . 18671) (\BASEBYTES.BOUT 18673 . 19427) (\BASEBYTES.SETFILEPTR
19429 . 20050) (\BASEBYTES.READP 20052 . 20696) (\BASEBYTES.BIN 20698 . 21205) (\BASEBYTES.PEEKBIN
21207 . 22037) (\BASEBYTES.TRUNCATEFN 22039 . 22547) (\BASEBYTES.OPENFN 22549 . 23343) (
\BASEBYTES.BLOCKIO 23345 . 24519)) (24644 27948 (OPENSTRINGSTREAM 24654 . 26363) (MAKE-STRING-FORMAT
26365 . 27946)) (28220 32528 (\STRINGSTREAM.INIT 28230 . 32526)) (32605 35305 (GETSTREAM 32615 . 32846
) (\CLEAROFD 32848 . 33141) (\GETSTREAM 33143 . 35303)))))
(FILEMAP (NIL (2372 3491 (\ADD-OPEN-STREAM 2382 . 2663) (\GENERIC-UNREGISTER-STREAM 2665 . 3489)) (
3532 10596 (CLOSEALL 3542 . 4020) (CLOSEF 4022 . 5236) (EOFCLOSEF 5238 . 5538) (INPUT 5540 . 6310) (
OPENP 6312 . 6715) (OUTPUT 6717 . 7489) (POSITION 7491 . 8299) (RANDACCESSP 8301 . 8691) (\IOMODEP
8693 . 9322) (WHENCLOSE 9324 . 10594)) (10597 10719 (STREAMADDPROP 10607 . 10717)) (11677 24530 (
\BASEBYTES.IO.INIT 11687 . 14887) (\MAKEBASEBYTESTREAM 14889 . 17817) (\MBS.OUTCHARFN 17819 . 18219) (
\BASEBYTES.NAME.FROM.STREAM 18221 . 18680) (\BASEBYTES.BOUT 18682 . 19436) (\BASEBYTES.SETFILEPTR
19438 . 20059) (\BASEBYTES.READP 20061 . 20705) (\BASEBYTES.BIN 20707 . 21214) (\BASEBYTES.PEEKBIN
21216 . 22046) (\BASEBYTES.TRUNCATEFN 22048 . 22556) (\BASEBYTES.OPENFN 22558 . 23352) (
\BASEBYTES.BLOCKIO 23354 . 24528)) (24653 28066 (OPENSTRINGSTREAM 24663 . 26372) (MAKE-STRING-FORMAT
26374 . 28064)) (28338 32646 (\STRINGSTREAM.INIT 28348 . 32644)) (32723 35423 (GETSTREAM 32733 . 32964
) (\CLEAROFD 32966 . 33259) (\GETSTREAM 33261 . 35421)))))
STOP

BIN
sources/AOFD.LCOM
View File

Binary file not shown.

88
sources/ATBL
View File

@@ -1,16 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Dec-2021 14:32:50" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;32 91860
(FILECREATED "24-Apr-2025 21:52:35" {WMEDLEY}<sources>ATBL.;33 91754
:CHANGES-TO (FNS MAKE-READER-ENVIRONMENT)
:EDIT-BY rmk
:PREVIOUS-DATE "19-Dec-2021 14:09:43"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;31)
:CHANGES-TO (FNS \ATBLSET EQUAL-READER-ENVIRONMENT)
:PREVIOUS-DATE "26-Dec-2021 14:32:50" {WMEDLEY}<sources>ATBL.;32)
(* ; "
Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT ATBLCOMS)
@@ -1733,26 +1730,27 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(DEFINEQ
(\ATBLSET
[LAMBDA NIL (* ; "Edited 28-Jun-2021 09:29 by rmk:")
(* ; "Edited 3-Dec-86 18:07 by Pavel")
[LAMBDA NIL (* ; "Edited 24-Apr-2025 21:51 by rmk")
(* ; "Edited 28-Jun-2021 09:29 by rmk:")
(* ; "Edited 3-Dec-86 18:07 by Pavel")
(DECLARE (GLOBALVARS \ORIGREADTABLE \ORIGTERMTABLE))
(COND
((NULL (BOUNDP '\PRIMREADTABLE))
(initrecord CHARTABLE)
(* ;; "Read tables")
(* ;; "Read tables")
(* ;; "RMK: If reloading, don't smash an existing hash table")
(* ;; "RMK: If reloading, don't smash an existing hash table")
[OR (HARRAYP \READTABLEHASH)
(SETQ \READTABLEHASH (HASHARRAY 20 NIL (FUNCTION STRING-EQUAL-HASHBITS)
(FUNCTION STRING-EQUAL]
(LET (TRDTBL NEW-IL-RDTBL)
(PROGN (* ; "The ORIG read table")
(PROGN (* ; "The ORIG read table")
(SETQ \ORIGREADTABLE (\ORIGREADTABLE))
(READTABLEPROP \ORIGREADTABLE 'NAME 'ORIG))
(PROGN (* ;
 "The old Interlisp T read table. May not have a use for this any more")
(PROGN (* ;
 "The old Interlisp T read table. May not have a use for this any more")
(SETQ TRDTBL (COPYREADTABLE \ORIGREADTABLE))
(SETSYNTAX (CHARCODE "|")
'(MACRO READVBAR)
@@ -1767,9 +1765,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
'(MACRO FIRST READQUOTE)
TRDTBL)
(READTABLEPROP TRDTBL 'NAME "OLD-INTERLISP-T")
(PROGN (* ; "Temporary")
(PROGN (* ; "Temporary")
(SETTOPVAL '%#CURRENTRDTBL# TRDTBL)))
(PROGN (* ; "The old FILERDTBL")
(PROGN (* ; "The old FILERDTBL")
(SETQ FILERDTBL (COPYREADTABLE \ORIGREADTABLE))
(SETSYNTAX (CHARCODE "|")
TRDTBL FILERDTBL)
@@ -1778,12 +1776,12 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(create READER-ENVIRONMENT
REREADTABLE _ FILERDTBL
REBASE _ 10
REFORMAT _ :XCCS)) (* ;
 "need this to read files in the loadup")
REFORMAT _ :MCCS)) (* ;
 "need this to read files in the loadup")
)
(PROGN (SETQ NEW-IL-RDTBL (COPYREADTABLE TRDTBL))
(* ;
 "The new Interlisp read table is more common lispy")
(* ;
 "The new Interlisp read table is more common lispy")
(READTABLEPROP NEW-IL-RDTBL 'MULTIPLE-ESCAPECHAR (CHARCODE "|"))
(READTABLEPROP NEW-IL-RDTBL 'HASHMACROCHAR (CHARCODE "#"))
(SET-DEFAULT-HASHMACRO-SETTINGS NEW-IL-RDTBL)
@@ -1791,11 +1789,11 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(READTABLEPROP NEW-IL-RDTBL 'USESILPACKAGE NIL)
(READTABLEPROP NEW-IL-RDTBL 'NAME "INTERLISP")
(for I from 1 to 26 do (SETSYNTAX I 'SEPRCHAR FILERDTBL)
(* ; "Make font switch chars seprs")
(SETSYNTAX I 'SEPRCHAR NEW-IL-RDTBL))
(* ; "Make font switch chars seprs")
(SETSYNTAX I 'SEPRCHAR NEW-IL-RDTBL))
(SETQ *READTABLE* NEW-IL-RDTBL))
(* ;; "Make ^Y like #. in the old T readtable and the new INTERLISP one.")
(* ;; "Make ^Y like #. in the old T readtable and the new INTERLISP one.")
(SETSYNTAX (CHARCODE ^Y)
'[MACRO ALWAYS (LAMBDA (FILE RDTBL)
@@ -1805,7 +1803,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
TRDTBL NEW-IL-RDTBL)
(DEFPRINT 'READTABLEP '\READTABLEP.DEFPRINT))
(* ;; "Terminal tables")
(* ;; "Terminal tables")
(SETQ \ORIGTERMTABLE (\ORIGTERMTABLE))
(SETQ \PRIMTERMTABLE (COPYTERMTABLE \ORIGTERMTABLE))
@@ -1868,7 +1866,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(EQUAL-READER-ENVIRONMENT
[LAMBDA (ENV1 ENV2)
(* ;; "Edited 19-Dec-2021 14:09 by rmk: Replace constant :XCCS with *DEFAULT-EXTERNALFORMAT*")
(* ;; "Edited 24-Apr-2025 21:52 by rmk")
(* ;; "Edited 19-Dec-2021 14:09 by rmk: Use *DEFAULT-EXTERNALFORMAT*")
(* ;; "Edited 19-Dec-2021 14:01 by rmk")
@@ -1921,25 +1921,23 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
(ADDTOVAR LAMA READTABLEPROP)
)
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018
2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (17749 28901 (GETSYNTAX 17759 . 22590) (SETSYNTAX 22592 . 23665) (SYNTAXP 23667 . 26164)
(\COPYSYNTAX 26166 . 26883) (\GETCHARCODE 26885 . 27173) (\SETFATSYNCODE 27175 . 28466) (
\MAPCHARTABLE 28468 . 28899)) (28934 43900 (CONTROL 28944 . 29196) (COPYTERMTABLE 29198 . 29565) (
DELETECONTROL 29567 . 32208) (GETDELETECONTROL 32210 . 33172) (ECHOCHAR 33174 . 34615) (ECHOCONTROL
34617 . 35074) (ECHOMODE 35076 . 35322) (GETECHOMODE 35324 . 35488) (GETCONTROL 35490 . 35656) (
GETTERMTABLE 35658 . 35725) (RAISE 35727 . 36153) (GETRAISE 36155 . 36317) (RESETTERMTABLE 36319 .
37403) (SETTERMTABLE 37405 . 37639) (TERMTABLEP 37641 . 37802) (\GETTERMSYNTAX 37804 . 38075) (
\GTTERMTABLE 38077 . 38413) (\ORIGTERMTABLE 38415 . 42025) (\SETTERMSYNTAX 42027 . 42662) (
\TERMCLASSTOCODE 42664 . 43093) (\TERMCODETOCLASS 43095 . 43482) (\LITCHECK 43484 . 43898)) (46411
70235 (COPYREADTABLE 46421 . 46619) (FIND-READTABLE 46621 . 46768) (IN-READTABLE 46770 . 46930) (
ESCAPE 46932 . 47185) (GETBRK 47187 . 47325) (GETREADTABLE 47327 . 47463) (GETSEPR 47465 . 47603) (
READMACROS 47605 . 47868) (READTABLEP 47870 . 48033) (READTABLEPROP 48035 . 53193) (RESETREADTABLE
53195 . 57442) (SETBRK 57444 . 59054) (SETREADTABLE 59056 . 59244) (SETSEPR 59246 . 60788) (
\GETREADSYNTAX 60790 . 63480) (\GTREADTABLE 63482 . 63707) (\GTREADTABLE1 63709 . 63965) (
\ORIGREADTABLE 63967 . 65875) (\READCLASSTOCODE 65877 . 66328) (\SETMACROSYNTAX 66330 . 68125) (
\SETREADSYNTAX 68127 . 69188) (\READTABLEP.DEFPRINT 69190 . 70233)) (83067 87520 (\ATBLSET 83077 .
87518)) (87967 91384 (MAKE-READER-ENVIRONMENT 87977 . 89634) (EQUAL-READER-ENVIRONMENT 89636 . 90786)
(SET-READER-ENVIRONMENT 90788 . 91382)))))
(FILEMAP (NIL (17619 28771 (GETSYNTAX 17629 . 22460) (SETSYNTAX 22462 . 23535) (SYNTAXP 23537 . 26034)
(\COPYSYNTAX 26036 . 26753) (\GETCHARCODE 26755 . 27043) (\SETFATSYNCODE 27045 . 28336) (
\MAPCHARTABLE 28338 . 28769)) (28804 43770 (CONTROL 28814 . 29066) (COPYTERMTABLE 29068 . 29435) (
DELETECONTROL 29437 . 32078) (GETDELETECONTROL 32080 . 33042) (ECHOCHAR 33044 . 34485) (ECHOCONTROL
34487 . 34944) (ECHOMODE 34946 . 35192) (GETECHOMODE 35194 . 35358) (GETCONTROL 35360 . 35526) (
GETTERMTABLE 35528 . 35595) (RAISE 35597 . 36023) (GETRAISE 36025 . 36187) (RESETTERMTABLE 36189 .
37273) (SETTERMTABLE 37275 . 37509) (TERMTABLEP 37511 . 37672) (\GETTERMSYNTAX 37674 . 37945) (
\GTTERMTABLE 37947 . 38283) (\ORIGTERMTABLE 38285 . 41895) (\SETTERMSYNTAX 41897 . 42532) (
\TERMCLASSTOCODE 42534 . 42963) (\TERMCODETOCLASS 42965 . 43352) (\LITCHECK 43354 . 43768)) (46281
70105 (COPYREADTABLE 46291 . 46489) (FIND-READTABLE 46491 . 46638) (IN-READTABLE 46640 . 46800) (
ESCAPE 46802 . 47055) (GETBRK 47057 . 47195) (GETREADTABLE 47197 . 47333) (GETSEPR 47335 . 47473) (
READMACROS 47475 . 47738) (READTABLEP 47740 . 47903) (READTABLEPROP 47905 . 53063) (RESETREADTABLE
53065 . 57312) (SETBRK 57314 . 58924) (SETREADTABLE 58926 . 59114) (SETSEPR 59116 . 60658) (
\GETREADSYNTAX 60660 . 63350) (\GTREADTABLE 63352 . 63577) (\GTREADTABLE1 63579 . 63835) (
\ORIGREADTABLE 63837 . 65745) (\READCLASSTOCODE 65747 . 66198) (\SETMACROSYNTAX 66200 . 67995) (
\SETREADSYNTAX 67997 . 69058) (\READTABLEP.DEFPRINT 69060 . 70103)) (82937 87494 (\ATBLSET 82947 .
87492)) (87941 91385 (MAKE-READER-ENVIRONMENT 87951 . 89608) (EQUAL-READER-ENVIRONMENT 89610 . 90787)
(SET-READER-ENVIRONMENT 90789 . 91383)))))
STOP

BIN
sources/ATBL.LCOM
View File

Binary file not shown.

BIN
sources/ATERM.LCOM
View File

Binary file not shown.

26
sources/DIRECTORY
View File

@@ -1,16 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Mar-2022 10:53:16" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;15 28665
(FILECREATED " 6-Nov-2025 00:13:55" {WMEDLEY}<sources>DIRECTORY.;17 28439
:CHANGES-TO (FNS DIRECTORY)
:EDIT-BY rmk
:PREVIOUS-DATE "29-Mar-2022 08:29:33"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DIRECTORY.;14)
:CHANGES-TO (VARS DIRCOMMANDS)
:PREVIOUS-DATE "22-Oct-2025 22:07:27" {WMEDLEY}<sources>DIRECTORY.;16)
(* ; "
Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
")
(PRETTYCOMPRINT DIRECTORYCOMS)
@@ -419,7 +416,7 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
DELETE
(DELETE? PROMPT " delete? " DELETE)
DELETED
(LE LENGTH "(" BYTESIZE ")")
(LE . LENGTH)
NEWERTHAN OLDVERSIONS (OLD OLDERTHAN 90)
OLDERTHAN
(OU . OUT)
@@ -463,12 +460,11 @@ Copyright (c) 1986-1988, 1990, 1992 by Venue & Xerox Corporation.
(GLOBALVARS DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES)
)
)
(PUTPROPS DIRECTORY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1325 27144 (DODIR 1335 . 1882) (FILDIR 1884 . 2164) (DIRECTORY 2166 . 12883) (
DIRECTORY.PARSE 12885 . 14179) (DIRECTORY.FILL.PATTERN 14181 . 14711) (DIRCONJ 14713 . 14933) (
DIRECTORY.NEXTFILE 14935 . 15528) (DMATCH 15530 . 15905) (DIRECTORY.MATCH.SETUP 15907 . 16441) (
DIRECTORY.MATCH 16443 . 16860) (DIRECTORY.MATCH1 16862 . 18975) (DODIRCOMMANDS 18977 . 24447) (
DIRPRINTNAME 24449 . 25865) (DPRIN1 25867 . 25952) (DIRFILENAME 25954 . 26675) (DIRGETFILEINFO 26677
. 26829) (DREAD 26831 . 27142)))))
(FILEMAP (NIL (1200 27019 (DODIR 1210 . 1757) (FILDIR 1759 . 2039) (DIRECTORY 2041 . 12758) (
DIRECTORY.PARSE 12760 . 14054) (DIRECTORY.FILL.PATTERN 14056 . 14586) (DIRCONJ 14588 . 14808) (
DIRECTORY.NEXTFILE 14810 . 15403) (DMATCH 15405 . 15780) (DIRECTORY.MATCH.SETUP 15782 . 16316) (
DIRECTORY.MATCH 16318 . 16735) (DIRECTORY.MATCH1 16737 . 18850) (DODIRCOMMANDS 18852 . 24322) (
DIRPRINTNAME 24324 . 25740) (DPRIN1 25742 . 25827) (DIRFILENAME 25829 . 26550) (DIRGETFILEINFO 26552
. 26704) (DREAD 26706 . 27017)))))
STOP

BIN
sources/DIRECTORY.LCOM
View File

Binary file not shown.

585
sources/FONT
View File

@@ -1,14 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Oct-2025 17:51:13" {WMEDLEY}<sources>FONT.;617 284869
(FILECREATED " 8-Dec-2025 22:19:01" {WMEDLEY}<sources>FONT.;645 281352
:EDIT-BY rmk
:CHANGES-TO (FNS \CREATECHARSET.DISPLAY COMPLETE.FONT \COERCECHARSET)
(MACROS LEGACYFONTS LEGACYFONT)
(VARS FONTCOMS)
:CHANGES-TO (MACROS SPREADFONTSPEC)
:PREVIOUS-DATE " 7-Oct-2025 12:43:05" {WMEDLEY}<sources>FONT.;614)
:PREVIOUS-DATE " 4-Dec-2025 09:46:06" {WMEDLEY}<sources>FONT.;644)
(PRETTYCOMPRINT FONTCOMS)
@@ -17,27 +15,24 @@
[
(* ;; "font functions ")
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
 "Can't be loaded/not needed during INIT, load at end of LOAD-LISP.")
(FILES (SYSLOAD)
MULTI-ALIST))
(FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY
\STRINGWIDTH.GENERIC)
(COMS (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT
GETFONTCLASSCOMPONENT)
(MACROS \GETFONTCLASSCOMPONENT \SETFONTCLASSCOMPONENT))
(VARS NSFONTFAMILIES ALTOFONTFAMILIES)
(INITVARS MCCSFONTFAMILIES)
(COMS
(* ;; "Creation: ")
(FNS FONTCREATE FONTCREATE1 FONTCREATE.SLUGFD \FONT.CHECKARGS \FONT.CHECKARGS1
\FONTCREATE1.NOFN FONTFILEP \READCHARSET)
(FNS FONTCREATE FONTCREATE1 FONTCREATE.SLUGFD \FONT.CHECKARGS1 \FONTCREATE1.NOFN
FONTFILEP \READCHARSET)
(FNS \FONT.CHECKARGS \CHARSET.CHECK)
(FNS COERCEFONTSPEC)
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS COERCEFONTSPEC.MATCH COERCEFONTSPEC.TARGET))
(MACROS SPREADFONTSPEC)
(FNS MAKEFONTSPEC)
(FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNESLUGCSINFOS))
(FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNESLUGCSINFOS MONOSPACEFONTP))
(COMS
(* ;; "Property extraction:")
@@ -64,15 +59,20 @@
(FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \COERCECHARSET
\BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR SETFONTCHARENCODING
)
(FNS FONTSAVAILABLE FONTEXISTS? \SEARCHFONTFILES FLUSHFONTSINCORE FINDFONTFILES SORTFONTSPECS
)
(FNS FONTSAVAILABLE FONTEXISTS? \SEARCHFONTFILES FLUSHFONTCACHE FLUSHFONTSINCORE
FINDFONTFILES SORTFONTSPECS)
(FNS MATCHFONTFACE MAKEFONTFACE FONTFACETOATOM)
(INITVARS \FONTSINCORE \FONTEXISTS?-CACHE \DEFAULTDEVICEFONTS)
(INITVARS \FONTSINCORE \FONTEXISTS?-CACHE \FONTSAVAILABLEFILECACHE \DEFAULTDEVICEFONTS)
(* ;; "The INITVARS value of MEDLEY-INIT-VARS in MEDLEY dalso includes these entries. That's because FONT is in the INIT, so these entries would be lost when MEDLEY-INIT-VARS is reinitialized when the Lisp loadup starts")
(ADDVARS (MEDLEY-INIT-VARS (\FONTEXISTS?-CACHE NIL RESET)
(\FONTSAVAILABLEFILECACHE NIL RESET)))
[COMS (GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
(INITVARS \UNITWIDTHSVECTOR)
(FNS \UNITWIDTHSVECTOR)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR]
(DECLARE%: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO FONTSPEC)
(DECLARE%: DONTCOPY [EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO FONTSPEC)
(MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET
\FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH
\FGETIMAGEWIDTH \FSETIMAGEWIDTH)
@@ -80,8 +80,7 @@
\CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR CHARSETPROP)
(PROP ARGNAMES CHARSETPROP)
(CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR))
(SLUGCHARSET (ADD1 \MAXCHARSET)))
(MACROS LEGACYFONTS))
(SLUGCHARSET (ADD1 \MAXCHARSET]
(MACROS INDIRECTCHARSETP))
(FNS FONTDESCRIPTOR.DEFPRINT FONTCLASS.DEFPRINT)
(INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
@@ -157,7 +156,7 @@
(PALATINO CLASSIC)
(OPTIMA MODERN)
(BOLDPS CLASSIC)
(PCTERMINAL)
(PCTERMINAL CLASSIC)
(TITANLEGAL CLASSIC]
(\DEFAULTCHARSET 0))
@@ -211,11 +210,6 @@
(* ;; "font functions ")
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (SYSLOAD)
MULTI-ALIST)
)
(DEFINEQ
(CHARWIDTH
@@ -506,6 +500,8 @@
(RPAQQ ALTOFONTFAMILIES (TIMESROMAN TIMESROMAND HELVETICA HELVETICAD CLARITY BRAVOX TONTO CREAM
OLDENGLISH))
(RPAQ? MCCSFONTFAMILIES NIL)
(* ;; "Creation: ")
@@ -621,111 +617,6 @@
else (for CS from 0 to (ADD1 \MAXCHARSET) do (\SETCHARSETINFO FONTDESC CS SLUGCSINFO)))
FONTDESC])
(\FONT.CHECKARGS
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Aug-2025 14:46 by rmk")
(* ; "Edited 23-Aug-2025 11:54 by rmk")
(* ; "Edited 17-Aug-2025 19:15 by rmk")
(* ; "Edited 12-Aug-2025 22:36 by rmk")
(* ; "Edited 10-Aug-2025 12:06 by rmk")
(* ; "Edited 8-Aug-2025 09:57 by rmk")
(* ; "Edited 27-Jul-2025 13:30 by rmk")
(* ; "Edited 22-Jul-2025 23:07 by rmk")
(* ; "Edited 21-Jul-2025 09:22 by rmk")
(* ; "Edited 14-Jul-2025 20:09 by rmk")
(* ; "Edited 11-Jul-2025 10:15 by rmk")
(* ; "Edited 5-Jul-2025 13:37 by rmk")
(* ; "Edited 2-Jul-2025 16:50 by rmk")
(* ; "Edited 27-Jun-2025 10:42 by rmk")
(* ; "Edited 15-Jun-2025 00:25 by rmk")
(* ;; "DON'T BREAK, TRACE, OR UNSAVE THIS UNLESS ALL SYSTEM FONTS HAVE ALREADY BEEN INSTANTIATED")
(* ;; "Decodes and checks the various ways of specifying the arguments to font lookup functions.")
(* ;; "If FAMILY can be coerced to a font descriptor and none of its properties are overwritten by the other aguments, then that font descriptor is returned. Otherwise the value is the coerced fontspec (family size face rotation device).")
(LET (FONTX)
(CL:WHEN (AND (EQ 'CLASS (CAR (LISTP FAMILY)))
(LITATOM (CADR FAMILY)))
(* ;; "This used to be at the entry to FONTCREATE, and it returned the FONTCLASS. That seemed wrong--FONTCREATE should always return a fontdescriptor. So here we build a throwaway fontclass, coerce it to its device font, and fall through.")
(SETQ FAMILY (\FONT.CHECKARGS1 (FONTCLASS (CADR FAMILY)
(CDDR FAMILY))
DEVICE)))
(CL:UNLESS (AND FAMILY (LITATOM FAMILY)
(NEQ FAMILY T))
(* ;; "FAMILY T or NIL produces an error below")
[if (LISTP FAMILY)
then
(* ;; "Presumably a FONTSPEC. The variables here override the FONTX properties, as with the fontdescriptor below ")
(SETQ FONTX (CL:IF (EQ 'FONT (CAR FAMILY))
(CDR FAMILY)
FAMILY))
(SETQ FAMILY (fetch (FONTSPEC FSFAMILY) of FONTX))
(SETQ SIZE (OR SIZE (fetch (FONTSPEC FSSIZE) of FONTX)))
(SETQ FACE (OR FACE (fetch (FONTSPEC FSFACE) of FONTX)))
(SETQ ROTATION (OR ROTATION (fetch (FONTSPEC FSROTATION) of FONTX)))
(SETQ DEVICE (OR DEVICE (fetch (FONTSPEC FSDEVICE) of FONTX)))
(SETQ FONTX NIL)
elseif (SETQ FONTX (CL:IF (type? FONTDESCRIPTOR FAMILY)
FAMILY
(\FONT.CHECKARGS1 FAMILY DEVICE T)))
then
(* ;;
 "FAMILY was a spec for a font descriptor. Are any of its properties overwritten?")
(SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of FONTX))
(CL:UNLESS SIZE
(SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX)))
(CL:UNLESS FACE
(SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONTX)))
(CL:UNLESS ROTATION
(SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX)))
(CL:UNLESS DEVICE
(SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX)))])
(* ;; "We have decoded the arguments, fill in defaults and validate")
(SETQ DEVICE (if (NULL DEVICE)
then 'DISPLAY
elseif (OR (AND (LITATOM DEVICE)
(NEQ DEVICE T))
(STRINGP DEVICE))
then (\DEVICESYMBOL DEVICE)
elseif [AND (SETQ DEVICE (\GETSTREAM DEVICE 'OUTPUT T))
(CAR (MKLIST (IMAGESTREAMTYPE DEVICE]
else (\ILLEGAL.ARG DEVICE)))
(CL:UNLESS (AND FAMILY (LITATOM FAMILY)
(NEQ FAMILY T))
(ERROR "Illegal font family" FAMILY))
(SETQ FAMILY (U-CASE FAMILY))
(CL:UNLESS (OR (AND (FIXP SIZE)
(IGREATERP SIZE 0))
(EQ SIZE '*))
(ERROR "Illegal font size" SIZE))
(CL:UNLESS (EQ FACE '*)
(SETQ FACE (\FONTFACE FACE NIL DEVICE)))
(if (NULL ROTATION)
then (SETQ ROTATION 0)
elseif (AND (FIXP ROTATION)
(IGEQ ROTATION 0))
elseif (EQ ROTATION '*)
else (\ILLEGAL.ARG ROTATION))
(CL:WHEN FONTX
(* ;; "Return FONTX only if no fields were overwritten")
(CL:UNLESS (AND (EQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX))
(EQUAL FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONTX))
(EQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX))
(EQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX)))
(SETQ FONTX NIL)))
(OR FONTX (MAKEFONTSPEC FAMILY SIZE FACE ROTATION DEVICE])
(\FONT.CHECKARGS1
[LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 22-Jul-2025 18:47 by rmk")
(* ; "Edited 14-Jul-2025 19:40 by rmk")
@@ -822,7 +713,8 @@
(CLOSEF? STRM))))])
(\READCHARSET
[LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 2-Sep-2025 23:57 by rmk")
[LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 11-Nov-2025 14:30 by rmk")
(* ; "Edited 2-Sep-2025 23:57 by rmk")
(* ; "Edited 28-Aug-2025 23:17 by rmk")
(* ; "Edited 25-Aug-2025 12:03 by rmk")
(* ; "Edited 16-Aug-2025 18:00 by rmk")
@@ -856,17 +748,15 @@
(* ;; "The file didn't know its own encoding")
(SETQ FAMILY (fetch (FONTSPEC FSFAMILY) of FONTSPEC))
(CHARSETPROP CSINFO 'CSCHARENCODING (if (NEQ CHARSET 0)
then 'MCCS
elseif (MEMB FAMILY
NSFONTFAMILIES
)
then 'XCCS$
elseif (MEMB FAMILY
ALTOFONTFAMILIES
)
then 'ALTOTEXT
else FAMILY)))
(CHARSETPROP CSINFO 'CSCHARENCODING
(if (OR (NEQ CHARSET 0)
(MEMB FAMILY MCCSFONTFAMILIES))
then 'MCCS
elseif (MEMB FAMILY NSFONTFAMILIES)
then 'XCCS$
elseif (MEMB FAMILY ALTOFONTFAMILIES)
then 'ALTOTEXT
else FAMILY)))
(* ;; "Remember the file that this basic charset information came from, before any character coercions, for informational purposes. Path and version won't be valid if sysout moves, or if PSEUDOFILENAME's aren't aligned. Don't want files to be new atoms, for loadup.")
@@ -884,7 +774,8 @@
(DEFINEQ
(\FONT.CHECKARGS
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Aug-2025 14:46 by rmk")
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE ALWAYSFONTSPEC) (* ; "Edited 22-Nov-2025 11:31 by rmk")
(* ; "Edited 28-Aug-2025 14:46 by rmk")
(* ; "Edited 23-Aug-2025 11:54 by rmk")
(* ; "Edited 17-Aug-2025 19:15 by rmk")
(* ; "Edited 12-Aug-2025 22:36 by rmk")
@@ -981,7 +872,8 @@
(* ;; "Return FONTX only if no fields were overwritten")
(CL:UNLESS (AND (EQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX))
(CL:UNLESS (AND (NOT ALWAYSFONTSPEC)
(EQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX))
(EQUAL FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONTX))
(EQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX))
(EQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX)))
@@ -999,7 +891,8 @@
(DEFINEQ
(COERCEFONTSPEC
[LAMBDA (FONTSPEC COERCIONS) (* ; "Edited 5-Oct-2025 09:41 by rmk")
[LAMBDA (FONTSPEC COERCIONS) (* ; "Edited 9-Nov-2025 17:54 by rmk")
(* ; "Edited 5-Oct-2025 09:41 by rmk")
(* ; "Edited 28-Aug-2025 14:41 by rmk")
(* ; "Edited 25-Aug-2025 10:22 by rmk")
(* ; "Edited 17-Aug-2025 19:15 by rmk")
@@ -1013,11 +906,14 @@
(* ;; "Doesn't make sense to coerce the device, DEVICE and also CHARSET are just carried along.")
(CL:WHEN (LITATOM COERCIONS)
[SETQ COERCIONS (FONTDEVICEPROP FONTSPEC (OR COERCIONS 'FONTCOERCIONS])
(* ;; "A NIL match component matches everything, and a NIL target component denotes the corresponding argument.")
(for C MATCH TARGET MFAMILY MSIZE MFACE MROTATION TFAMILY TSIZE TFACE TROTATION COERCED FAMILY
SIZE FACE ROTATION DEVICE in (OR COERCIONS (FONTDEVICEPROP FONTSPEC 'FONTCOERCIONS))
first (SPREADFONTSPEC FONTSPEC) eachtime (SETQ MATCH (MKLIST (CAR C)))
SIZE FACE ROTATION DEVICE in COERCIONS first (SPREADFONTSPEC FONTSPEC)
eachtime (SETQ MATCH (MKLIST (CAR C)))
when [AND (COERCEFONTSPEC.MATCH (pop MATCH)
FAMILY)
(COERCEFONTSPEC.MATCH (pop MATCH)
@@ -1077,33 +973,38 @@
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS SPREADFONTSPEC MACRO [(FONTSPEC)
(LET ((FS FONTSPEC))
(PUTPROPS SPREADFONTSPEC MACRO [(FSPEC)
(LET ((FS FSPEC))
(* ;; "Unwrap a FONTSPEC sequentially")
(* ;; "Unwrap a FONTSPEC ")
(CL:WHEN (type? FONTDESCRIPTOR FS)
(SETQ FS (FONTPROP FS 'SPEC)))
(SETQ FAMILY (pop FS))
(SETQ SIZE (pop FS))
(SETQ FACE (pop FS))
(SETQ ROTATION (pop FS))
(SETQ DEVICE (pop FS])
(SETQ FAMILY (fetch (FONTSPEC FSFAMILY) of FS))
(SETQ SIZE (fetch (FONTSPEC FSSIZE) of FS))
(SETQ FACE (fetch (FONTSPEC FSFACE) of FS))
(SETQ ROTATION (fetch (FONTSPEC FSROTATION) of FS))
(SETQ DEVICE (fetch (FONTSPEC FSDEVICE) of FS])
)
(DEFINEQ
(MAKEFONTSPEC
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Aug-2025 14:32 by rmk")
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE BASE) (* ; "Edited 7-Nov-2025 07:52 by rmk")
(* ; "Edited 28-Aug-2025 14:32 by rmk")
(* ; "Edited 17-Aug-2025 20:44 by rmk")
(* ;; "This is a function, not a macro, so that it can be used in the loadup sequence to create the FONTSPEC for the \GUARANTEEDDISPLAYFONT. That font is created by \CREATEFONT and therefore is not dependent on \FONT.CHECKARGS or on the multi-alist multi-key indexing functions. The strategy might change if MULTI-ALIST is moved earlier in the loadup sequence.")
(* ;; "BASE (fontspec or font) provides defaults for NIL arguments, essentialy models a (create using BASE...)")
(CL:WHEN (FONTP BASE)
(SETQ BASE (FONTPROP BASE 'SPEC)))
(create FONTSPEC
FSFAMILY _ FAMILY
FSSIZE _ SIZE
FSFACE _ FACE
FSROTATION _ ROTATION
FSDEVICE _ DEVICE])
FSFAMILY _ (OR FAMILY (fetch (FONTSPEC FSFAMILY) of BASE))
FSSIZE _ (OR SIZE (fetch (FONTSPEC FSSIZE) of BASE))
FSFACE _ (OR FACE (fetch (FONTSPEC FSFACE) of BASE))
FSROTATION _ (OR ROTATION (fetch (FONTSPEC FSROTATION) of BASE))
FSDEVICE _ (OR DEVICE (fetch (FONTSPEC FSDEVICE) of BASE])
)
(DEFINEQ
@@ -1190,6 +1091,30 @@
(fetch (CHARSETINFO CSSLUGP) of CSINFO))
do (\SETCHARSETINFO FONT CS NIL))
FONT])
(MONOSPACEFONTP
[LAMBDA (FONT CODES SKIPSLUGS RETURNVARIABLES) (* ; "Edited 12-Oct-2025 21:13 by rmk")
(* ;; "Returns T if all the CODES are the same width. Skips slugs if SKIPSLUGHTS, returns the list of variable width characters if RETURNVARIABLES (instead of NIL).")
(* ;; "If CODES is a charset, checks all the codes in that charset. Otherwise, can be a (firstcode lastcode) list (e.g. (0 127) to check 7-bit ascii.FIX")
(SETQ FONT (FONTCREATE FONT))
[SETQ CODES (if (LISTP CODES)
then [LIST (OR (CHARCODEP (CAR CODES))
(CHARCODE.DECODE (CAR CODES)))
(OR (CHARCODEP (CADR CODES))
(CHARCODE.DECODE (CADR CODES]
else (SETQ CODES (\CHARSET.CHECK CODES))
(LIST (FIRSTCHARSETCODE CODES)
(LASTCHARSETCODE CODES]
(for CODE WIDTH from (CAR CODES) to (CADR CODES)
unless (OR (AND SKIPSLUGS (SLUGCHARP.DISPLAY CODE FONT))
(EQ (OR WIDTH (SETQ WIDTH (CHARWIDTH CODE FONT)))
(CHARWIDTH CODE FONT))) collect CODE
finally (RETURN (if (NULL $$VAL)
elseif RETURNVARIABLES
then (SORT $$VAL])
)
@@ -1218,7 +1143,8 @@
(fetch (FONTDESCRIPTOR \SFHeight) of (FONTCREATE FONTSPEC])
(FONTPROP
[LAMBDA (FONT PROP) (* ; "Edited 2-Sep-2025 22:21 by rmk")
[LAMBDA (FONT PROP) (* ; "Edited 2-Dec-2025 16:01 by rmk")
(* ; "Edited 2-Sep-2025 22:21 by rmk")
(* ; "Edited 12-Aug-2025 21:10 by rmk")
(* ; "Edited 10-Aug-2025 13:28 by rmk")
(* ; "Edited 23-Jul-2025 17:01 by rmk")
@@ -1253,6 +1179,9 @@
elseif (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT)
ALTOFONTFAMILIES)
then 'ALTOTEXT
elseif (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT)
MCCSFONTFAMILIES)
then 'MCCS
else (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT])
(SPEC (create FONTSPEC
FSFAMILY _ (ffetch FONTFAMILY of FONT)
@@ -1888,24 +1817,34 @@
(\FINDFONTFILE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)
(* ; "Edited 3-Dec-2025 23:38 by rmk")
(* ; "Edited 9-Jun-2025 09:40 by rmk")
(* ; "Edited 15-May-2025 22:41 by rmk")
(* ; "Edited 14-Sep-96 10:53 by rmk:")
(* ; "Edited 6-Oct-89 11:18 by bvm")
(* ;; "This doesn't call FINDFILE because the hyphens separating the family from the face would get confused with the hyphen in TEDIT-STREAM file names.")
(CL:UNLESS DIRLST
(SETQ DIRLST (CONS NIL)))
(* ;; "Find any font file on any directory with any naming convention with any extension. Note that ROTATION and DEVICE are just place holders. DEVICE is irrelevant because DIRLST already incorporates the device information. The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup. If set to a list of extensions, just those will be looked up with old-style conventions.")
(for EXT FONTFILE inside EXTLST
when (SETQ FONTFILE (FINDFILE (if (FMEMB EXT *OLD-FONT-EXTENSIONS*)
then (\FONTFILENAME.OLD FAMILY SIZE FACE EXT CHARSET)
else (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET))
T DIRLST)) collect FONTFILE finally
(for EXT FONTFILE inside EXTLST join (SETQ FONTFILE (if (FMEMB EXT *OLD-FONT-EXTENSIONS*)
then (\FONTFILENAME.OLD FAMILY SIZE FACE
EXT CHARSET)
else (\FONTFILENAME FAMILY SIZE FACE EXT
CHARSET)))
(for DIR FOUND inside DIRLST
when (SETQ FOUND (INFILEP (PACKFILENAME.STRING
'DIRECTORY DIR 'BODY FONTFILE)
)) collect FOUND)
finally
(* ;;
 "Backward compatibility for devices that expect a single file")
(* ;; "Backward compatibility for devices that expect a single file")
(CL:UNLESS (CDR $$VAL)
(RETURN (CAR $$VAL)))])
(CL:UNLESS (CDR $$VAL)
(RETURN (CAR $$VAL)))])
(\FONTFILENAMES
[LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS) (* ; "Edited 7-Oct-2025 12:21 by rmk")
@@ -2069,7 +2008,8 @@
'EXTENSION EXTENSION])
(FONTSPECFROMFILENAME
[LAMBDA (FONTFILE DEVICE) (* ; "Edited 30-Aug-2025 10:05 by rmk")
[LAMBDA (FONTFILE DEVICE) (* ; "Edited 23-Nov-2025 21:42 by rmk")
(* ; "Edited 30-Aug-2025 10:05 by rmk")
(* ; "Edited 28-Aug-2025 14:28 by rmk")
(* ; "Edited 25-Aug-2025 10:16 by rmk")
(* ; "Edited 23-Aug-2025 10:42 by rmk")
@@ -2105,17 +2045,23 @@
(SETQ NAME (U-CASE NAME))
(SETQ FACE (SUBSTRING NAME SIZEEND)) (* ;
 "don't need name, but checks for lowercase face")
[SETQ FACE (LIST (SELCHARQ (NTHCHARCODE FACE 1)
(SETQ FACE (LIST (SELCHARQ (NTHCHARCODE FACE 1)
(B 'BOLD)
(L 'LIGHT)
'MEDIUM)
(M 'MEDIUM)
NIL)
(SELCHARQ (NTHCHARCODE FACE 2)
(I 'ITALIC)
'REGULAR)
(R 'REGULAR)
NIL)
(SELCHARQ (NTHCHARCODE FACE 3)
(C 'COMPRESSED)
(E 'EXPANDED)
'REGULAR]
(R 'REGULAR)
NIL)))
(CL:WHEN (MEMB NIL FACE) (* ;
 "Named didn't have a recognizable face")
(SETQ FACE NIL))
(CL:WHEN (SETQ CHARSET (STRPOS "-c" NAME NIL NIL NIL T UPPERCASEARRAY))
[SETQ CHARSET (FIXP (MKATOM (CONCAT (SUBSTRING NAME CHARSET)
"Q"])
@@ -2772,7 +2718,9 @@
(DEFINEQ
(FONTSAVAILABLE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* ; "Edited 25-Sep-2025 18:39 by rmk")
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* ; "Edited 22-Nov-2025 11:32 by rmk")
(* ; "Edited 6-Nov-2025 13:50 by rmk")
(* ; "Edited 25-Sep-2025 18:39 by rmk")
(* ; "Edited 30-Aug-2025 13:55 by rmk")
(* ; "Edited 28-Aug-2025 14:43 by rmk")
(* ; "Edited 23-Aug-2025 10:51 by rmk")
@@ -2787,48 +2735,63 @@
(* ;;; "returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be * which means get them all. if CHECKFILESTOO? is NIL, only fonts in core will be considered. If ONLY, fonts in memory will be ignored. ")
(DECLARE (GLOBALVARS \FONTSINCORE))
(LET ((FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)))
(if (EQ '* (fetch (FONTSPEC FSDEVICE) of FONTSPEC))
then
(* ;;
(DECLARE (GLOBALVARS \FONTSINCORE \FONTSAVAILABLEFILECACHE))
(LET
((FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE T))
FILEFONTS)
(if (EQ '* (fetch (FONTSPEC FSDEVICE) of FONTSPEC))
then
(* ;;
 "The results for each device will be grouped together, because the sort happens in the clause below")
(for I in IMAGESTREAMTYPES join (FONTSAVAILABLE FONTSPEC NIL NIL NIL (CAR I)
CHECKFILESTOO?))
else (SPREADFONTSPEC FONTSPEC) (* ; "For easier matching code")
(SORTFONTSPECS (UNION (CL:UNLESS (EQ 'ONLY CHECKFILESTOO?)
[COLLECTMULTI \FONTSINCORE
(FUNCTION (LAMBDA (FM S FC R D FONT)
(DECLARE (USEDFREE $$COLLECT))
(CL:WHEN
[AND (OR (EQ FAMILY FM)
(EQ FAMILY '*))
(OR (EQ SIZE S)
(EQ SIZE '*))
(MATCHFONTFACE FACE FC)
(OR (EQ ROTATION R)
(EQ ROTATION '*))
(OR (EQ DEVICE D)
(EQ DEVICE '*]
(push $$COLLECT
(create FONTSPEC
FSFAMILY _ FM
FSSIZE _ S
FSFACE _ FC
FSROTATION _ R
FSDEVICE _ D)))])
(CL:WHEN CHECKFILESTOO?(* ;
(for I in IMAGESTREAMTYPES join (FONTSAVAILABLE FONTSPEC NIL NIL NIL (CAR I)
CHECKFILESTOO?))
else
(SPREADFONTSPEC FONTSPEC) (* ; "For easier matching code")
(SORTFONTSPECS
(UNION (CL:UNLESS (EQ 'ONLY CHECKFILESTOO?)
[COLLECTMULTI \FONTSINCORE
(FUNCTION (LAMBDA (FM S FC R D FONT)
(DECLARE (USEDFREE $$COLLECT))
(CL:WHEN [AND (OR (EQ FAMILY FM)
(EQ FAMILY '*))
(OR (EQ SIZE S)
(EQ SIZE '*))
(MATCHFONTFACE FACE FC)
(OR (EQ ROTATION R)
(EQ ROTATION '*))
(OR (EQ DEVICE D)
(EQ DEVICE '*]
(push $$COLLECT
(create FONTSPEC
FSFAMILY _ FM
FSSIZE _ S
FSFACE _ FC
FSROTATION _ R
FSDEVICE _ D)))])
(CL:WHEN CHECKFILESTOO? (* ;
 "apply the device font lookup function.")
(LET [(FN (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE
'FONTSAVAILABLE))
(FUNCTION \SEARCHFONTFILES]
(SETQ FILEFONTS (SGETMULTI \FONTSAVAILABLEFILECACHE FAMILY SIZE FACE ROTATION
DEVICE))
(* ;; "Until all the device functions take a FONTSPEC")
(* ;; "APPEND the cache value because of the SORT")
(CL:IF (EQ 1 (NARGS FN))
(APPLY* FN FONTSPEC)
(APPLY* FN FAMILY SIZE FACE ROTATION DEVICE))))])
(APPEND (if (NULL FILEFONTS)
then (LET [(FN (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE
'FONTSAVAILABLE))
(FUNCTION \SEARCHFONTFILES]
(* ;; "Until all the device functions take a FONTSPEC")
(SETQ FILEFONTS (CL:IF (EQ 1 (NARGS FN))
(APPLY* FN FONTSPEC)
(APPLY* FN FAMILY SIZE FACE ROTATION
DEVICE)))
(SPUTMULTI \FONTSAVAILABLEFILECACHE FAMILY SIZE FACE
ROTATION DEVICE (OR FILEFONTS 'NONE))
FILEFONTS)
elseif (NEQ FILEFONTS 'NONE)
then FILEFONTS)))])
(FONTEXISTS?
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS) (* ; "Edited 26-Sep-2025 10:10 by rmk")
@@ -2929,47 +2892,52 @@
FONTSFOUND)
do (push FONTSFOUND THISFONT))) finally (RETURN (DREVERSE FONTSFOUND])
(FLUSHFONTCACHE
[LAMBDA (TYPE FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 27-Nov-2025 10:02 by rmk")
(* ; "Edited 22-Nov-2025 15:52 by rmk")
(* ;;
 "Removes information for font(s) from the TYPE cache, if TYPE is NIL, all caches are flushed")
(CL:UNLESS TYPE
(SETQ TYPE '(:INCORE :EXISTS :AVAILABLE)))
(if (LISTP TYPE)
then (for TY in TYPE collect (FLUSHFONTCACHE TY FAMILY SIZE FACE ROTATION DEVICE))
else
(* ;; "If all NILs, don't want the default font")
(SPREADFONTSPEC (\FONT.CHECKARGS (OR FAMILY '*)
(OR SIZE '*)
(OR FACE '*)
(OR ROTATION '*)
(OR DEVICE '*)
T))
(LET ((NFLUSHED 0)
FONTX)
(DECLARE (SPECVARS NFLUSHED))
[MAPMULTI (SELECTQ TYPE
(:INCORE \FONTSINCORE)
(:EXISTS \FONTEXISTS?-CACHE)
(:AVAILABLE \FONTSAVAILABLEFILECACHE)
(\ILLEGAL.ARG TYPE))
(FUNCTION (LAMBDA (FM S FC R DPAIR)
(CL:WHEN (AND (OR (EQ FAMILY FM)
(EQ FAMILY '*))
(OR (EQ SIZE S)
(EQ SIZE '*))
(MATCHFONTFACE FACE FC)
(OR (EQ ROTATION R)
(EQ ROTATION '*))
(OR (EQ DEVICE (CAR DPAIR))
(EQ DEVICE '*))
(CDR DPAIR))
(ADD NFLUSHED 1)
(RPLACD DPAIR))]
(LIST TYPE NFLUSHED])
(FLUSHFONTSINCORE
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 26-Sep-2025 10:04 by rmk")
(* ; "Edited 4-Sep-2025 10:14 by rmk")
(* ; "Edited 28-Aug-2025 14:44 by rmk")
(* ; "Edited 18-Aug-2025 00:33 by rmk")
(* ; "Edited 12-Aug-2025 21:07 by rmk")
(* ; "Edited 21-Jul-2025 08:59 by rmk")
(* ; "Edited 21-Jun-2025 11:19 by rmk")
(DECLARE (SPECVARS . T)
(GLOBALVARS \FONTSINCORE \FONTEXISTS?-CACHE))
(SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE))
(LET ((INCOREFLUSHED 0)
(EXISTSFLUSHED 0))
(DECLARE (SPECVARS INCOREFLUSHED EXISTSFLUSHED))
[MAPMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R DPAIR)
(CL:WHEN (AND (OR (EQ FAMILY FM)
(EQ FAMILY '*))
(OR (EQ SIZE S)
(EQ SIZE '*))
(MATCHFONTFACE FACE FC)
(OR (EQ ROTATION R)
(EQ ROTATION '*))
(OR (EQ DEVICE (CAR DPAIR))
(EQ DEVICE '*))
(CDR DPAIR))
(ADD INCOREFLUSHED 1)
(RPLACD DPAIR))]
[MAPMULTI \FONTEXISTS?-CACHE (FUNCTION (LAMBDA (FM S FC R DPAIR)
(CL:WHEN (AND (OR (EQ FAMILY FM)
(EQ FAMILY '*))
(OR (EQ SIZE S)
(EQ SIZE '*))
(MATCHFONTFACE FACE FC)
(OR (EQ ROTATION R)
(EQ ROTATION '*))
(OR (EQ DEVICE (CAR DPAIR))
(EQ DEVICE '*))
(CDR DPAIR))
(ADD EXISTSFLUSHED 1)
(RPLACD DPAIR))]
(LIST INCOREFLUSHED EXISTSFLUSHED])
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 22-Nov-2025 10:23 by rmk")
(FLUSHFONTCACHE :INCORE FAMILY SIZE FACE ROTATION DEVICE])
(FINDFONTFILES
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 28-Aug-2025 14:45 by rmk")
@@ -3072,7 +3040,10 @@
(EQ PEXPANSION '*])
(MAKEFONTFACE
[LAMBDA (WEIGHT SLOPE EXPANSION BASE COLOR) (* ; "Edited 30-Aug-2025 10:22 by rmk")
[LAMBDA (WEIGHT SLOPE EXPANSION BASE COLOR) (* ; "Edited 7-Nov-2025 08:50 by rmk")
(* ; "Edited 30-Aug-2025 10:22 by rmk")
(CL:WHEN (FONTP BASE)
(SETQ BASE (FONTPROP BASE 'FACE)))
(CL:UNLESS WEIGHT
(SETQ WEIGHT (CL:IF BASE
(fetch (FONTFACE WEIGHT) of BASE)
@@ -3131,7 +3102,19 @@
(RPAQ? \FONTEXISTS?-CACHE NIL)
(RPAQ? \FONTSAVAILABLEFILECACHE NIL)
(RPAQ? \DEFAULTDEVICEFONTS NIL)
(* ;;
"The INITVARS value of MEDLEY-INIT-VARS in MEDLEY dalso includes these entries. That's because FONT is in the INIT, so these entries would be lost when MEDLEY-INIT-VARS is reinitialized when the Lisp loadup starts"
)
(ADDTOVAR MEDLEY-INIT-VARS (\FONTEXISTS?-CACHE NIL RESET)
(\FONTSAVAILABLEFILECACHE NIL RESET))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
@@ -3399,19 +3382,6 @@
(CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR))
(SLUGCHARSET (ADD1 \MAXCHARSET)))
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS LEGACYFONTS MACRO ((F . FORMS) (* ;
 "Execute FORMS in a legacy font environment")
(RESETLST
(RESETSAVE \FONTSINCORE NIL)
(RESETSAVE \FONTEXISTS?-CACHE)
(RESETSAVE DISPLAYFONTCOERCIONS)
(RESETSAVE DISPLAYCHARCOERCIONS)
(RESETSAVE DISPLAYFONTEXTENSIONS '(DISPLAYFONT))
(RESETSAVE DISPLAYFONTDIRECTORIES (MEDLEYDIR "fonts>displayfonts>"))
(PROGN F . FORMS))))
)
(* "END EXPORTED DEFINITIONS")
@@ -4563,7 +4533,7 @@
(PALATINO CLASSIC)
(OPTIMA MODERN)
(BOLDPS CLASSIC)
(PCTERMINAL)
(PCTERMINAL CLASSIC)
(TITANLEGAL CLASSIC)))
(RPAQ? \DEFAULTCHARSET 0)
@@ -4627,43 +4597,44 @@
(ADDTOVAR LAMA FONTCOPY)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (12196 21909 (CHARWIDTH 12206 . 12991) (CHARWIDTHY 12993 . 14510) (STRINGWIDTH 14512 .
15605) (\CHARWIDTH.DISPLAY 15607 . 16020) (\STRINGWIDTH.DISPLAY 16022 . 16446) (\STRINGWIDTH.GENERIC
16448 . 21907)) (21910 28430 (DEFAULTFONT 21920 . 23205) (FONTCLASS 23207 . 25369) (FONTCLASSUNPARSE
25371 . 26270) (FONTCLASSCOMPONENT 26272 . 26860) (SETFONTCLASSCOMPONENT 26862 . 27304) (
GETFONTCLASSCOMPONENT 27306 . 28428)) (30109 54490 (FONTCREATE 30119 . 33364) (FONTCREATE1 33366 .
35981) (FONTCREATE.SLUGFD 35983 . 37465) (\FONT.CHECKARGS 37467 . 44057) (\FONT.CHECKARGS1 44059 .
48582) (\FONTCREATE1.NOFN 48584 . 48798) (FONTFILEP 48800 . 49688) (\READCHARSET 49690 . 54488)) (
54491 61408 (\FONT.CHECKARGS 54501 . 61091) (\CHARSET.CHECK 61093 . 61406)) (61409 64492 (
COERCEFONTSPEC 61419 . 64490)) (66562 67352 (MAKEFONTSPEC 66572 . 67350)) (67353 74127 (COMPLETE.FONT
67363 . 69886) (COMPLETEFONTP 69888 . 70511) (COMPLETE.CHARSET 70513 . 73198) (PRUNESLUGCSINFOS 73200
. 74125)) (74166 82087 (FONTASCENT 74176 . 74560) (FONTDESCENT 74562 . 75047) (FONTHEIGHT 75049 .
75451) (FONTPROP 75453 . 81364) (\AVGCHARWIDTH 81366 . 82085)) (82744 83652 (FONTDEVICEPROP 82754 .
83650)) (83698 84552 (EDITCHAR 83708 . 84550)) (84598 96788 (GETCHARBITMAP 84608 . 85732) (
PUTCHARBITMAP 85734 . 87892) (\GETCHARBITMAP.CSINFO 87894 . 89910) (\PUTCHARBITMAP.CSINFO 89912 .
96786)) (96789 117269 (MOVECHARBITMAP 96799 . 98693) (MOVEFONTCHARS 98695 . 102655) (\MOVEFONTCHAR
102657 . 107500) (\MOVEFONTCHARS.SOURCEDATA 107502 . 113607) (\MAKESLUGCHAR 113609 . 116144) (
SLUGCHARP.DISPLAY 116146 . 117267)) (118202 138340 (FONTFILES 118212 . 120045) (\FINDFONTFILE 120047
. 121764) (\FONTFILENAMES 121766 . 122761) (\FONTFILENAME 122763 . 126746) (\FONTFILENAME.OLD 126748
. 129697) (\FONTFILENAME.NEW 129699 . 131956) (FONTSPECFROMFILENAME 131958 . 136059) (
\FONTINFOFROMFILENAME.OLD 136061 . 138338)) (138607 174410 (FONTCOPY 138617 . 143680) (FONTP 143682 .
143981) (FONTUNPARSE 143983 . 145702) (SETFONTDESCRIPTOR 145704 . 147168) (\STREAMCHARWIDTH 147170 .
151334) (\COERCECHARSET 151336 . 153931) (\BUILDSLUGCSINFO 153933 . 157556) (\FONTSYMBOL 157558 .
158208) (\DEVICESYMBOL 158210 . 159079) (\FONTFACE 159081 . 166271) (\FONTFACE.COLOR 166273 . 173193)
(SETFONTCHARENCODING 173195 . 174408)) (174411 194962 (FONTSAVAILABLE 174421 . 179276) (FONTEXISTS?
179278 . 183256) (\SEARCHFONTFILES 183258 . 186343) (FLUSHFONTSINCORE 186345 . 189518) (FINDFONTFILES
189520 . 192734) (SORTFONTSPECS 192736 . 194960)) (194963 198386 (MATCHFONTFACE 194973 . 195788) (
MAKEFONTFACE 195790 . 196630) (FONTFACETOATOM 196632 . 198384)) (198614 199106 (\UNITWIDTHSVECTOR
198624 . 199104)) (214449 216516 (FONTDESCRIPTOR.DEFPRINT 214459 . 216038) (FONTCLASS.DEFPRINT 216040
. 216514)) (220345 223135 (\CREATEKERNELEMENT 220355 . 220713) (\FSETLEFTKERN 220715 . 221206) (
\FGETLEFTKERN 221208 . 223133)) (223136 232772 (\CREATEFONT 223146 . 224585) (\CREATECHARSET 224587 .
228523) (\INSTALLCHARSETINFO 228525 . 231859) (\INSTALLCHARSETINFO.CHARENCODING 231861 . 232770)) (
233094 234458 (\FONTRESETCHARWIDTHS 233104 . 234456)) (235088 245135 (\CREATEDISPLAYFONT 235098 .
236947) (\CREATECHARSET.DISPLAY 236949 . 242658) (\FONTEXISTS?.DISPLAY 242660 . 245133)) (245136
260001 (STRIKEFONT.FILEP 245146 . 246034) (STRIKEFONT.GETCHARSET 246036 . 251628) (WRITESTRIKEFONTFILE
251630 . 256541) (STRIKECSINFO 256543 . 259999)) (260032 276349 (MAKEBOLD.CHARSET 260042 . 263691) (
MAKEBOLD.CHAR 263693 . 265445) (MAKEITALIC.CHARSET 265447 . 269120) (MAKEITALIC.CHAR 269122 . 271468)
(\SFMAKEBOLD 271470 . 273694) (\SFMAKEITALIC 273696 . 276347)) (276350 280499 (\SFMAKEROTATEDFONT
276360 . 277761) (\SFROTATECSINFO 277763 . 278400) (\SFROTATEFONTCHARACTERS 278402 . 278782) (
\SFROTATECSINFOOFFSETS 278784 . 280497)) (280500 281881 (\SFMAKECOLOR 280510 . 281879)))))
(FILEMAP (NIL (12152 21865 (CHARWIDTH 12162 . 12947) (CHARWIDTHY 12949 . 14466) (STRINGWIDTH 14468 .
15561) (\CHARWIDTH.DISPLAY 15563 . 15976) (\STRINGWIDTH.DISPLAY 15978 . 16402) (\STRINGWIDTH.GENERIC
16404 . 21863)) (21866 28386 (DEFAULTFONT 21876 . 23161) (FONTCLASS 23163 . 25325) (FONTCLASSUNPARSE
25327 . 26226) (FONTCLASSCOMPONENT 26228 . 26816) (SETFONTCLASSCOMPONENT 26818 . 27260) (
GETFONTCLASSCOMPONENT 27262 . 28384)) (30099 47603 (FONTCREATE 30109 . 33354) (FONTCREATE1 33356 .
35971) (FONTCREATE.SLUGFD 35973 . 37455) (\FONT.CHECKARGS1 37457 . 41980) (\FONTCREATE1.NOFN 41982 .
42196) (FONTFILEP 42198 . 43086) (\READCHARSET 43088 . 47601)) (47604 54680 (\FONT.CHECKARGS 47614 .
54363) (\CHARSET.CHECK 54365 . 54678)) (54681 57941 (COERCEFONTSPEC 54691 . 57939)) (60136 61475 (
MAKEFONTSPEC 60146 . 61473)) (61476 69653 (COMPLETE.FONT 61486 . 64009) (COMPLETEFONTP 64011 . 64634)
(COMPLETE.CHARSET 64636 . 67321) (PRUNESLUGCSINFOS 67323 . 68248) (MONOSPACEFONTP 68250 . 69651)) (
69692 77947 (FONTASCENT 69702 . 70086) (FONTDESCENT 70088 . 70573) (FONTHEIGHT 70575 . 70977) (
FONTPROP 70979 . 77224) (\AVGCHARWIDTH 77226 . 77945)) (78604 79512 (FONTDEVICEPROP 78614 . 79510)) (
79558 80412 (EDITCHAR 79568 . 80410)) (80458 92648 (GETCHARBITMAP 80468 . 81592) (PUTCHARBITMAP 81594
. 83752) (\GETCHARBITMAP.CSINFO 83754 . 85770) (\PUTCHARBITMAP.CSINFO 85772 . 92646)) (92649 113129 (
MOVECHARBITMAP 92659 . 94553) (MOVEFONTCHARS 94555 . 98515) (\MOVEFONTCHAR 98517 . 103360) (
\MOVEFONTCHARS.SOURCEDATA 103362 . 109467) (\MAKESLUGCHAR 109469 . 112004) (SLUGCHARP.DISPLAY 112006
. 113127)) (114062 135227 (FONTFILES 114072 . 115905) (\FINDFONTFILE 115907 . 118216) (\FONTFILENAMES
118218 . 119213) (\FONTFILENAME 119215 . 123198) (\FONTFILENAME.OLD 123200 . 126149) (
\FONTFILENAME.NEW 126151 . 128408) (FONTSPECFROMFILENAME 128410 . 132946) (\FONTINFOFROMFILENAME.OLD
132948 . 135225)) (135494 171297 (FONTCOPY 135504 . 140567) (FONTP 140569 . 140868) (FONTUNPARSE
140870 . 142589) (SETFONTDESCRIPTOR 142591 . 144055) (\STREAMCHARWIDTH 144057 . 148221) (
\COERCECHARSET 148223 . 150818) (\BUILDSLUGCSINFO 150820 . 154443) (\FONTSYMBOL 154445 . 155095) (
\DEVICESYMBOL 155097 . 155966) (\FONTFACE 155968 . 163158) (\FONTFACE.COLOR 163160 . 170080) (
SETFONTCHARENCODING 170082 . 171295)) (171298 191597 (FONTSAVAILABLE 171308 . 176662) (FONTEXISTS?
176664 . 180642) (\SEARCHFONTFILES 180644 . 183729) (FLUSHFONTCACHE 183731 . 185954) (FLUSHFONTSINCORE
185956 . 186153) (FINDFONTFILES 186155 . 189369) (SORTFONTSPECS 189371 . 191595)) (191598 195207 (
MATCHFONTFACE 191608 . 192423) (MAKEFONTFACE 192425 . 193451) (FONTFACETOATOM 193453 . 195205)) (
195838 196330 (\UNITWIDTHSVECTOR 195848 . 196328)) (210924 212991 (FONTDESCRIPTOR.DEFPRINT 210934 .
212513) (FONTCLASS.DEFPRINT 212515 . 212989)) (216820 219610 (\CREATEKERNELEMENT 216830 . 217188) (
\FSETLEFTKERN 217190 . 217681) (\FGETLEFTKERN 217683 . 219608)) (219611 229247 (\CREATEFONT 219621 .
221060) (\CREATECHARSET 221062 . 224998) (\INSTALLCHARSETINFO 225000 . 228334) (
\INSTALLCHARSETINFO.CHARENCODING 228336 . 229245)) (229569 230933 (\FONTRESETCHARWIDTHS 229579 .
230931)) (231563 241610 (\CREATEDISPLAYFONT 231573 . 233422) (\CREATECHARSET.DISPLAY 233424 . 239133)
(\FONTEXISTS?.DISPLAY 239135 . 241608)) (241611 256476 (STRIKEFONT.FILEP 241621 . 242509) (
STRIKEFONT.GETCHARSET 242511 . 248103) (WRITESTRIKEFONTFILE 248105 . 253016) (STRIKECSINFO 253018 .
256474)) (256507 272824 (MAKEBOLD.CHARSET 256517 . 260166) (MAKEBOLD.CHAR 260168 . 261920) (
MAKEITALIC.CHARSET 261922 . 265595) (MAKEITALIC.CHAR 265597 . 267943) (\SFMAKEBOLD 267945 . 270169) (
\SFMAKEITALIC 270171 . 272822)) (272825 276974 (\SFMAKEROTATEDFONT 272835 . 274236) (\SFROTATECSINFO
274238 . 274875) (\SFROTATEFONTCHARACTERS 274877 . 275257) (\SFROTATECSINFOOFFSETS 275259 . 276972)) (
276975 278356 (\SFMAKECOLOR 276985 . 278354)))))
STOP

BIN
sources/FONT.LCOM
View File

Binary file not shown.

64
sources/HLDISPLAY
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Aug-2025 11:38:16" {WMEDLEY}<sources>HLDISPLAY.;3 205136
(FILECREATED "24-Dec-2025 21:06:38" {WMEDLEY}<sources>HLDISPLAY.;4 205147
:EDIT-BY rmk
:CHANGES-TO (FNS EDITBM)
:CHANGES-TO (VARS HLDISPLAYCOMS)
:PREVIOUS-DATE " 2-Aug-2025 10:16:35" {WMEDLEY}<sources>HLDISPLAY.;2)
:PREVIOUS-DATE "29-Aug-2025 11:38:16" {WMEDLEY}<sources>HLDISPLAY.;3)
(PRETTYCOMPRINT HLDISPLAYCOMS)
@@ -3508,38 +3508,38 @@
DEST-WORD-WIDTH)))
DESTINATION))
(PUTPROPS HLDISPLAY FILETYPE CL:COMPILE-FILE)
(PUTPROPS HLDISPLAY FILETYPE :FAKE-COMPILE-FILE)
(READVARS-FROM-STRINGS '(\4BITEXPANSIONTABLE)
"({Y16 SMALLPOSP 0 0 15 240 255 3840 3855 4080 4095 61440 61455 61680 61695 65280 65295 65520 65535 })
")
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4649 11812 (GRID 4659 . 8930) (GRIDXCOORD 8932 . 9437) (GRIDYCOORD 9439 . 9948) (
LEFTOFGRIDCOORD 9950 . 10387) (BOTTOMOFGRIDCOORD 10389 . 10650) (SHADEGRIDBOX 10652 . 11810)) (11868
12276 (INSIDE? 11878 . 12274)) (12314 16710 (MOUSESTATE-EXPR 12324 . 15979) (MOUSESTATE-NAME 15981 .
16708)) (20200 21185 (DECODEBUTTONS 20210 . 21183)) (21186 22198 (PTDIFFERENCE 21196 . 21705) (PTPLUS
21707 . 22196)) (22249 50152 (GETPOSITION 22259 . 22567) (GETBOXPOSITION 22569 . 23252) (
DSPYSCREENTOWINDOW 23254 . 23738) (DSPXSCREENTOWINDOW 23740 . 24224) (GETREGION 24226 . 24775) (
\GETREGION.PACKPTS 24777 . 25345) (\GETREGION.CHECKBASEPT 25347 . 27290) (\GETREGION.CHECKOPPT 27292
. 30102) (\GETREGIONTRACKWITHBOX 30104 . 36635) (\UPDATEXYANDBOX 36637 . 39016) (GETBOXREGION 39018
. 39492) (\TRACKWITHBOX 39494 . 44632) (MOVEBOX 44634 . 45264) (DRAWGRAYBOX 45266 . 45788) (BLTHLINE
45790 . 46040) (BLTVLINE 46042 . 46281) (SETCORNER 46283 . 47549) (GETSCREENPOSITION 47551 . 48164) (
GETBOXSCREENPOSITION 48166 . 48777) (GETSCREENREGION 48779 . 49435) (GETBOXSCREENREGION 49437 . 50150)
) (50238 67054 (\MEDW.GETSCREENPOSITION 50248 . 52041) (\MEDW.GETBOXSCREENPOSITION 52043 . 55597) (
\MEDW.GETSCREENREGION 55599 . 67052)) (67055 74793 (GETGRIDBOXREGION 67065 . 74719) (\RANGELIMIT 74721
. 74791)) (74794 77844 (MOUSECONFIRM 74804 . 77842)) (77985 79354 (NEAREST/PT/ON/GRID 77995 . 78590)
(PTON10GRID 78592 . 78917) (NEAREST/MULTIPLE 78919 . 79352)) (81398 85300 (\SW2BM 81408 . 84106) (
COMPOSEREGS 84108 . 84662) (TRANSLATEREG 84664 . 85298)) (85342 176197 (EDITBM 85352 . 95681) (
EDITBMSCROLLFN 95683 . 110836) (EDITBMCLOSEFN 110838 . 111455) (TILEAREA 111457 . 111848) (
EDITBMBUTTONFN 111850 . 136677) (\EDITBM/PUTUP/DISPLAY 136679 . 137581) (\EDITBMHOWMUCH 137583 .
138569) (EDITBMRESHAPEFN 138571 . 147257) (EDITBMREPAINTFN 147259 . 148578) (UPDATE/SHADE/DISPLAY
148580 . 149027) (UPDATE/BM/DISPLAY/SELECTED/REGION 149029 . 150143) (SHOWBUTTON 150145 . 150703) (
RESETGRID.NEW 150705 . 154054) (RESETGRID 154056 . 154880) (\READBMDIMENSIONS 154882 . 155919) (
EDITSHADE 155921 . 164647) (\BITMAPFROMTEXTURE 164649 . 165347) (EDITSHADEREPAINTFN 165349 . 167123) (
GRAYBOXAREA 167125 . 167808) (\SHADEBITS 167810 . 170775) (READHOTSPOT 170777 . 174642) (WBOX 174644
. 175368) (\CLEARBM 175370 . 175569) (EDITBMTEXTURE 175571 . 176195)) (177542 185249 (SCALEBM 177552
. 179618) (BLTPATTERN 179620 . 182138) (BLTPATTERN.REPLACEDISPLAY 182140 . 184229) (
BLTPATTERN.GENERIC 184231 . 185247)) (185250 197069 (EXPANDBITMAP 185260 . 187784) (EXPANDBM 187786 .
194341) (SHRINKBITMAP 194343 . 195687) (\FAST4BIT 195689 . 197067)) (197071 201060 (ROTATE-BITMAP
197071 . 201060)) (201062 204898 (ROTATE-BITMAP-LEFT 201062 . 204898)))))
(FILEMAP (NIL (4657 11820 (GRID 4667 . 8938) (GRIDXCOORD 8940 . 9445) (GRIDYCOORD 9447 . 9956) (
LEFTOFGRIDCOORD 9958 . 10395) (BOTTOMOFGRIDCOORD 10397 . 10658) (SHADEGRIDBOX 10660 . 11818)) (11876
12284 (INSIDE? 11886 . 12282)) (12322 16718 (MOUSESTATE-EXPR 12332 . 15987) (MOUSESTATE-NAME 15989 .
16716)) (20208 21193 (DECODEBUTTONS 20218 . 21191)) (21194 22206 (PTDIFFERENCE 21204 . 21713) (PTPLUS
21715 . 22204)) (22257 50160 (GETPOSITION 22267 . 22575) (GETBOXPOSITION 22577 . 23260) (
DSPYSCREENTOWINDOW 23262 . 23746) (DSPXSCREENTOWINDOW 23748 . 24232) (GETREGION 24234 . 24783) (
\GETREGION.PACKPTS 24785 . 25353) (\GETREGION.CHECKBASEPT 25355 . 27298) (\GETREGION.CHECKOPPT 27300
. 30110) (\GETREGIONTRACKWITHBOX 30112 . 36643) (\UPDATEXYANDBOX 36645 . 39024) (GETBOXREGION 39026
. 39500) (\TRACKWITHBOX 39502 . 44640) (MOVEBOX 44642 . 45272) (DRAWGRAYBOX 45274 . 45796) (BLTHLINE
45798 . 46048) (BLTVLINE 46050 . 46289) (SETCORNER 46291 . 47557) (GETSCREENPOSITION 47559 . 48172) (
GETBOXSCREENPOSITION 48174 . 48785) (GETSCREENREGION 48787 . 49443) (GETBOXSCREENREGION 49445 . 50158)
) (50246 67062 (\MEDW.GETSCREENPOSITION 50256 . 52049) (\MEDW.GETBOXSCREENPOSITION 52051 . 55605) (
\MEDW.GETSCREENREGION 55607 . 67060)) (67063 74801 (GETGRIDBOXREGION 67073 . 74727) (\RANGELIMIT 74729
. 74799)) (74802 77852 (MOUSECONFIRM 74812 . 77850)) (77993 79362 (NEAREST/PT/ON/GRID 78003 . 78598)
(PTON10GRID 78600 . 78925) (NEAREST/MULTIPLE 78927 . 79360)) (81406 85308 (\SW2BM 81416 . 84114) (
COMPOSEREGS 84116 . 84670) (TRANSLATEREG 84672 . 85306)) (85350 176205 (EDITBM 85360 . 95689) (
EDITBMSCROLLFN 95691 . 110844) (EDITBMCLOSEFN 110846 . 111463) (TILEAREA 111465 . 111856) (
EDITBMBUTTONFN 111858 . 136685) (\EDITBM/PUTUP/DISPLAY 136687 . 137589) (\EDITBMHOWMUCH 137591 .
138577) (EDITBMRESHAPEFN 138579 . 147265) (EDITBMREPAINTFN 147267 . 148586) (UPDATE/SHADE/DISPLAY
148588 . 149035) (UPDATE/BM/DISPLAY/SELECTED/REGION 149037 . 150151) (SHOWBUTTON 150153 . 150711) (
RESETGRID.NEW 150713 . 154062) (RESETGRID 154064 . 154888) (\READBMDIMENSIONS 154890 . 155927) (
EDITSHADE 155929 . 164655) (\BITMAPFROMTEXTURE 164657 . 165355) (EDITSHADEREPAINTFN 165357 . 167131) (
GRAYBOXAREA 167133 . 167816) (\SHADEBITS 167818 . 170783) (READHOTSPOT 170785 . 174650) (WBOX 174652
. 175376) (\CLEARBM 175378 . 175577) (EDITBMTEXTURE 175579 . 176203)) (177550 185257 (SCALEBM 177560
. 179626) (BLTPATTERN 179628 . 182146) (BLTPATTERN.REPLACEDISPLAY 182148 . 184237) (
BLTPATTERN.GENERIC 184239 . 185255)) (185258 197077 (EXPANDBITMAP 185268 . 187792) (EXPANDBM 187794 .
194349) (SHRINKBITMAP 194351 . 195695) (\FAST4BIT 195697 . 197075)) (197079 201068 (ROTATE-BITMAP
197079 . 201068)) (201070 204906 (ROTATE-BITMAP-LEFT 201070 . 204906)))))
STOP

BIN
sources/HLDISPLAY.LCOM
View File

Binary file not shown.

72
sources/LLKEY
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 5-May-2025 20:57:08" {WMEDLEY}<sources>LLKEY.;15 199508
(FILECREATED "12-Nov-2025 16:40:50" {WMEDLEY}<sources>LLKEY.;18 199501
:EDIT-BY rmk
:CHANGES-TO (VARS \MAIKOKEYACTIONS \KEYNAMES)
:CHANGES-TO (VARS \ORIGKEYACTIONS)
:PREVIOUS-DATE " 4-Apr-2025 17:10:10" {WMEDLEY}<sources>LLKEY.;11)
:PREVIOUS-DATE "12-Nov-2025 15:56:25" {WMEDLEY}<sources>LLKEY.;17)
(PRETTYCOMPRINT LLKEYCOMS)
@@ -1591,7 +1591,7 @@
(12 ("/" "?" NOLOCKSHIFT))
(13 ("\" "|" NOLOCKSHIFT))
(14 ("LF" "`" NOLOCKSHIFT))
(15 ("Bs" "Bs" NOLOCKSHIFT))
(15 ("Bs" "^W" NOLOCKSHIFT))
(16 ("3" "#" NOLOCKSHIFT))
(17 ("2" "@" NOLOCKSHIFT))
(18 ("w" "W" LOCKSHIFT))
@@ -1771,7 +1771,7 @@
(66 ("Function,G" "Function,g" NOLOCKSHIFT))
(104 ("Function,H" "Function,h" NOLOCKSHIFT))
(80 ("Function,I" "Function,i" NOLOCKSHIFT))
(13 ("^W" "^U" NOLOCKSHIFT))
(13 (RUBOUT "^U" NOLOCKSHIFT))
(33 ("Esc" "Esc" NOLOCKSHIFT))
(65 ("Esc" "Esc" NOLOCKSHIFT))
(2 ("6" "^" NOLOCKSHIFT))
@@ -1851,9 +1851,9 @@
(4 ("7" "'" NOLOCKSHIFT))
(8 ("0" "0" NOLOCKSHIFT))
(10 ("\" "_" NOLOCKSHIFT))
(13 ("^W" "^U" NOLOCKSHIFT))
(13 (RUBOUT "^U" NOLOCKSHIFT))
(14 METADOWN . METAUP)
(15 ("Bs" "Bs" NOLOCKSHIFT))
(15 ("Bs" "^W" NOLOCKSHIFT))
(17 ("2" "%"" NOLOCKSHIFT))
(22 ("9" ")" NOLOCKSHIFT))
(28 (":" "*" NOLOCKSHIFT))
@@ -3916,33 +3916,33 @@
(ADDTOVAR LAMA CURSORPROP METASHIFT MOUSECHORDWAIT)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (14602 21918 (BKSYSCHARCODE 14612 . 14961) (\CLEARSYSBUF 14963 . 15521) (\GETKEY 15523
. 16698) (\NSYSBUFCHARS 16700 . 17442) (\SAVESYSBUF 17444 . 19053) (\SYSBUFP 19055 . 19359) (
\GETSYSBUF 19361 . 19541) (\PUTSYSBUF 19543 . 20756) (\PEEKSYSBUF 20758 . 21916)) (23203 60761 (
\KEYBOARDINIT 23213 . 24933) (\KEYBOARDEVENTFN 24935 . 29635) (\ALLOCLOCKED 29637 . 30227) (
\SETIOPOINTERS 30229 . 34765) (\KEYBOARDOFF 34767 . 35181) (\KEYBOARDON 35183 . 35562) (\KEYHANDLER
35564 . 35695) (\KEYHANDLER1 35697 . 43143) (\RESETKEYBOARD 43145 . 44793) (\DOMOUSECHORDING 44795 .
48615) (\DOTRANSITIONS 48617 . 49294) (\DECODETRANSITION 49296 . 56709) (MOUSECHORDWAIT 56711 . 57375)
(\TRACKCURSOR 57377 . 60759)) (95227 117100 (KEYACTION 95237 . 96090) (KEYACTIONTABLE 96092 . 97274)
(KEYBOARDTYPE 97276 . 98378) (RESETKEYACTION 98380 . 100139) (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
100141 . 102043) (\KEYACTION1 102045 . 112161) (KEYDOWNP 112163 . 112498) (KEYNUMBERP 112500 . 112698)
(\KEYNAMETONUMBER 112700 . 113394) (\KEYNUMBERTONAME 113396 . 113586) (MODIFY.KEYACTIONS 113588 .
114449) (METASHIFT 114451 . 115395) (SHIFTDOWNP 115397 . 117098)) (117163 117459 (
SETUP.OFFICE.KEYBOARD 117173 . 117457)) (120438 122150 (\INIT.KEYBOARD.STREAM 120448 . 122148)) (
122415 138792 (\DOBUFFEREDTRANSITIONS 122425 . 137855) (\TIMER.INTERRUPTFRAME 137857 . 138582) (
\PERIODIC.INTERRUPTFRAME 138584 . 138790)) (139046 143123 (\HARDCURSORUP 139056 . 140938) (
\HARDCURSORPOSITION 140940 . 142976) (\HARDCURSORDOWN 142978 . 143121)) (143124 167184 (CURSOR.INIT
143134 . 146834) (\CURSORDESTINATION 146836 . 149154) (\SOFTCURSORUP 149156 . 154410) (
\SOFTCURSORUPCURRENT 154412 . 161448) (\SOFTCURSORPOSITION 161450 . 162215) (\SOFTCURSORDOWN 162217 .
162925) (CURSORPROP 162927 . 163269) (GETCURSORPROP 163271 . 163459) (PUTCURSORPROP 163461 . 164616) (
\CURSORBITSPERPIXEL 164618 . 166734) (\CURSORIMAGEPROPNAME 166736 . 166960) (\CURSORMASKPROPNAME
166962 . 167182)) (167185 185135 (CURSORCREATE 167195 . 169870) (CURSOR 169872 . 171684) (
\CURSOR-VALID-P 171686 . 172773) (\CURSORUP 172775 . 174490) (\CURSORPOSITION 174492 . 177020) (
\CURSORDOWN 177022 . 177255) (ADJUSTCURSORPOSITION 177257 . 177835) (CURSORPOSITION 177837 . 179379) (
CURSORSCREEN 179381 . 180037) (CURSOREXIT 180039 . 181430) (FLIPCURSOR 181432 . 182558) (FLIPCURSORBAR
182560 . 183540) (LASTMOUSEX 183542 . 183796) (LASTMOUSEY 183798 . 184052) (CREATEPOSITION 184054 .
184260) (POSITIONP 184262 . 184546) (CURSORHOTSPOT 184548 . 185133)) (186373 187921 (GETMOUSESTATE
186383 . 187042) (\EVENTKEYS 187044 . 187919)) (194120 194916 (MACHINETYPE 194130 . 194530) (
SETMAINTPANEL 194532 . 194914)) (194946 196085 (BEEPON 194956 . 195609) (BEEPOFF 195611 . 196083)) (
196536 196799 (WITHOUT-INTERRUPTS 196546 . 196797)))))
(FILEMAP (NIL (14591 21907 (BKSYSCHARCODE 14601 . 14950) (\CLEARSYSBUF 14952 . 15510) (\GETKEY 15512
. 16687) (\NSYSBUFCHARS 16689 . 17431) (\SAVESYSBUF 17433 . 19042) (\SYSBUFP 19044 . 19348) (
\GETSYSBUF 19350 . 19530) (\PUTSYSBUF 19532 . 20745) (\PEEKSYSBUF 20747 . 21905)) (23192 60750 (
\KEYBOARDINIT 23202 . 24922) (\KEYBOARDEVENTFN 24924 . 29624) (\ALLOCLOCKED 29626 . 30216) (
\SETIOPOINTERS 30218 . 34754) (\KEYBOARDOFF 34756 . 35170) (\KEYBOARDON 35172 . 35551) (\KEYHANDLER
35553 . 35684) (\KEYHANDLER1 35686 . 43132) (\RESETKEYBOARD 43134 . 44782) (\DOMOUSECHORDING 44784 .
48604) (\DOTRANSITIONS 48606 . 49283) (\DECODETRANSITION 49285 . 56698) (MOUSECHORDWAIT 56700 . 57364)
(\TRACKCURSOR 57366 . 60748)) (95220 117093 (KEYACTION 95230 . 96083) (KEYACTIONTABLE 96085 . 97267)
(KEYBOARDTYPE 97269 . 98371) (RESETKEYACTION 98373 . 100132) (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
100134 . 102036) (\KEYACTION1 102038 . 112154) (KEYDOWNP 112156 . 112491) (KEYNUMBERP 112493 . 112691)
(\KEYNAMETONUMBER 112693 . 113387) (\KEYNUMBERTONAME 113389 . 113579) (MODIFY.KEYACTIONS 113581 .
114442) (METASHIFT 114444 . 115388) (SHIFTDOWNP 115390 . 117091)) (117156 117452 (
SETUP.OFFICE.KEYBOARD 117166 . 117450)) (120431 122143 (\INIT.KEYBOARD.STREAM 120441 . 122141)) (
122408 138785 (\DOBUFFEREDTRANSITIONS 122418 . 137848) (\TIMER.INTERRUPTFRAME 137850 . 138575) (
\PERIODIC.INTERRUPTFRAME 138577 . 138783)) (139039 143116 (\HARDCURSORUP 139049 . 140931) (
\HARDCURSORPOSITION 140933 . 142969) (\HARDCURSORDOWN 142971 . 143114)) (143117 167177 (CURSOR.INIT
143127 . 146827) (\CURSORDESTINATION 146829 . 149147) (\SOFTCURSORUP 149149 . 154403) (
\SOFTCURSORUPCURRENT 154405 . 161441) (\SOFTCURSORPOSITION 161443 . 162208) (\SOFTCURSORDOWN 162210 .
162918) (CURSORPROP 162920 . 163262) (GETCURSORPROP 163264 . 163452) (PUTCURSORPROP 163454 . 164609) (
\CURSORBITSPERPIXEL 164611 . 166727) (\CURSORIMAGEPROPNAME 166729 . 166953) (\CURSORMASKPROPNAME
166955 . 167175)) (167178 185128 (CURSORCREATE 167188 . 169863) (CURSOR 169865 . 171677) (
\CURSOR-VALID-P 171679 . 172766) (\CURSORUP 172768 . 174483) (\CURSORPOSITION 174485 . 177013) (
\CURSORDOWN 177015 . 177248) (ADJUSTCURSORPOSITION 177250 . 177828) (CURSORPOSITION 177830 . 179372) (
CURSORSCREEN 179374 . 180030) (CURSOREXIT 180032 . 181423) (FLIPCURSOR 181425 . 182551) (FLIPCURSORBAR
182553 . 183533) (LASTMOUSEX 183535 . 183789) (LASTMOUSEY 183791 . 184045) (CREATEPOSITION 184047 .
184253) (POSITIONP 184255 . 184539) (CURSORHOTSPOT 184541 . 185126)) (186366 187914 (GETMOUSESTATE
186376 . 187035) (\EVENTKEYS 187037 . 187912)) (194113 194909 (MACHINETYPE 194123 . 194523) (
SETMAINTPANEL 194525 . 194907)) (194939 196078 (BEEPON 194949 . 195602) (BEEPOFF 195604 . 196076)) (
196529 196792 (WITHOUT-INTERRUPTS 196539 . 196790)))))
STOP

BIN
sources/LLKEY.LCOM
View File

Binary file not shown.

106
sources/LLPACKAGE
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
(IL:FILECREATED " 5-Sep-2024 17:42:20" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;3| 87515
(IL:FILECREATED " 2-Nov-2025 19:49:02" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;2| 92970
:EDIT-BY "mth"
:CHANGES-TO (IL:FNS XCL:DEFPACKAGE)
:PREVIOUS-DATE " 4-Sep-2024 13:17:23" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;2|
:PREVIOUS-DATE "30-Oct-2025 14:25:43" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;1|
)
@@ -524,7 +524,9 @@
(IL:DEFINEQ
(XCL:DEFPACKAGE
(IL:NLAMBDA IL:ARGS (IL:* IL:\; "Edited 4-Sep-2024 13:17 by mth")
(IL:NLAMBDA IL:ARGS (IL:* IL:\; "Edited 2-Nov-2025 19:48 by mth")
(IL:* IL:\; "Edited 30-Oct-2025 11:34 by mth")
(IL:* IL:\; "Edited 4-Sep-2024 13:17 by mth")
(IL:* IL:\; "Edited 2-Dec-87 10:39 by raf")
(IL:SETQ IL:ARGS (XCL:REMOVE-COMMENTS IL:ARGS))
(LET
@@ -571,6 +573,30 @@
IL:SYMBOL)))
PACKAGE))
(:IMPORT (IMPORT VALUES PACKAGE))
(:IMPORT-FROM (LET* ((PACKAGE-NAME (POP VALUES))
(XCL::PACKAGE-FROM (FIND-PACKAGE PACKAGE-NAME)))
(IMPORT (IL:MAPCAR VALUES
(IL:FUNCTION (IL:LAMBDA (XCL::SN)
(COND
((IL:LITATOM XCL::SN)
(SETQ XCL::SN
(SYMBOL-NAME
XCL::SN))))
(COND
((IL:STRINGP XCL::SN)
(OR (FIND-SYMBOL
XCL::SN
XCL::PACKAGE-FROM
)
(ERROR
"Symbol ~S not found in package ~S in :import-from option of defpackage"
XCL::SN
PACKAGE-NAME
)))
(T (IL:ERROR
"Bad object in :import-from option of defpackage "
XCL::SN))))))
PACKAGE)))
((:SHADOW :SHADOWING-IMPORT)
(LET ((IL:SYMBOLS-TO-SHADOW (IL:MAPCONC
VALUES
@@ -620,7 +646,8 @@
((:PREFIX-NAME :INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS
:EXTERNAL-ONLY)
(LIST IL:KEY (CAR VALUES)))
((:SHADOW :EXPORT :IMPORT :SHADOWING-IMPORT)
((:SHADOW :EXPORT :IMPORT :IMPORT-FROM
:SHADOWING-IMPORT)
(IL:SETQ IL:POST-MAKE-FORMS
(CONS (CONS IL:KEY VALUES)
IL:POST-MAKE-FORMS))
@@ -648,6 +675,37 @@
PACKAGE))
(:IMPORT (IMPORT (CDR IL:FORM)
PACKAGE))
(:IMPORT-FROM (LET* ((PACKAGE-NAME (CADR IL:FORM))
(XCL::PACKAGE-FROM (FIND-PACKAGE PACKAGE-NAME)))
(IMPORT (IL:MAPCAR (CDDR IL:FORM)
(IL:FUNCTION (IL:LAMBDA (XCL::SN)
(COND
((IL:LITATOM
XCL::SN)
(SETQ
XCL::SN
(SYMBOL-NAME
XCL::SN))))
(COND
((IL:STRINGP
XCL::SN)
(OR
(FIND-SYMBOL
XCL::SN
XCL::PACKAGE-FROM
)
(ERROR
"Symbol ~S not found in package ~S in :import-from option of defpackage"
XCL::SN
PACKAGE-NAME
)))
(T (IL:ERROR
"Bad object in :import-from option of defpackage "
XCL::SN)))))
)
PACKAGE)))
(:SHADOWING-IMPORT
(SHADOWING-IMPORT (CDR IL:FORM)
PACKAGE))
@@ -1663,7 +1721,7 @@
(IL:* IL:|;;| "Proper compiler, readtable and package environment")
(IL:PUTPROPS IL:LLPACKAGE IL:FILETYPE COMPILE-FILE)
(IL:PUTPROPS IL:LLPACKAGE IL:FILETYPE :FAKE-COMPILE-FILE)
(IL:PUTPROPS IL:LLPACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
@@ -1691,23 +1749,23 @@ IL:\\PKG-FIND-FREE-PACKAGE-INDEX 17838 . 18248)) (18305 18451 (IL:SETF-SYMBOL-PA
IL:ENTRY-HASH 20528 . 20919)) (20968 21314 (IL:COUNT-PACKAGE-HASHTABLE 20968 . 21314)) (21316 21488 (
IL:INTERNAL-SYMBOL-COUNT 21316 . 21488)) (21490 21608 (IL:EXTERNAL-SYMBOL-COUNT 21490 . 21608)) (21610
22766 (IL:ENTER-NEW-NICKNAMES 21610 . 22766)) (22768 23194 (IL:MAKE-PRIME-HASHTABLE-SIZE 22768 .
23194)) (23196 24845 (MAKE-PACKAGE 23196 . 24845)) (24846 34317 (XCL:DEFPACKAGE 24859 . 34315)) (34366
34588 (FIND-PACKAGE 34366 . 34588)) (34590 37951 (USE-PACKAGE 34590 . 37951)) (37953 38433 (
IN-PACKAGE 37953 . 38433)) (38435 38709 (XCL:PKG-GOTO 38435 . 38709)) (38711 39811 (RENAME-PACKAGE
38711 . 39811)) (39813 41264 (XCL:DELETE-PACKAGE 39813 . 41264)) (41266 44212 (EXPORT 41266 . 44212))
(44214 45457 (UNEXPORT 44214 . 45457)) (45459 47103 (IMPORT 45459 . 47103)) (47105 48385 (
SHADOWING-IMPORT 47105 . 48385)) (48387 49441 (SHADOW 48387 . 49441)) (49443 50098 (UNUSE-PACKAGE
49443 . 50098)) (50162 50468 (LIST-ALL-PACKAGES 50162 . 50468)) (50525 54208 (IL:ADD-SYMBOL 50525 .
54208)) (54210 58263 (IL:WITH-SYMBOL 54210 . 58263)) (58265 59568 (IL:INTERN* 58265 . 59568)) (59570
65402 (IL:FIND-SYMBOL* 59570 . 65402)) (65404 66855 (INTERN 65404 . 66855)) (66857 67435 (FIND-SYMBOL
66857 . 67435)) (67493 68389 (IL:NUKE-SYMBOL 67493 . 68389)) (68391 70505 (UNINTERN 68391 . 70505)) (
70507 71650 (IL:MOBY-UNINTERN 70507 . 71650)) (71709 71781 (IL:\\INDEXATOMPNAME 71709 . 71781)) (71893
72040 (IL:MAKE-DO-SYMBOLS-VARS 71893 . 72040)) (72042 73497 (IL:MAKE-DO-SYMBOLS-CODE 72042 . 73497))
(73501 74279 (DO-EXTERNAL-SYMBOLS 73501 . 74279)) (74281 75627 (XCL:DO-LOCAL-SYMBOLS 74281 . 75627)) (
75629 76745 (XCL:DO-INTERNAL-SYMBOLS 75629 . 76745)) (76747 79045 (DO-SYMBOLS 76747 . 79045)) (79047
80729 (DO-ALL-SYMBOLS 79047 . 80729)) (80797 81322 (FIND-ALL-SYMBOLS 80797 . 81322)) (81324 81603 (
IL:BRIEFLY-DESCRIBE-SYMBOL 81324 . 81603)) (81605 83119 (APROPOS 81605 . 83119)) (83121 84688 (
APROPOS-LIST 83121 . 84688)) (84792 86319 (IL:FIND-EXTERNAL-SYMBOL 84792 . 86319)) (86321 86841 (
IL:FIND-EXACT-SYMBOL 86321 . 86841)) (86843 86923 (IL:PACKAGE-NAME-AS-SYMBOL 86843 . 86923)) (86925
87074 (IL:\\FIND.PACKAGE.INTERNAL 86925 . 87074)))))
23194)) (23196 24845 (MAKE-PACKAGE 23196 . 24845)) (24846 39766 (XCL:DEFPACKAGE 24859 . 39764)) (39815
40037 (FIND-PACKAGE 39815 . 40037)) (40039 43400 (USE-PACKAGE 40039 . 43400)) (43402 43882 (
IN-PACKAGE 43402 . 43882)) (43884 44158 (XCL:PKG-GOTO 43884 . 44158)) (44160 45260 (RENAME-PACKAGE
44160 . 45260)) (45262 46713 (XCL:DELETE-PACKAGE 45262 . 46713)) (46715 49661 (EXPORT 46715 . 49661))
(49663 50906 (UNEXPORT 49663 . 50906)) (50908 52552 (IMPORT 50908 . 52552)) (52554 53834 (
SHADOWING-IMPORT 52554 . 53834)) (53836 54890 (SHADOW 53836 . 54890)) (54892 55547 (UNUSE-PACKAGE
54892 . 55547)) (55611 55917 (LIST-ALL-PACKAGES 55611 . 55917)) (55974 59657 (IL:ADD-SYMBOL 55974 .
59657)) (59659 63712 (IL:WITH-SYMBOL 59659 . 63712)) (63714 65017 (IL:INTERN* 63714 . 65017)) (65019
70851 (IL:FIND-SYMBOL* 65019 . 70851)) (70853 72304 (INTERN 70853 . 72304)) (72306 72884 (FIND-SYMBOL
72306 . 72884)) (72942 73838 (IL:NUKE-SYMBOL 72942 . 73838)) (73840 75954 (UNINTERN 73840 . 75954)) (
75956 77099 (IL:MOBY-UNINTERN 75956 . 77099)) (77158 77230 (IL:\\INDEXATOMPNAME 77158 . 77230)) (77342
77489 (IL:MAKE-DO-SYMBOLS-VARS 77342 . 77489)) (77491 78946 (IL:MAKE-DO-SYMBOLS-CODE 77491 . 78946))
(78950 79728 (DO-EXTERNAL-SYMBOLS 78950 . 79728)) (79730 81076 (XCL:DO-LOCAL-SYMBOLS 79730 . 81076)) (
81078 82194 (XCL:DO-INTERNAL-SYMBOLS 81078 . 82194)) (82196 84494 (DO-SYMBOLS 82196 . 84494)) (84496
86178 (DO-ALL-SYMBOLS 84496 . 86178)) (86246 86771 (FIND-ALL-SYMBOLS 86246 . 86771)) (86773 87052 (
IL:BRIEFLY-DESCRIBE-SYMBOL 86773 . 87052)) (87054 88568 (APROPOS 87054 . 88568)) (88570 90137 (
APROPOS-LIST 88570 . 90137)) (90241 91768 (IL:FIND-EXTERNAL-SYMBOL 90241 . 91768)) (91770 92290 (
IL:FIND-EXACT-SYMBOL 91770 . 92290)) (92292 92372 (IL:PACKAGE-NAME-AS-SYMBOL 92292 . 92372)) (92374
92523 (IL:\\FIND.PACKAGE.INTERNAL 92374 . 92523)))))
IL:STOP

BIN
sources/LLPACKAGE.LCOM
View File

Binary file not shown.

131
sources/MEDLEYDIR
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Aug-2025 17:25:03" {DSK}<home>larry>il>medley>sources>MEDLEYDIR.;36 12210
(FILECREATED "26-Nov-2025 21:51:39" {WMEDLEY}<sources>MEDLEYDIR.;43 15970
:EDIT-BY "lmm"
:EDIT-BY rmk
:CHANGES-TO (FNS MEDLEYDIR)
:CHANGES-TO (VARS MEDLEYDIRCOMS)
:PREVIOUS-DATE "18-Aug-2025 11:19:10" {DSK}<home>larry>il>medley>sources>MEDLEYDIR.;34)
:PREVIOUS-DATE "26-Nov-2025 17:12:16" {WMEDLEY}<sources>MEDLEYDIR.;42)
(PRETTYCOMPRINT MEDLEYDIRCOMS)
@@ -25,7 +25,47 @@
(* ;; "**WARNING** The EVALed expressions get run early in the lodup.")
(VARS MEDLEY-INIT-VARS)
(* ;; "The INITVARS prevents this from accumulating entries from other files that happen to have been loaded when this is worked on and saved. The loadup scripts set MEDLEY-INIT-VARS to NOBIND to make sure that these are the initial values (as opposed to whatever there was in the startup sysout. But the FONT cache variables have to be specified here, because FONT is in the INIT and the resetting to NOBIND would wipe out these entries even if they were already correct in the init sysout.")
[INITVARS (MEDLEY-INIT-VARS '((\FONTEXISTS?-CACHE NIL RESET)
(\FONTSAVAILABLEFILECACHE NIL RESET)
[LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers"
"internal"
"greetfiles"
"doctools"]
[LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources"]
(LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
(IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
(IRM.DINFOGRAPH)
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES
))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (OR (UNIX-GETENV
"LOGINDIR")
(UNIX-GETENV
"HOME"]
(AND (GETD 'PSEUDOHOSTS)
(TARGETHOST 'LI)
(PSEUDOHOST 'LI LHD))
LHD)
RESET)
(USERGREETFILES [LIST (CONS LOGINHOST/DIR '("INIT" COM))
(CONS LOGINHOST/DIR '("INIT"]
RESET)
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/medleydisplayfonts"
"fonts/displayfonts")
NIL NIL T))
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts"
)
NIL NIL T))
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
NIL NIL T))
(UNICODEDIRECTORIES (MEDLEYDIR '("unicode/xerox")
NIL NIL T))
(XCL::*WHERE-IS-CASH-FILES* (MEDLEYDIR '("loadups")
"whereis.hash" NIL T))
(LOADUPSDIRECTORIES (MEDLEYDIR '("loadups")
NIL NIL T]
(DECLARE%: EVAL@COMPILE DOCOPY (ADDVARS (GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS
\SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS])
@@ -201,50 +241,49 @@
(* ;; "**WARNING** The EVALed expressions get run early in the lodup.")
(RPAQQ MEDLEY-INIT-VARS
((ShellBrowser)
(ShellOpener)
[LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers" "internal" "greetfiles" "doctools"]
[LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources"]
(LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
(IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
(IRM.DINFOGRAPH)
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME"]
(AND (GETD 'PSEUDOHOSTS)
(TARGETHOST 'LI)
(PSEUDOHOST 'LI LHD))
LHD))
[USERGREETFILES (LIST (CONS LOGINHOST/DIR '("INIT" COM))
(CONS LOGINHOST/DIR '("INIT"]
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/medleydisplayfonts" "fonts/displayfonts")
NIL NIL T))
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")
NIL NIL T))
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
NIL NIL T))
(UNICODEDIRECTORIES (MEDLEYDIR '("unicode/xerox")
NIL NIL T))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME"]
(AND (GETD 'PSEUDOHOSTS)
(TARGETHOST 'LI)
(PSEUDOHOST 'LI LHD))
LHD)
RESET)
(USERGREETFILES [LIST (CONS LOGINHOST/DIR '("INIT" COM))
(CONS LOGINHOST/DIR '("INIT"]
RESET)
(XCL::*WHERE-IS-CASH-FILES* (MEDLEYDIR '("loadups")
"whereis.hash" NIL T))
(LOADUPSDIRECTORIES (MEDLEYDIR '("loadups")
NIL NIL T))))
(* ;;
"The INITVARS prevents this from accumulating entries from other files that happen to have been loaded when this is worked on and saved. The loadup scripts set MEDLEY-INIT-VARS to NOBIND to make sure that these are the initial values (as opposed to whatever there was in the startup sysout. But the FONT cache variables have to be specified here, because FONT is in the INIT and the resetting to NOBIND would wipe out these entries even if they were already correct in the init sysout."
)
(RPAQ? MEDLEY-INIT-VARS
'((\FONTEXISTS?-CACHE NIL RESET)
(\FONTSAVAILABLEFILECACHE NIL RESET)
[LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers" "internal" "greetfiles" "doctools"]
[LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources"]
(LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
(IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
(IRM.DINFOGRAPH)
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
(LOGINHOST/DIR (LET [(LHD (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
(UNIX-GETENV "HOME"]
(AND (GETD 'PSEUDOHOSTS)
(TARGETHOST 'LI)
(PSEUDOHOST 'LI LHD))
LHD)
RESET)
(USERGREETFILES [LIST (CONS LOGINHOST/DIR '("INIT" COM))
(CONS LOGINHOST/DIR '("INIT"]
RESET)
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/medleydisplayfonts" "fonts/displayfonts")
NIL NIL T))
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")
NIL NIL T))
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
NIL NIL T))
(UNICODEDIRECTORIES (MEDLEYDIR '("unicode/xerox")
NIL NIL T))
(XCL::*WHERE-IS-CASH-FILES* (MEDLEYDIR '("loadups")
"whereis.hash" NIL T))
(LOADUPSDIRECTORIES (MEDLEYDIR '("loadups")
NIL NIL T))))
(DECLARE%: EVAL@COMPILE DOCOPY
(ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS \SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1675 9578 (MEDLEY-INIT-VARS 1685 . 5163) (MEDLEYDIR 5165 . 8378) (MEDLEYSUBSTDIR 8380
. 9358) (SET-SYSOUT-COMMIT 9360 . 9576)))))
(FILEMAP (NIL (5329 13232 (MEDLEY-INIT-VARS 5339 . 8817) (MEDLEYDIR 8819 . 12032) (MEDLEYSUBSTDIR
12034 . 13012) (SET-SYSOUT-COMMIT 13014 . 13230)))))
STOP

BIN
sources/MEDLEYDIR.LCOM
View File

Binary file not shown.

425
sources/SEDIT-COMMANDS
View File

@@ -1,14 +1,13 @@
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL)) READTABLE "XCL" BASE 10)
(IL:FILECREATED "15-Aug-2021 21:22:22" 
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;7| 125181
IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-COMMANDSCOMS)
(IL:FILECREATED "13-Nov-2025 00:19:24" IL:|{WMEDLEY}<sources>SEDIT-COMMANDS.;5| 124301
IL:|previous| IL:|date:| "14-Aug-2021 12:59:29"
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
:EDIT-BY IL:|rmk|
:CHANGES-TO (IL:VARIABLES COMMAND-TABLE-SPEC)
:PREVIOUS-DATE "13-Nov-2025 00:14:31" IL:|{WMEDLEY}<sources>SEDIT-COMMANDS.;4|)
; Copyright (c) 1986-1988, 1990-1991, 2018, 2021 by Venue & Xerox Corporation.
(IL:PRETTYCOMPRINT IL:SEDIT-COMMANDSCOMS)
@@ -30,18 +29,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
IL:\; < > IL:\.))))
(IL:FUNCTIONS
(IL:* IL:|;;| "pseudo-selections")
(IL:* IL:|;;| "pseudo-selections")
PSEUDO-SELECTION-FROM-SELECTION COMPOSE-PSEUDO-SELECTION DECOMPOSE-PSEUDO-SELECTION
SELECTION-FROM-PSEUDO-SELECTION SELECT-PSEUDO-SEGMENT)
(IL:* IL:|;;| "user interface to adding new commands")
(IL:* IL:|;;| "user interface to adding new commands")
(IL:FUNCTIONS ADD-COMMAND GET-SELECTION REPLACE-SELECTION RESET-COMMANDS DEFAULT-COMMANDS)
(IL:VARIABLES DEFAULT-COMMAND-TABLE-SPEC FIRST-ADD-COMMAND FIRST-ADD-COMMAND-MENU-ENTRY)
(IL:FUNCTIONS
(IL:* IL:|;;| "building help menu")
(IL:* IL:|;;| "building help menu")
EQUALIZE-STRING-WIDTHS MINIMUM-STRING-WIDTH MAXIMUM-STRING-WIDTH)
(IL:FUNCTIONS FIND-AND-DISPLAY-STRUCTURE FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
@@ -65,8 +64,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(IL:PUTPROPS IL:SEDIT-COMMANDS IL:FILETYPE :COMPILE-FILE)
(IL:PUTPROPS IL:SEDIT-COMMANDS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
(DEFPACKAGE IL:SEDIT
(:USE IL:LISP IL:XCL))))
(DEFPACKAGE IL:SEDIT (:USE IL:LISP
IL:XCL))))
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
(IL:LOCALVARS . T)
@@ -78,10 +77,10 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFPARAMETER COMMAND-TABLE-SPEC
(IL:* IL:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: (<fn> <help menu entry> <normalize?> <key>+) where <fn> is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), <help menu entry> is a list of strings for the name, key-name, and help-string, <normalize?> is T if the caret should be normalized after this command, and <key>+ is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).")
(IL:* IL:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: (<fn> <help menu entry> <normalize?> <key>+) where <fn> is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), <help menu entry> is a list of strings for the name, key-name, and help-string, <normalize?> is T if the caret should be normalized after this command, and <key>+ is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).")
'(
(IL:* IL:|;;| "STRUCTURE CONTROL")
(IL:* IL:|;;| "STRUCTURE CONTROL")
(INSERT-NULL-LIST NIL T (IL:LEFTPAREN))
(CLOSE-LIST NIL NIL (IL:RIGHTPAREN))
@@ -104,7 +103,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
((INPUT-QUOTE COMMA-AT)
NIL NIL "@")
(IL:* IL:|;;| "EDIT CONTROL")
(IL:* IL:|;;| "EDIT CONTROL")
(DELETE-SELECTION NIL T IL:DEL)
(BACKSPACE NIL T IL:BS "^A")
@@ -114,7 +113,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
((VERIFY-STRUCTURE NIL T NIL)
NIL NIL "Meta,^L")
(IL:* IL:|;;| "COMPLETION")
(IL:* IL:|;;| "COMPLETION")
((COMPLETE :ABORT NIL)
("Abort" "M-A" "Complete this edit without installing changes.")
@@ -134,14 +133,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
("Done, Compile, & Close" "C-M-C" "Complete this edit, compile, and close the window.")
NIL "Meta,^C")
(IL:* IL:|;;| "COMMANDS")
(IL:* IL:|;;| "COMMANDS")
(NULL ("" "" "")
NIL 0)
(UNDO ("Undo" "M-U" "Undo the last change made.")
NIL "Meta,U" "Meta,u" "Function,^D" (UNDO))
NIL "Meta,U" "Meta,u" "Function,^D" (UNDO))
(REDO ("Redo" "M-R" "Redo the last change undone.")
NIL "Meta,R" "Meta,r" "Function,Bs" (REDO))
NIL "Meta,R" "Meta,r" "Function,Bs" (REDO))
(NULL ("" "" "")
NIL 0)
(FIND-OBJ ("Find" "M-F" "Find the current selection, or prompt for structure to Find.")
@@ -161,7 +160,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(EDIT-HELP ("Arglist" "M-H" "Show the argument list for the selected function.")
NIL "Meta,H" "Meta,h" "Function,^A" (ARGLIST))
(CONVERT-COMMENT ("Convert Comment" "M-;"
"Convert the old style comments in the current selection.")
"Convert the old style comments in the current selection.")
NIL "Meta,;")
(COMMENT-OUT-SELECTION NIL NIL "Meta,^;")
(EDIT-SELECTION ("Edit" "M-O" "Edit the definition of the current selection.")
@@ -173,13 +172,13 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
NIL "Meta,E" "Meta,e" (EVAL))
(EXPAND ("Expand" "M-X" "Replace the current selection with its definition.")
NIL "Meta,X" "Meta,x" IL:ESC "Function,^T" (EXPAND))
(EXTRACT-CURRENT-SELECTION ("Extract" "M-/"
"Extract one level of structure: unquote or unlist.")
(EXTRACT-CURRENT-SELECTION ("Extract" "M-/" "Extract one level of structure: unquote or unlist."
)
NIL "Meta,/" (EXTRACT))
(INSPECT-SELECTION ("Inspect" "M-I" "Inspect the current selection.")
NIL "Meta,I" "Meta,i" (INSPECT))
(JOIN ("Join" "M-J" "Join selected items together.")
NIL "Meta,J" "Meta,j" (JOIN))
NIL "Meta,J" "Meta,j" (JOIN))
(MUTATE ("Mutate" "M-Z" "Prompt for a function to operate on the current selection.")
NIL "Meta,Z" "Meta,z")
((PARENTHESIZE-CURRENT-SELECTION NIL)
@@ -209,7 +208,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(ADD-MENU ("Attach Menu" "M-M" "Attach a command menu.")
NIL "Meta,M" "Meta,m")
(IL:* IL:|;;| "RANDOM: tells Meta-Space or Meta-Return to scroll to the selection, using the auto-scroller for free.")
(IL:* IL:|;;| "RANDOM: tells Meta-Space or Meta-Return to scroll to the selection, using the auto-scroller for free.")
(TRUE NIL T "Meta, " "Meta,CR")))
@@ -269,19 +268,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(IL:RPAQ? MENUS NIL)
(IL:DECLARE\: IL:EVAL@COMPILE
(IL:RPAQ WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < >
IL:\.)))
(IL:RPAQ WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.)))
(IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; <
> IL:\.))))
(IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < >
IL:\.))))
)
(DEFUN PSEUDO-SELECTION-FROM-SELECTION (SEL)
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "This function takes a selection and creates a pseudo selection from it.")
(IL:* IL:|;;;| "This function takes a selection and creates a pseudo selection from it.")
(COMPOSE-PSEUDO-SELECTION (IL:FETCH SELECT-NODE IL:OF SEL)
(IL:FETCH SELECT-START IL:OF SEL)
@@ -290,9 +288,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN COMPOSE-PSEUDO-SELECTION (NODE &OPTIONAL START END)
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "This function takes the fields of a pseudo selection and hands back one.")
(IL:* IL:|;;;| "This function takes the fields of a pseudo selection and hands back one.")
(COND
((LISTP NODE)
@@ -308,9 +306,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN DECOMPOSE-PSEUDO-SELECTION (PSEL)
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "This function takes a pseudo selection and hands its fields back as values.")
(IL:* IL:|;;;| "This function takes a pseudo selection and hands its fields back as values.")
(IF (LISTP PSEL)
(VALUES (FIRST PSEL)
@@ -322,9 +320,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN SELECTION-FROM-PSEUDO-SELECTION (PSEL &OPTIONAL SEL)
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.")
(IL:* IL:|;;;| "This function takes a pseudo-selection and constructs the corresponding selection. If you don't hand it a selection structure, it conses one.")
(IL:* IL:|;;;| "This function takes a pseudo-selection and constructs the corresponding selection. If you don't hand it a selection structure, it conses one.")
(UNLESS SEL
(SETF SEL (IL:CREATE EDIT-SELECTION)))
@@ -350,13 +348,13 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN ADD-COMMAND (KEY-CODE FORM &OPTIONAL SCROLL? KEY-NAME COMMAND-NAME HELP-STRING)
(WHEN FIRST-ADD-COMMAND
(IL:* IL:|;;| "cache the command-table-spec so the user can undo this!")
(IL:* IL:|;;| "cache the command-table-spec so the user can undo this!")
(SETQ DEFAULT-COMMAND-TABLE-SPEC (COPY-TREE COMMAND-TABLE-SPEC))
(SETQ FIRST-ADD-COMMAND NIL))
(WHEN (AND KEY-NAME COMMAND-NAME FIRST-ADD-COMMAND-MENU-ENTRY)
(IL:* IL:|;;| "add another separation line to the help menu.")
(IL:* IL:|;;| "add another separation line to the help menu.")
(NCONC COMMAND-TABLE-SPEC (LIST (LIST 'NULL (LIST "-----" "" "")
NIL 0)))
@@ -366,8 +364,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
SCROLL? KEY-CODE)))
(OR COMMAND-NAME FORM))
(DEFUN GET-SELECTION (CONTEXT) (IL:* IL:\; "Edited 23-Apr-2018 18:11 by rmk:")
(IL:* IL:\; "Edited 22-Apr-2018 16:48 by rmk:")
(DEFUN GET-SELECTION (CONTEXT) (IL:* IL:\; "Edited 23-Apr-2018 18:11 by rmk:")
(IL:* IL:\; "Edited 22-Apr-2018 16:48 by rmk:")
(LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT))
(NODE (IL:FETCH SELECT-NODE IL:OF SELECTION))
(CHARS (IL:FETCH STRUCTURE IL:OF NODE))
@@ -377,7 +375,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(TYPE (IL:FETCH SELECT-TYPE IL:OF SELECTION))
NOT-ALL-SELECTED)
(IL:* IL:|;;| "All except NODE are needed for the atom/string cases")
(IL:* IL:|;;| "All except NODE are needed for the atom/string cases")
(COND
((NULL NODE)
@@ -388,7 +386,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(START :SUB-LIST)
(T T))))
(T
(IL:* IL:|;;| "RMK: a single character-atom or a substring of characters in an atom or string. Full multicharacter atoms are structures. Code copies from COPY-SELECTION-LITATOM")
(IL:* IL:|;;| "RMK: a single character-atom or a substring of characters in an atom or string. Full multicharacter atoms are structures. Code copies from COPY-SELECTION-LITATOM")
(WHEN (IL:TYPE? BROKEN-ATOM CHARS)
(IL:SETQ CHARS (IL:FETCH ATOM-CHARS IL:OF CHARS)))
@@ -396,7 +394,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(IL:NCHARS STRING))
(IL:NEQ START 1)))
(IL:* IL:|;;| "some subset of the atom/string has been selected")
(IL:* IL:|;;| "some subset of the atom/string has been selected")
(IL:SETQ NOT-ALL-SELECTED T))
(VALUES (IL:MKSTRING (IF NOT-ALL-SELECTED
@@ -428,16 +426,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(PENDING-DELETE POINT SELECTION)
(INSERT POINT CONTEXT (COPY-LIST NEW-NODES))
(IL:* IL:|;;| "try to select the stuff that was just inserted.")
(IL:* IL:|;;| "try to select the stuff that was just inserted.")
(SELECT-PSEUDO-SEGMENT CONTEXT (COMPOSE-PSEUDO-SELECTION NEW-NODES))))
(DEFUN RESET-COMMANDS ()
(LET ((COMMANDS (CREATE-COMMAND-TABLE COMMAND-TABLE-SPEC)))
(IL:REPLACE (EDIT-ENV COMMAND-TABLE) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH
(FIRST COMMANDS))
(IL:REPLACE (EDIT-ENV HELP-MENU) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (SECOND
COMMANDS)))
(IL:REPLACE (EDIT-ENV COMMAND-TABLE) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (FIRST COMMANDS))
(IL:REPLACE (EDIT-ENV HELP-MENU) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (SECOND COMMANDS)))
T)
(DEFUN DEFAULT-COMMANDS ()
@@ -456,13 +452,12 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
"Used in Add-Command to signal the first time a new command is added to the middle button menu, so that the user entries can be separated from the default entries"
)
(DEFUN EQUALIZE-STRING-WIDTHS (STRING-LIST FONT &OPTIONAL PRIN2? (DESIRED-WIDTH (
 MAXIMUM-STRING-WIDTH
STRING-LIST FONT
PRIN2?))
(PAD-CHAR #\Space))
(DEFUN EQUALIZE-STRING-WIDTHS (STRING-LIST FONT &OPTIONAL PRIN2? (DESIRED-WIDTH (MAXIMUM-STRING-WIDTH
STRING-LIST FONT
PRIN2?))
(PAD-CHAR #\Space))
(IL:* IL:|;;;| "Increase the width of all the strings in STRING-LIST to DESIRED-WIDTH by padding them on the right with PAD-CHAR.")
(IL:* IL:|;;;| "Increase the width of all the strings in STRING-LIST to DESIRED-WIDTH by padding them on the right with PAD-CHAR.")
(DO ((PAD-CHAR-WIDTH (IL:CHARWIDTH (CHAR-CODE PAD-CHAR)
FONT))
@@ -488,7 +483,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-AND-DISPLAY-STRUCTURE (CONTEXT STR &OPTIONAL SCOPE START WRAP?)
(IL:* IL:|;;;| "Find structure and display it by selecting it (point after) and normalizing the selection in the window. SCOPE defaults to the root structure of the CONTEXT. The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).")
(IL:* IL:|;;;| "Find structure and display it by selecting it (point after) and normalizing the selection in the window. SCOPE defaults to the root structure of the CONTEXT. The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).")
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
(TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))
@@ -503,7 +498,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (CONTEXT STR &OPTIONAL SCOPE END WRAP?)
(IL:* IL:|;;;| "Like find-and-display-structure, but searches backwards")
(IL:* IL:|;;;| "Like find-and-display-structure, but searches backwards")
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
(TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))
@@ -518,7 +513,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE (CONTEXT STR &OPTIONAL SCOPE START WRAP?)
(IL:* IL:|;;;| "Find substructure and display it by selecting it (pending delete) and normalizing the selection in the window. SCOPE defaults to the root structure of the CONTEXT. The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).")
(IL:* IL:|;;;| "Find substructure and display it by selecting it (pending delete) and normalizing the selection in the window. SCOPE defaults to the root structure of the CONTEXT. The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).")
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
(TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))
@@ -533,7 +528,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (CONTEXT STR &OPTIONAL SCOPE END WRAP?)
(IL:* IL:|;;;| "Like find-and-display-substructure but searches backwards")
(IL:* IL:|;;;| "Like find-and-display-substructure but searches backwards")
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
(TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))
@@ -548,7 +543,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-NTH-STRUCTURE (CONTEXT CHARCODE STRUCTURE N)
(IL:* IL:|;;;| "Find the Nth occurance of Structure in this edit, always starting from the beginning. This function is used as an external command to set the selection to a desired structure. Find, select, and normalize.")
(IL:* IL:|;;;| "Find the Nth occurance of Structure in this edit, always starting from the beginning. This function is used as an external command to set the selection to a desired structure. Find, select, and normalize.")
(LET ((TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))))
(DO ((M 1 (+ M 1))
@@ -561,13 +556,13 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-NODE-SUBSTRUCTURE (STR STRLEN NODE &OPTIONAL START END CONTINUATION?)
(IL:* IL:|;;;| "STR is a list of structures of length STRLEN. NODE, together with START and END (which are subnode indices), is taken to indicate a subtree. We return a pseudo-selection which selects the first sequence of sibling nodes in that subtree whose successive structures match the successive elements of STR.")
(IL:* IL:|;;;| "STR is a list of structures of length STRLEN. NODE, together with START and END (which are subnode indices), is taken to indicate a subtree. We return a pseudo-selection which selects the first sequence of sibling nodes in that subtree whose successive structures match the successive elements of STR.")
(IL:* IL:|;;;| "\"First\" here is taken to mean \"first in linearization order\", so we have to do a careful recursion which: (1a) recursively checks the subtree rooted at the START subnode of NODE (default the first), (1b) checks if the START subnode starts a matching sibling sequence, (2a) recursively checks the subtree rooted at the START+1 subnode of NODE, (2b) checks if the START+1 subnode starts a matching sibling sequence, . . ., (Na) recusively checks the subtree rooted at the END subnode of NODE (default the last), (Nb) checks if the END subnode starts a matching sibling sequence [note that such a sequence could be only 1 node long since END is the right end of the subtree being checked].")
(IL:* IL:|;;;| "\"First\" here is taken to mean \"first in linearization order\", so we have to do a careful recursion which: (1a) recursively checks the subtree rooted at the START subnode of NODE (default the first), (1b) checks if the START subnode starts a matching sibling sequence, (2a) recursively checks the subtree rooted at the START+1 subnode of NODE, (2b) checks if the START+1 subnode starts a matching sibling sequence, . . ., (Na) recusively checks the subtree rooted at the END subnode of NODE (default the last), (Nb) checks if the END subnode starts a matching sibling sequence [note that such a sequence could be only 1 node long since END is the right end of the subtree being checked].")
(IL:* IL:|;;;| "N.B. It might seem that, to get true linearization order, we should check to see if a node starts a matching sibling sequence before we check its subtree. But since node structures can not be circular, we know that if a match is found in the subtree below a node then that node could not have started a matching sequence.")
(IL:* IL:|;;;| "N.B. It might seem that, to get true linearization order, we should check to see if a node starts a matching sibling sequence before we check its subtree. But since node structures can not be circular, we know that if a match is found in the subtree below a node then that node could not have started a matching sequence.")
(IL:* IL:|;;;| "The CONTINUATION? flag means that we are continuing a search that has already recursively checked the START subnode, so we skip that particular recursion. This generally happens when we are working our way up and to the right in some subtree which has already been partially checked.")
(IL:* IL:|;;;| "The CONTINUATION? flag means that we are continuing a search that has already recursively checked the START subnode, so we skip that particular recursion. This generally happens when we are working our way up and to the right in some subtree which has already been partially checked.")
(SETF START (OR START 1))
(LET* ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE))
@@ -593,7 +588,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-NODE-SUBSTRUCTURE-BACKWARDS (STR STRLEN NODE &OPTIONAL START END CONTINUATION?)
(IL:* IL:|;;;| "Like find-node-substructure but searches in reverse linearization order.")
(IL:* IL:|;;;| "Like find-node-substructure but searches in reverse linearization order.")
(LET* ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE))
(SUBLENGTH (FIRST SUBNODES)))
@@ -610,8 +605,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
((OR (NULL SUBS)
(AND START (< INDEX START)))
NIL)
(WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN
(FIRST SUBS))))
(WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN (FIRST SUBS)))
)
(RETURN MATCH))
(UNLESS (OR (< STARTINDEX 1)
(MISMATCH STR SUBS :END2 STRLEN :TEST
@@ -621,7 +616,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-OBJ (CONTEXT &OPTIONAL CHARCODE FIND-STRING BACKWARDS?)
(IL:* IL:|;;;| "Find either the passed structure, the selected structure, or a prompted-for structure. The search direction is forward unless BACKWARDS? is specified.")
(IL:* IL:|;;;| "Find either the passed structure, the selected structure, or a prompted-for structure. The search direction is forward unless BACKWARDS? is specified.")
(CLOSE-OPEN-NODE CONTEXT)
(LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT))
@@ -632,7 +627,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(EQ (IL:|fetch| SELECT-TYPE IL:|of| SELECTION)
'STRUCTURE))
(IL:* IL:|;;| "there is a non-string selection")
(IL:* IL:|;;| "there is a non-string selection")
(IF BACKWARDS?
(FIND-SELECTION-BACKWARDS CONTEXT WRAP?)
@@ -644,7 +639,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-SELECTION (CONTEXT &OPTIONAL WRAP?)
(IL:* IL:|;;;| "Find the next match of the current selection and display it.")
(IL:* IL:|;;;| "Find the next match of the current selection and display it.")
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
(SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT))
@@ -652,32 +647,31 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(START (IL:|fetch| SELECT-START IL:|of| SELECTION)))
(IF START
(IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence after it")
(IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence after it")
(FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)
NIL
(LIST NODE (1+ START))
WRAP?)
(IL:* IL:|;;| "a node is selected, look for a matching node ")
(IL:* IL:|;;| "a node is selected, look for a matching node ")
(IF (SETF START (NEXT-NODE NODE T))
(IL:* IL:|;;| "start the search with the following node")
(IL:* IL:|;;| "start the search with the following node")
(FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)
NIL START WRAP?)
(IL:* IL:|;;| "there are no more nodes, either wrap or give up")
(IL:* IL:|;;| "there are no more nodes, either wrap or give up")
(IF WRAP?
(FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)
)
(FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION))
(FORMAT PROMPTWINDOW "~%At end; no more structure to search."))))))
(DEFUN FIND-SELECTION-BACKWARDS (CONTEXT &OPTIONAL WRAP?)
(IL:* IL:|;;;| "Find the previous match of the current selection and display it.")
(IL:* IL:|;;;| "Find the previous match of the current selection and display it.")
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
(SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT))
@@ -686,36 +680,34 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(IL:|fetch| SELECT-END IL:|of| SELECTION))))
(IF END
(IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence before it")
(IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence before it")
(FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION
SELECTION)
(FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)
NIL
(LIST NODE (1- END))
WRAP?)
(IL:* IL:|;;| "a node is selected, look for a matching node ")
(IL:* IL:|;;| "a node is selected, look for a matching node ")
(IF (SETF END (PREV-NODE NODE T))
(IL:* IL:|;;| "start the search with the previous node")
(IL:* IL:|;;| "start the search with the previous node")
(FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION
SELECTION)
(FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)
NIL END WRAP?)
(IL:* IL:|;;| "there are no more nodes, either wrap or give up")
(IL:* IL:|;;| "there are no more nodes, either wrap or give up")
(IF WRAP?
(FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION
SELECTION))
(FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION
SELECTION))
(FORMAT PROMPTWINDOW "~%At beginning; no more structure to search."))))))
(DEFUN FIND-STRUCTURE (STR SCOPE &OPTIONAL START)
(IL:* IL:|;;;| "Search forward in linearization order for a node whose structure matches STR. The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate its left-most node). START defaults to SCOPE. The return value is the first node in SCOPE at or after START whose structure is IL:EQUAL to STR.")
(IL:* IL:|;;;| "Search forward in linearization order for a node whose structure matches STR. The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate its left-most node). START defaults to SCOPE. The return value is the first node in SCOPE at or after START whose structure is IL:EQUAL to STR.")
(IL:* IL:|;;;| "N.B. Since node structures can not be circular, no subnode of a node can have structure matching that node. Thus looking for a matching node in pre-order is the same as looking for one in linearization order. So we do a pre-order search here.")
(IL:* IL:|;;;| "N.B. Since node structures can not be circular, no subnode of a node can have structure matching that node. Thus looking for a matching node in pre-order is the same as looking for one in linearization order. So we do a pre-order search here.")
(MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
(DECOMPOSE-PSEUDO-SELECTION SCOPE)
@@ -727,11 +719,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(EQ START-NODE SCOPE-NODE)))
(IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF SCOPE-NODE)))
(IL:* IL:|;;| "special case: the scope includes its root node, we're starting at the root of the scope, and the root of the scope matches the passed structure.")
(IL:* IL:|;;| "special case: the scope includes its root node, we're starting at the root of the scope, and the root of the scope matches the passed structure.")
(RETURN-FROM FIND-STRUCTURE SCOPE-NODE))
(IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in preorder.")
(IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in preorder.")
(DO* ((MIN-DEPTH (1+ (IL:FETCH DEPTH IL:OF SCOPE-NODE)))
(NODE (OR (IF START-START
@@ -755,7 +747,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-STRUCTURE-BACKWARDS (STR SCOPE &OPTIONAL END)
(IL:* IL:|;;;| "like find-structure but searches in reverse linearization order. Actually we search in postorder rather than reverse linearization order but this works just as well for the same reasons that preorder matches linearization order.")
(IL:* IL:|;;;| "like find-structure but searches in reverse linearization order. Actually we search in postorder rather than reverse linearization order but this works just as well for the same reasons that preorder matches linearization order.")
(MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
(DECOMPOSE-PSEUDO-SELECTION SCOPE)
@@ -767,12 +759,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(EQ END-NODE SCOPE-NODE)))
(IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF SCOPE-NODE)))
(IL:* IL:|;;| "special case: the scope includes its root node, we're ending at the root of the scope, and the root of the scope matches the passed structure.")
(IL:* IL:|;;| "special case: the scope includes its root node, we're ending at the root of the scope, and the root of the scope matches the passed structure.")
(RETURN-FROM FIND-STRUCTURE-BACKWARDS SCOPE-NODE))
(IL:* IL:|;;|
 "normal case: check all the nodes in the scope subtree in postorder.")
(IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in postorder.")
(DO* ((MIN-DEPTH (1+ (IL:FETCH DEPTH IL:OF SCOPE-NODE)))
(NODE (OR (IF END-END
@@ -796,9 +787,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-SUBSTRUCTURE (STR SCOPE &OPTIONAL START)
(IL:* IL:|;;;| "Search forward in linearization order for a sequence of nodes whose successive structures match the successive elements of STR. The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate the left edge of a subtree). START defauts to SCOPE. The return value is a pseudo-selection indicating the sibling sequence of nodes in SCOPE at or to the right of START whose successive node structures are IL:EQUAL to the successive members of STR.")
(IL:* IL:|;;;| "Search forward in linearization order for a sequence of nodes whose successive structures match the successive elements of STR. The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate the left edge of a subtree). START defauts to SCOPE. The return value is a pseudo-selection indicating the sibling sequence of nodes in SCOPE at or to the right of START whose successive node structures are IL:EQUAL to the successive members of STR.")
(IL:* IL:|;;;| "N.B. For a sequence of sibling nodes, first in linearization order can not be found by doing a preorder search. See find-node-substructure for details about the correct search method.")
(IL:* IL:|;;;| "N.B. For a sequence of sibling nodes, first in linearization order can not be found by doing a preorder search. See find-node-substructure for details about the correct search method.")
(MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
(DECOMPOSE-PSEUDO-SELECTION SCOPE)
@@ -807,18 +798,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(COND
((NULL START-NODE)
(IL:* IL:|;;| "just check the entire scope")
(IL:* IL:|;;| "just check the entire scope")
(FIND-NODE-SUBSTRUCTURE STR (LENGTH STR)
SCOPE-NODE SCOPE-START SCOPE-END))
((EQ START-NODE SCOPE-NODE)
(IL:* IL:|;;| "just check a terminal subtree of the scope")
(IL:* IL:|;;| "just check a terminal subtree of the scope")
(FIND-NODE-SUBSTRUCTURE STR (LENGTH STR)
SCOPE-NODE START-START SCOPE-END))
(T
(IL:* IL:|;;| "check each node from the start subtree up and to the right in the scope subtree. We carefully resume the recursion that would have happened if we had started from the root of the subtree. This means checking remaining structure in super-nodes on our way from the start node back up the subtree.")
(IL:* IL:|;;| "check each node from the start subtree up and to the right in the scope subtree. We carefully resume the recursion that would have happened if we had started from the root of the subtree. This means checking remaining structure in super-nodes on our way from the start node back up the subtree.")
(DO ((NODE START-NODE SUPER-NODE)
(SUPER-NODE (IL:FETCH SUPER-NODE IL:OF START-NODE)
@@ -839,7 +830,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN FIND-SUBSTRUCTURE-BACKWARDS (STR SCOPE &OPTIONAL END)
(IL:* IL:|;;;| "Like find-substructure but searches in reverse linearization order.")
(IL:* IL:|;;;| "Like find-substructure but searches in reverse linearization order.")
(MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
(DECOMPOSE-PSEUDO-SELECTION SCOPE)
@@ -848,18 +839,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(COND
((NULL END-NODE)
(IL:* IL:|;;| "just check the entire scope")
(IL:* IL:|;;| "just check the entire scope")
(FIND-NODE-SUBSTRUCTURE-BACKWARDS STR (LENGTH STR)
SCOPE-NODE SCOPE-START SCOPE-END))
((EQ END-NODE SCOPE-NODE)
(IL:* IL:|;;| "just check an initial subtree of the scope")
(IL:* IL:|;;| "just check an initial subtree of the scope")
(FIND-NODE-SUBSTRUCTURE-BACKWARDS STR (LENGTH STR)
SCOPE-NODE SCOPE-START END-END))
(T
(IL:* IL:|;;| "check each node in the initial subtree of scope terminated by the end subtree. We carefully resume the recursion that would have happened if we had started from the root of the scope subtree. This means checking remaining structure in super-nodes on our way from the end node back up the subtree.")
(IL:* IL:|;;| "check each node in the initial subtree of scope terminated by the end subtree. We carefully resume the recursion that would have happened if we had started from the root of the scope subtree. This means checking remaining structure in super-nodes on our way from the end node back up the subtree.")
(DO ((NODE END-NODE SUPER-NODE)
(SUPER-NODE (IL:FETCH SUPER-NODE IL:OF END-NODE)
@@ -873,8 +864,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(STRLEN (LENGTH STR))
MATCH)
((OR (NULL NODE)
(SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN NODE
START END CONTINUATION?))
(SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN NODE START
END CONTINUATION?))
(EQ NODE SCOPE-NODE))
MATCH)))))))
@@ -885,15 +876,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN SEARCH-OBJ (CONTEXT &OPTIONAL SEARCH-STRING WRAP?)
(IL:* IL:|;;;| "Search for the the structure(s) in the string SEARCH-OBJ and display them. The search starts just after the current point or selection, if any.")
(IL:* IL:|;;;| "Search for the the structure(s) in the string SEARCH-OBJ and display them. The search starts just after the current point or selection, if any.")
(MULTIPLE-VALUE-BIND (STR STRLEN)
(STRUCTURE-FROM-STRING (OR SEARCH-STRING (SETF SEARCH-STRING
(GET-USER-STRING CONTEXT "Find: "
(OR (IL:|fetch|
FIND-CANDIDATE
IL:|of| CONTEXT)
FIND-CANDIDATE)))))
(GET-USER-STRING CONTEXT "Find: "
(OR (IL:|fetch| FIND-CANDIDATE
IL:|of| CONTEXT)
FIND-CANDIDATE)))))
(COND
((< STRLEN 0)
(FORMAT (GET-PROMPT-WINDOW CONTEXT)
@@ -904,12 +894,12 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
"-- aborted.")
(RETURN-FROM SEARCH-OBJ)))
(IL:* IL:|;;| "update the remembered defaults")
(IL:* IL:|;;| "update the remembered defaults")
(IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE
SEARCH-STRING))
(IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE
SEARCH-STRING))
(IL:* IL:|;;| "figure out where to search and where to start")
(IL:* IL:|;;| "figure out where to search and where to start")
(LET* ((SCOPE (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))
(START (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT))
@@ -933,36 +923,35 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(T SCOPE)))))
(UNLESS (OR WRAP? START)
(IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap")
(IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap")
(FORMAT (GET-PROMPT-WINDOW CONTEXT)
"~%At end; no more structure to search.")
(RETURN-FROM SEARCH-OBJ))
(IL:* IL:|;;| "do the search")
(IL:* IL:|;;| "do the search")
(IF (> STRLEN 1)
(IL:* IL:|;;| "substructure search")
(IL:* IL:|;;| "substructure search")
(FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE START WRAP?)
(IL:* IL:|;;| "structure search")
(IL:* IL:|;;| "structure search")
(FIND-AND-DISPLAY-STRUCTURE CONTEXT (FIRST STR)
SCOPE START WRAP?)))))
(DEFUN SEARCH-OBJ-BACKWARDS (CONTEXT &OPTIONAL SEARCH-STRING WRAP?)
(IL:* IL:|;;;| "Like search-obj but searches backwards.")
(IL:* IL:|;;;| "Like search-obj but searches backwards.")
(MULTIPLE-VALUE-BIND (STR STRLEN)
(STRUCTURE-FROM-STRING (OR SEARCH-STRING (SETF SEARCH-STRING
(GET-USER-STRING CONTEXT "Find: "
(OR (IL:|fetch|
FIND-CANDIDATE
IL:|of| CONTEXT)
FIND-CANDIDATE)))))
(GET-USER-STRING CONTEXT "Find: "
(OR (IL:|fetch| FIND-CANDIDATE
IL:|of| CONTEXT)
FIND-CANDIDATE)))))
(COND
((< STRLEN 0)
(FORMAT (GET-PROMPT-WINDOW CONTEXT)
@@ -973,12 +962,12 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
"-- aborted.")
(RETURN-FROM SEARCH-OBJ-BACKWARDS)))
(IL:* IL:|;;| "update the remembered defaults")
(IL:* IL:|;;| "update the remembered defaults")
(IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE
SEARCH-STRING))
(IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE
SEARCH-STRING))
(IL:* IL:|;;| "figure out where to search and where to start")
(IL:* IL:|;;| "figure out where to search and where to start")
(LET* ((SCOPE (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))
(END (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT))
@@ -1002,30 +991,30 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(T SCOPE)))))
(UNLESS (OR WRAP? END)
(IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap")
(IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap")
(FORMAT (GET-PROMPT-WINDOW CONTEXT)
"~%At beginning; no more structure to search.")
(RETURN-FROM SEARCH-OBJ-BACKWARDS))
(IL:* IL:|;;| "do the search")
(IL:* IL:|;;| "do the search")
(IF (> STRLEN 1)
(IL:* IL:|;;| "substructure search")
(IL:* IL:|;;| "substructure search")
(FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT STR SCOPE END WRAP?)
(IL:* IL:|;;| "structure search")
(IL:* IL:|;;| "structure search")
(FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (FIRST STR)
SCOPE END WRAP?)))))
(DEFUN SUBSTITUTE-OBJ (CONTEXT &OPTIONAL CHARCODE OLDSTR NEWSTR REMOVE?)
(IL:* IL:|;;;| "OLDSTR and NEWSTR are strings. In the scope of the selection, replace every occurence of structure matching OLDSTR by structure parsed from NEWSTR. If REMOVE? is specified, just remove structure matching OLD.")
(IL:* IL:|;;;| "OLDSTR and NEWSTR are strings. In the scope of the selection, replace every occurence of structure matching OLDSTR by structure parsed from NEWSTR. If REMOVE? is specified, just remove structure matching OLD.")
(IL:* IL:|;;;| "We preserve the selection as best we can. Point gets thrown away.")
(IL:* IL:|;;;| "We preserve the selection as best we can. Point gets thrown away.")
(CLOSE-OPEN-NODE CONTEXT)
(LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))
@@ -1033,7 +1022,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(SCOPE NIL)
(TYPE (IF REMOVE?
"delet"
"substitut"))) (IL:* IL:\; "hack!!!")
"substitut"))) (IL:* IL:\; "hack!!!")
(UNLESS (AND (IL:|fetch| SELECT-NODE IL:|of| SELECTION)
(EQ (IL:|fetch| SELECT-TYPE IL:|of| SELECTION)
'STRUCTURE))
@@ -1041,14 +1030,13 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(RETURN-FROM SUBSTITUTE-OBJ T))
(SETQ SCOPE (PSEUDO-SELECTION-FROM-SELECTION SELECTION))
(MULTIPLE-VALUE-BIND (OLD OLDLEN)
(STRUCTURE-FROM-STRING (OR OLDSTR (SETF OLDSTR
(GET-USER-STRING CONTEXT
(IF REMOVE?
"Delete form: "
"Replace old form: ")
(OR (IL:|fetch| FIND-CANDIDATE
IL:|of| CONTEXT)
FIND-CANDIDATE)))))
(STRUCTURE-FROM-STRING (OR OLDSTR (SETF OLDSTR (GET-USER-STRING CONTEXT
(IF REMOVE?
"Delete form: "
"Replace old form: ")
(OR (IL:|fetch| FIND-CANDIDATE
IL:|of| CONTEXT)
FIND-CANDIDATE)))))
(COND
((< OLDLEN 0)
(FORMAT PROMPTWINDOW " -- Invalid structure.")
@@ -1060,13 +1048,13 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(IF REMOVE?
(VALUES NIL 0)
(STRUCTURE-FROM-STRING (OR NEWSTR
(SETF NEWSTR
(GET-USER-STRING
CONTEXT "with new form: "
(OR (IL:|fetch|
SUBSTITUTE-CANDIDATE
IL:|of| CONTEXT)
SUBSTITUTE-CANDIDATE))))))
(SETF NEWSTR
(GET-USER-STRING CONTEXT
"with new form: "
(OR (IL:|fetch|
SUBSTITUTE-CANDIDATE
IL:|of| CONTEXT)
SUBSTITUTE-CANDIDATE))))))
(COND
((< NEWLEN 0)
(FORMAT PROMPTWINDOW " -- Invalid structure.")
@@ -1076,16 +1064,16 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(FORMAT PROMPTWINDOW "-- aborted.")
(RETURN-FROM SUBSTITUTE-OBJ T)))
(IL:* IL:|;;| "update defaults ")
(IL:* IL:|;;| "update defaults ")
(IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ
FIND-CANDIDATE
OLDSTR))
(IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE
OLDSTR))
(UNLESS REMOVE?
(IL:|replace| SUBSTITUTE-CANDIDATE IL:|of| CONTEXT
IL:|with| (IL:SETQ SUBSTITUTE-CANDIDATE NEWSTR)))
(IL:|replace| SUBSTITUTE-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ
SUBSTITUTE-CANDIDATE
NEWSTR)))
(IL:* IL:|;;| "do the substitution, report, and reselect.")
(IL:* IL:|;;| "do the substitution, report, and reselect.")
(MULTIPLE-VALUE-BIND (NEW-SCOPE SUBCOUNT)
(IF (> OLDLEN 1)
@@ -1101,14 +1089,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN SUBSTITUTE-STRUCTURE (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?)
(IL:* IL:|;;;| "Inside SCOPE, replace any node with structure OLD by nodes gotten from parsing NEW. If REMOVE? is given, just delete the old nodes. Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.")
(IL:* IL:|;;;| "Inside SCOPE, replace any node with structure OLD by nodes gotten from parsing NEW. If REMOVE? is given, just delete the old nodes. Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.")
(IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.")
(IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.")
(MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
(DECOMPOSE-PSEUDO-SELECTION SCOPE)
(LET* ((ROOT (IL:FETCH ROOT IL:OF CONTEXT))(IL:* IL:\;
 "substituting for root is special")
(LET* ((ROOT (IL:FETCH ROOT IL:OF CONTEXT)) (IL:* IL:\;
 "substituting for root is special")
(POINT (IL:FETCH CARET-POINT IL:OF CONTEXT))
(SELECTION (IL:FETCH SELECTION IL:OF CONTEXT))
(NEWLEN (IF REMOVE?
@@ -1139,14 +1127,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(SET-SELECTION-NOWHERE SELECTION)
(VALUES SCOPE NUMSUBS))
(IL:* IL:|;;| "replace the target ")
(IL:* IL:|;;| "replace the target ")
(SELECT-NODE CONTEXT TARGET)
(COND
(REMOVE? (COND
((EQ TARGET-SUPER ROOT)
(IL:* IL:|;;| "\"delete\" the root structure by making it nil")
(IL:* IL:|;;| "\"delete\" the root structure by making it nil")
(PENDING-DELETE POINT SELECTION)
(INSERT-NULL-LIST CONTEXT))
@@ -1154,19 +1142,19 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(T (PENDING-DELETE POINT SELECTION)
(INSERT POINT CONTEXT (COPY-LIST NEW-NODES))))
(IL:* IL:|;;| "fix up the scope, if necessary")
(IL:* IL:|;;| "fix up the scope, if necessary")
(COND
((EQ TARGET SCOPE-NODE)
(IL:* IL:|;;| "matched the scope, so we're done")
(IL:* IL:|;;| "matched the scope, so we're done")
(COND
(REMOVE? (SETF SCOPE NIL))
((= NEWLEN 1)
(SETF SCOPE (SUBNODE TARGET-INDEX TARGET-SUPER)))
(T
(IL:* IL:|;;| "replacing the root structure with multiple nodes inserts a new level of list between the root (target-super) and the multiple nodes inserted. In this case, make the scope node be the new list node instead of the root itself.")
(IL:* IL:|;;| "replacing the root structure with multiple nodes inserts a new level of list between the root (target-super) and the multiple nodes inserted. In this case, make the scope node be the new list node instead of the root itself.")
(SETF SCOPE (LIST (IF (EQ TARGET-SUPER ROOT)
(SUBNODE 1 ROOT)
@@ -1176,7 +1164,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(SETF RESUME NIL))
((AND SCOPE-START (EQ TARGET-SUPER SCOPE-NODE))
(IL:* IL:|;;| "matched a direct subnode of an extended scope")
(IL:* IL:|;;| "matched a direct subnode of an extended scope")
(WHEN (= TARGET-INDEX SCOPE-END)
(SETF RESUME NIL))
@@ -1185,9 +1173,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN SUBSTITUTE-SUBSTRUCTURE (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?)
(IL:* IL:|;;;| "Inside SCOPE, replace any sequences of nodes whose structures sequentially match the elements of OLD by nodes gotten from parsing NEW. If REMOVE? is given, just delete the old sequences. Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.")
(IL:* IL:|;;;| "Inside SCOPE, replace any sequences of nodes whose structures sequentially match the elements of OLD by nodes gotten from parsing NEW. If REMOVE? is given, just delete the old sequences. Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.")
(IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.")
(IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.")
(MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END)
(DECOMPOSE-PSEUDO-SELECTION SCOPE)
@@ -1218,7 +1206,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(MULTIPLE-VALUE-BIND (TNODE TSTART TEND)
(DECOMPOSE-PSEUDO-SELECTION TARGET)
(IL:* IL:|;;| "replace the target ")
(IL:* IL:|;;| "replace the target ")
(SELECT-PSEUDO-SEGMENT CONTEXT TARGET)
(COND
@@ -1226,13 +1214,12 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(T (PENDING-DELETE POINT SELECTION)
(INSERT POINT CONTEXT (COPY-LIST NEW-NODES))))
(IL:* IL:|;;|
 "fix up the scope, if necessary, and figure where to resume")
(IL:* IL:|;;| "fix up the scope, if necessary, and figure where to resume")
(COND
((AND SCOPE-START (EQ TNODE SCOPE-NODE))
(IL:* IL:|;;| "matched direct subnodes of an extended scope")
(IL:* IL:|;;| "matched direct subnodes of an extended scope")
(IF (= TEND SCOPE-END)
(SETF RESUME NIL)
@@ -1243,7 +1230,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN STRUCTURE-FROM-SELECTION (SELECTION)
(IL:* IL:|;;;| "selection must be a structure selection. Return the structure encompassed by selection, which if the selection is a node is the structure of that node, and if the selection is a segment a list of the structures of the nodes in that segment.")
(IL:* IL:|;;;| "selection must be a structure selection. Return the structure encompassed by selection, which if the selection is a node is the structure of that node, and if the selection is a segment a list of the structures of the nodes in that segment.")
(LET* ((NODE (IL:FETCH SELECT-NODE IL:OF SELECTION))
(START (IL:FETCH SELECT-START IL:OF SELECTION))
@@ -1263,7 +1250,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN STRUCTURE-FROM-STRING (STR)
(IL:* IL:|;;;| "return all the structures that can be read from string as a list. return a second value saying how many structures there were. If an error is encountered, a second value of -1 is returned. ")
(IL:* IL:|;;;| "return all the structures that can be read from string as a list. return a second value saying how many structures there were. If an error is encountered, a second value of -1 is returned. ")
(COND
((NULL STR)
@@ -1285,7 +1272,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(DEFUN COMMENT-OUT-SELECTION (CONTEXT CHARCODE)
(IL:* IL:|;;;| "given a sequence of whole structure selections, build a 5 level comment node and replace the nodes with the comment.")
(IL:* IL:|;;;| "given a sequence of whole structure selections, build a 5 level comment node and replace the nodes with the comment.")
(LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT))
(POINT (IL:FETCH CARET-POINT IL:OF CONTEXT))
@@ -1301,14 +1288,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(START (WITH-OUTPUT-TO-STRING (S)
(IL:BIND BLANK-BEFORE IL:FOR I IL:FROM START
IL:TO (OR (IL:FETCH SELECT-END IL:OF SELECTION)
START) IL:AS X
START) IL:AS X
IL:ON (CDR (IL:NTH (IL:FETCH SUB-NODES IL:OF NODE)
START))
IL:DO (IF BLANK-BEFORE
(WRITE-CHAR #\Space S)
(SETQ BLANK-BEFORE T))
(PRIN1 (IL:FETCH STRUCTURE IL:OF (CAR X))
S))))
START)) IL:DO (IF BLANK-BEFORE
(WRITE-CHAR #\Space S)
(SETQ BLANK-BEFORE T))
(PRIN1 (IL:FETCH STRUCTURE
IL:OF (CAR X))
S))))
(T (FORMAT NIL "~S" (IL:FETCH STRUCTURE IL:OF NODE))))))
(WHEN STR
(LET ((NEW-NODE (PARSE-NEW (LIST 'IL:* 'IL:\| STR)
@@ -1585,42 +1572,40 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>SEDIT-COMMANDS.;6|)
(il:lambda (context node subnodes) (il:* il:\; "Edited 7-Jul-87 09:39 by DCB") (il:* il:|;;;| "sticks subnodes back into node and revives them. ") (rplacd (il:fetch sub-nodes il:of node) subnodes) (il:for subnode il:in subnodes il:as index il:from 1 il:do (il:replace super-node il:of subnode il:with node) (il:replace sub-node-index il:of subnode il:with index) (detach-node subnode) (revive-node subnode (il:fetch depth il:of node))) (il:* il:|;;| "used to reparse here. now if we simply note the change, the format types, format values, and linear forms will be recomputed.") (note-change node context))
)
)
(IL:PUTPROPS IL:SEDIT-COMMANDS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 2018
2021))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (13643 14213 (PSEUDO-SELECTION-FROM-SELECTION 13643 . 14213)) (14215 14969 (
COMPOSE-PSEUDO-SELECTION 14215 . 14969)) (14971 15510 (DECOMPOSE-PSEUDO-SELECTION 14971 . 15510)) (
15512 16309 (SELECTION-FROM-PSEUDO-SELECTION 15512 . 16309)) (16311 16614 (SELECT-PSEUDO-SEGMENT 16311
. 16614)) (16679 17569 (ADD-COMMAND 16679 . 17569)) (17571 19734 (GET-SELECTION 17571 . 19734)) (
19736 20916 (REPLACE-SELECTION 19736 . 20916)) (20918 21410 (RESET-COMMANDS 20918 . 21410)) (21412
21581 (DEFAULT-COMMANDS 21412 . 21581)) (22059 23162 (EQUALIZE-STRING-WIDTHS 22059 . 23162)) (23164
23362 (MINIMUM-STRING-WIDTH 23164 . 23362)) (23364 23562 (MAXIMUM-STRING-WIDTH 23364 . 23562)) (23564
24435 (FIND-AND-DISPLAY-STRUCTURE 23564 . 24435)) (24437 25121 (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
24437 . 25121)) (25123 26027 (FIND-AND-DISPLAY-SUBSTRUCTURE 25123 . 26027)) (26029 26732 (
FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS 26029 . 26732)) (26734 27375 (FIND-NTH-STRUCTURE 26734 . 27375
)) (27377 30107 (FIND-NODE-SUBSTRUCTURE 27377 . 30107)) (30109 31362 (FIND-NODE-SUBSTRUCTURE-BACKWARDS
30109 . 31362)) (31364 32343 (FIND-OBJ 31364 . 32343)) (32345 33745 (FIND-SELECTION 32345 . 33745)) (
33747 35439 (FIND-SELECTION-BACKWARDS 33747 . 35439)) (35441 38170 (FIND-STRUCTURE 35441 . 38170)) (
38172 40519 (FIND-STRUCTURE-BACKWARDS 38172 . 40519)) (40521 43450 (FIND-SUBSTRUCTURE 40521 . 43450))
(43452 45752 (FIND-SUBSTRUCTURE-BACKWARDS 43452 . 45752)) (45754 45990 (GET-USER-STRING 45754 . 45990)
) (45992 49700 (SEARCH-OBJ 45992 . 49700)) (49702 53367 (SEARCH-OBJ-BACKWARDS 49702 . 53367)) (53369
58195 (SUBSTITUTE-OBJ 53369 . 58195)) (58197 62853 (SUBSTITUTE-STRUCTURE 58197 . 62853)) (62855 66027
(SUBSTITUTE-SUBSTRUCTURE 62855 . 66027)) (66029 67191 (STRUCTURE-FROM-SELECTION 66029 . 67191)) (67193
68036 (STRUCTURE-FROM-STRING 67193 . 68036)) (68038 70179 (COMMENT-OUT-SELECTION 68038 . 70179)) (
70180 125041 (ADD-MENU 70193 . 70856) (BACKSPACE 70858 . 71837) (CHANGE-PACKAGE 71839 . 74639) (
CHANGE-PRINTBASE 74641 . 76823) (CHANGE-QUOTE 76825 . 77180) (CONVERT-COMMENT 77182 . 78942) (
CONVERT-COMMENT-STRUCTURE 78944 . 80247) (CONVERT-COMMENT-TAIL 80249 . 81649) (CREATE-COMMAND-TABLE
81651 . 83629) (DEFAULT-EDIT-FN 83631 . 83768) (DELETE-SELECTION 83770 . 84452) (DELETE-WORD 84454 .
86555) (DO-MUTATION 86557 . 87105) (EDIT-SELECTION 87107 . 87555) (EVAL-SELECTION 87557 . 89426) (
EXPAND 89428 . 90557) (EXTRACT-CURRENT-SELECTION 90559 . 92927) (FIND-COMMENT 92929 . 93623) (GET-MENU
93625 . 94002) (EDIT-HELP 94004 . 95079) (HELPMENU 95081 . 97870) (INPUT-DOT 97872 . 100004) (
INPUT-ESCAPE 100006 . 100254) (INPUT-NORMAL-CHAR 100256 . 102289) (INPUT-QUOTE 102291 . 105373) (
INPUT-SQUARE-BRACKET 105375 . 105726) (INPUT-STRINGDELIM 105728 . 107127) (INPUT-TOKENDELIM 107129 .
108109) (INSERT-MULTI-ESCAPE 108111 . 109239) (INSERT-SPECIAL-CHARACTER 109241 . 110501) (
INSPECT-SELECTION 110503 . 111038) (JOIN 111040 . 114710) (MENU-CLOSEFN 114712 . 114930) (
MENU-FIND-SELECTEDFN 114932 . 115632) (MENU-INIT-STATE 115634 . 116441) (MENU-PACKAGE-SELECTEDFN
116443 . 117494) (MENU-PRINTBASE-SELECTEDFN 117496 . 118372) (MENU-SELECTEDFN 118374 . 118800) (
MENU-SUBSTITUTE-SELECTEDFN 118802 . 119762) (MUTATE 119764 . 120874) (QUOTE-CURRENT-SELECTION 120876
. 121643) (REDISPLAY 121645 . 121884) (REDO 121886 . 122380) (SELECTED-FN-NAME 122382 . 122827) (
SKIP-TO-GAP 122829 . 123606) (UNDO 123608 . 124408) (UNDO-EXTRACT 124410 . 125039)))))
(IL:FILEMAP (NIL (13440 14010 (PSEUDO-SELECTION-FROM-SELECTION 13440 . 14010)) (14012 14766 (
COMPOSE-PSEUDO-SELECTION 14012 . 14766)) (14768 15307 (DECOMPOSE-PSEUDO-SELECTION 14768 . 15307)) (
15309 16106 (SELECTION-FROM-PSEUDO-SELECTION 15309 . 16106)) (16108 16411 (SELECT-PSEUDO-SEGMENT 16108
. 16411)) (16476 17366 (ADD-COMMAND 16476 . 17366)) (17368 19539 (GET-SELECTION 17368 . 19539)) (
19541 20721 (REPLACE-SELECTION 19541 . 20721)) (20723 21044 (RESET-COMMANDS 20723 . 21044)) (21046
21215 (DEFAULT-COMMANDS 21046 . 21215)) (21693 22701 (EQUALIZE-STRING-WIDTHS 21693 . 22701)) (22703
22901 (MINIMUM-STRING-WIDTH 22703 . 22901)) (22903 23101 (MAXIMUM-STRING-WIDTH 22903 . 23101)) (23103
23974 (FIND-AND-DISPLAY-STRUCTURE 23103 . 23974)) (23976 24660 (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS
23976 . 24660)) (24662 25566 (FIND-AND-DISPLAY-SUBSTRUCTURE 24662 . 25566)) (25568 26271 (
FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS 25568 . 26271)) (26273 26914 (FIND-NTH-STRUCTURE 26273 . 26914
)) (26916 29646 (FIND-NODE-SUBSTRUCTURE 26916 . 29646)) (29648 30875 (FIND-NODE-SUBSTRUCTURE-BACKWARDS
29648 . 30875)) (30877 31856 (FIND-OBJ 30877 . 31856)) (31858 33229 (FIND-SELECTION 31858 . 33229)) (
33231 34791 (FIND-SELECTION-BACKWARDS 33231 . 34791)) (34793 37522 (FIND-STRUCTURE 34793 . 37522)) (
37524 39851 (FIND-STRUCTURE-BACKWARDS 37524 . 39851)) (39853 42782 (FIND-SUBSTRUCTURE 39853 . 42782))
(42784 45084 (FIND-SUBSTRUCTURE-BACKWARDS 42784 . 45084)) (45086 45322 (GET-USER-STRING 45086 . 45322)
) (45324 48925 (SEARCH-OBJ 45324 . 48925)) (48927 52485 (SEARCH-OBJ-BACKWARDS 48927 . 52485)) (52487
57315 (SUBSTITUTE-OBJ 52487 . 57315)) (57317 61983 (SUBSTITUTE-STRUCTURE 57317 . 61983)) (61985 65128
(SUBSTITUTE-SUBSTRUCTURE 61985 . 65128)) (65130 66292 (STRUCTURE-FROM-SELECTION 65130 . 66292)) (66294
67137 (STRUCTURE-FROM-STRING 66294 . 67137)) (67139 69410 (COMMENT-OUT-SELECTION 67139 . 69410)) (
69411 124272 (ADD-MENU 69424 . 70087) (BACKSPACE 70089 . 71068) (CHANGE-PACKAGE 71070 . 73870) (
CHANGE-PRINTBASE 73872 . 76054) (CHANGE-QUOTE 76056 . 76411) (CONVERT-COMMENT 76413 . 78173) (
CONVERT-COMMENT-STRUCTURE 78175 . 79478) (CONVERT-COMMENT-TAIL 79480 . 80880) (CREATE-COMMAND-TABLE
80882 . 82860) (DEFAULT-EDIT-FN 82862 . 82999) (DELETE-SELECTION 83001 . 83683) (DELETE-WORD 83685 .
85786) (DO-MUTATION 85788 . 86336) (EDIT-SELECTION 86338 . 86786) (EVAL-SELECTION 86788 . 88657) (
EXPAND 88659 . 89788) (EXTRACT-CURRENT-SELECTION 89790 . 92158) (FIND-COMMENT 92160 . 92854) (GET-MENU
92856 . 93233) (EDIT-HELP 93235 . 94310) (HELPMENU 94312 . 97101) (INPUT-DOT 97103 . 99235) (
INPUT-ESCAPE 99237 . 99485) (INPUT-NORMAL-CHAR 99487 . 101520) (INPUT-QUOTE 101522 . 104604) (
INPUT-SQUARE-BRACKET 104606 . 104957) (INPUT-STRINGDELIM 104959 . 106358) (INPUT-TOKENDELIM 106360 .
107340) (INSERT-MULTI-ESCAPE 107342 . 108470) (INSERT-SPECIAL-CHARACTER 108472 . 109732) (
INSPECT-SELECTION 109734 . 110269) (JOIN 110271 . 113941) (MENU-CLOSEFN 113943 . 114161) (
MENU-FIND-SELECTEDFN 114163 . 114863) (MENU-INIT-STATE 114865 . 115672) (MENU-PACKAGE-SELECTEDFN
115674 . 116725) (MENU-PRINTBASE-SELECTEDFN 116727 . 117603) (MENU-SELECTEDFN 117605 . 118031) (
MENU-SUBSTITUTE-SELECTEDFN 118033 . 118993) (MUTATE 118995 . 120105) (QUOTE-CURRENT-SELECTION 120107
. 120874) (REDISPLAY 120876 . 121115) (REDO 121117 . 121611) (SELECTED-FN-NAME 121613 . 122058) (
SKIP-TO-GAP 122060 . 122837) (UNDO 122839 . 123639) (UNDO-EXTRACT 123641 . 124270)))))
IL:STOP

BIN
sources/SEDIT-COMMANDS.DFASL
View File

Binary file not shown.

513
sources/UFS
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "18-Dec-2024 12:52:23" {WMEDLEY}<sources>UFS.;39 79633
(FILECREATED "27-Oct-2025 11:10:55" {WMEDLEY}<sources>UFS.;61 91949
:EDIT-BY rmk
:CHANGES-TO (FNS \UFSRenameFile)
:CHANGES-TO (FNS \UFSDeleteFile)
:PREVIOUS-DATE "16-Sep-2023 09:22:55" {WMEDLEY}<sources>UFS.;38)
:PREVIOUS-DATE "17-Oct-2025 08:49:57" {WMEDLEY}<sources>UFS.;60)
(PRETTYCOMPRINT UFSCOMS)
@@ -14,6 +14,11 @@
(RPAQQ UFSCOMS
[(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
UFS)
[COMS
(* ;; "For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed.")
(P (MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING]
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
DIRECTORY FILEIO))
(INITVARS (\UFS.DEFAULT.EOLC NIL))
@@ -130,6 +135,17 @@
(PUTPROPS UFS FILETYPE :BCOMPL)
(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10))
(* ;;
"For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed."
)
(MOVD? 'EVQ 'UTF8TOMSTRING)
(MOVD? 'EVQ 'MTOUTF8STRING)
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(FILESLOAD (LOADCOMP)
@@ -274,23 +290,160 @@
(DEFINEQ
(\UFSOpenFile
(LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 6-Jun-90 12:18 by nm") (* ;;; "Open a file.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG ((ACC (SELECTQ ACCESS (INPUT ACCESS-INPUT) (OUTPUT ACCESS-OUTPUT) (BOTH ACCESS-BOTH) (APPEND ACCESS-APPEND) ACCESS-OTHER)) (REC (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (SELECTQ ACCESS (INPUT RECOG-OLD) (OUTPUT RECOG-NEW) ((BOTH APPEND) RECOG-NEW-OLD) RECOG-OTHER))) (EOF-FN (FUNCTION \EOSERROR)) (ERRNO (CREATECELL \FIXP)) OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME CASE.CORRECT.FULLFILENAME) (SETQ CASE.CORRECT.NAME (if (type? STREAM FILE) then (COND ((fetch (UFSSTREAM FILEID) of FILE) (* ; "Already open--this really ought to be an error") (RETURN FILE)) (T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME) of FILE))) (SETQ STRM FILE) (* ; "Re use the old stream") (SUBSTRING FULLNAME (ADD1 (STRPOS "}" FULLNAME)))))) else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV))) (COND ((NOT CASE.CORRECT.NAME) (RETURN NIL)) ((AND (NULL OLDSTREAM) (EQ (fetch (FDEV DEVICENAME) of FDEV) (QUOTE DSK)) (SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV)) (SELECTQ ACCESS (INPUT (* ; "ok if other file is also input") (DIRTYABLE OTHER)) T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV)))) (SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV)) (* ;; "DSK cannot open a directory.") (AND (DSKP FDEV) (DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME) (PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.") (\UFSError CASE.CORRECT.NAME 23 FDEV))) (SETQ CDATE (CREATECELL \FIXP)) (SETQ BYTESIZE (CREATECELL \FIXP)) (SETQ FILEID (OR (\UFSOpenFile-C CASE.CORRECT.FULLFILENAME REC ACC CDATE BYTESIZE ERRNO) (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV)))) (if (= (IPLUS BYTESIZE 0) -1) then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR)) (SETQ BYTESIZE 0) elseif (EQ ACCESS (QUOTE OUTPUT)) then (SETQ BYTESIZE 0)) (if STRM then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)) (replace (STREAM DEVICE) of STRM with FDEV) (replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE)) (replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE)) (replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO))) (replace (STREAM VALIDATION) of STRM with CDATE) (replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN) else (SETQ STRM (create STREAM FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T) DEVICE _ FDEV EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE) EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE) EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO)) VALIDATION _ CDATE ENDOFSTREAMOP _ EOF-FN))) (replace (UFSSTREAM FILEID) of STRM with FILEID) (replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC (QUOTE CREATIONDATE) OTHERINFO)) then (IDATE (CADR CINFO)) else 0)) (replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME) (* ; "Save the case sensitive full file name for closef & getfileinfo.") (RETURN STRM))))
)
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk")
(* ; "Edited 6-Jun-90 12:18 by nm")
(* ;;; "Open a file.")
(WITH.MONITOR (\UFSGetMonitor FDEV)
(PROG ((ACC (SELECTQ ACCESS
(INPUT ACCESS-INPUT)
(OUTPUT ACCESS-OUTPUT)
(BOTH ACCESS-BOTH)
(APPEND ACCESS-APPEND)
ACCESS-OTHER))
(REC (SELECTQ RECOG
(OLD RECOG-OLD)
(OLDEST RECOG-OLDEST)
(NEW RECOG-NEW)
(OLD/NEW RECOG-NEW-OLD)
(SELECTQ ACCESS
(INPUT RECOG-OLD)
(OUTPUT RECOG-NEW)
((BOTH APPEND)
RECOG-NEW-OLD)
RECOG-OTHER)))
(EOF-FN (FUNCTION \EOSERROR))
(ERRNO (CREATECELL \FIXP))
OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME
CASE.CORRECT.FULLFILENAME)
(* ;; "CASE.CORRECT.NAME is MCCS")
(SETQ CASE.CORRECT.NAME (if (type? STREAM FILE)
then [COND
((fetch (UFSSTREAM FILEID) of FILE)
(* ;
 "Already open--this really ought to be an error")
(RETURN FILE))
(T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME)
of FILE)))
(SETQ STRM FILE)
(* ; "Re use the old stream")
(SUBSTRING FULLNAME (ADD1 (STRPOS "}"
FULLNAME]
else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV)))
[COND
((NOT CASE.CORRECT.NAME)
(RETURN NIL))
((AND (NULL OLDSTREAM)
(EQ (fetch (FDEV DEVICENAME) of FDEV)
'DSK)
(SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV))
(SELECTQ ACCESS
(INPUT (* ; "ok if other file is also input")
(DIRTYABLE OTHER))
T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...")
(CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV]
(SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV))
(* ;; "DSK cannot open a directory.")
(AND (DSKP FDEV)
(DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME)
(PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.")
(\UFSError CASE.CORRECT.NAME 23 FDEV)))
(SETQ CDATE (CREATECELL \FIXP))
(SETQ BYTESIZE (CREATECELL \FIXP))
[SETQ FILEID (OR (\UFSOpenFile-C (MTOUTF8STRING CASE.CORRECT.FULLFILENAME)
REC ACC CDATE BYTESIZE ERRNO)
(RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV]
(if (= (IPLUS BYTESIZE 0)
-1)
then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR))
(SETQ BYTESIZE 0)
elseif (EQ ACCESS 'OUTPUT)
then (SETQ BYTESIZE 0))
(if STRM
then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME
FDEV T))
(replace (STREAM DEVICE) of STRM with FDEV)
(replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE))
(replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE))
(replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME
(FASSOC 'TYPE OTHERINFO)))
(replace (STREAM VALIDATION) of STRM with CDATE)
(replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN)
else (SETQ STRM (create STREAM
FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)
DEVICE _ FDEV
EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE)
EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE)
EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC
'TYPE OTHERINFO))
VALIDATION _ CDATE
ENDOFSTREAMOP _ EOF-FN)))
(replace (UFSSTREAM FILEID) of STRM with FILEID)
(replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC 'CREATIONDATE OTHERINFO
))
then (IDATE (CADR CINFO))
else 0))
(replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME)
(* ;
 "Save the case sensitive full file name for closef & getfileinfo.")
(RETURN STRM)))])
(\UFS.OPENP
(LAMBDA (UNIXNAME DEV) (* ; "Edited 3-Mar-89 11:47 by bvm") (* ;; "Returns first open file having specified unix name") (for S in (fetch (FDEV OPENFILELST) of DEV) bind (COMPAREFN _ (if (EQ (fetch (FDEV DEVICENAME) of DEV) (QUOTE DSK)) then (* ; "We're case-insensitive, and it seems like not all functions return the correct Unix case") (FUNCTION STRING-EQUAL) else (* ; "Exact") (FUNCTION STREQUAL))) thereis (CL:FUNCALL COMPAREFN UNIXNAME (fetch (UFSSTREAM UNIXNAME) of S))))
)
(\UFS.RECOGNIZE.FILE
(LAMBDA (FILENAME RECOG DEV) (* ; "Edited 13-Mar-90 11:19 by nm") (* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (ERRNO (CREATECELL \FIXP)) LEN) (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) (\UFS.REMOVE.HOST.FIELD FILENAME DEV) (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (NON RECOG-NON) RECOG-NEW-OLD) NAMEAREA ERRNO)) (COND ((FIXP LEN) (SUBSTRING NAMEAREA 1 LEN)) (T (\UFSError FILENAME ERRNO))))))
)
[LAMBDA (FILENAME RECOG DEV) (* ; "Edited 16-Oct-2025 10:19 by rmk")
(* ; "Edited 13-Mar-90 11:19 by nm")
(* ;; "This assumes that input FILENAME is MCCS, returns MCCS")
(* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.")
(WITH.MONITOR (\UFSGetMonitor DEV)
[LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
(ERRNO (CREATECELL \FIXP))
LEN)
(SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV)
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV))
(SELECTQ RECOG
(OLD RECOG-OLD)
(OLDEST RECOG-OLDEST)
(NEW RECOG-NEW)
(OLD/NEW RECOG-NEW-OLD)
(NON RECOG-NON)
RECOG-NEW-OLD)
NAMEAREA ERRNO))
(COND
((FIXP LEN)
(UTF8TOMSTRING (SUBSTRING NAMEAREA 1 LEN)))
(T (\UFSError FILENAME ERRNO])])
(\UFS.DIRECTORY.NAME
(LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 1-Apr-90 23:36 by nm") (* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"ture%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"ture%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.") (if (STREQUAL DIRSTRING "<") then (RPLSTRING NAMEAREA 1 "<") 1 else (WITH.MONITOR (\UFSGetMonitor DEV) (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) DIRSTRING NAMEAREA (CREATECELL \FIXP)))))
)
[LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 15-Oct-2025 16:30 by rmk")
(* ; "Edited 1-Apr-90 23:36 by nm")
(* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"true%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"true%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.")
(* ;; "DIRSTRING is MCCS, the true name is not")
(if (STREQUAL DIRSTRING "<")
then (RPLSTRING NAMEAREA 1 "<")
1
else (WITH.MONITOR (\UFSGetMonitor DEV)
(CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV)
(MTOUTF8STRING DIRSTRING)
NAMEAREA
(CREATECELL \FIXP)))])
(\UFSCloseFile
[LAMBDA (STREAMFILE) (* ; "Edited 16-Sep-2023 09:21 by briggs")
[LAMBDA (STREAMFILE) (* ; "Edited 16-Oct-2025 13:47 by rmk")
(* ; "Edited 16-Sep-2023 09:21 by briggs")
(* ; "Edited 30-Mar-90 10:39 by nm")
(* ; "return stream")
@@ -314,7 +467,8 @@
then (* ; "Open for output")
(FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE)
(SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE)))
(RETURN (if (\UFSCloseFile-C UNIXNAME (fetch (UFSSTREAM FILEID) of STREAMFILE)
(RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME)
(fetch (UFSSTREAM FILEID) of STREAMFILE)
CDATE ERRNO)
then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL)
(replace (UFSSTREAM CDATE) of STREAMFILE with NIL)
@@ -328,11 +482,26 @@
)
(\UFSDeleteFile
(LAMBDA (FILENAME DEV) (* ; "Edited 30-Mar-90 10:46 by nm") (* ; "return deleted file name") (* ; "if error, return NIL") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAME (\UFS.RECOGNIZE.FILE FILENAME (QUOTE OLDEST) DEV))) (COND ((AND NAME (NOT (\UFS.OPENP NAME DEV))) (* ; "file found and not open, so try to delete") (LET ((ERRNO (CREATECELL \FIXP))) (COND ((\UFSDeleteFile-C (\UFS.REMOVE.HOST.FIELD NAME DEV) DEV ERRNO) (* ; "Success") (\UFS.FULLNAME NAME DEV T)) (T (* ; "Failure") (\UFSError NAME ERRNO DEV)))))))))
)
[LAMBDA (FILENAME DEV) (* ; "Edited 27-Oct-2025 11:10 by rmk")
(* ; "Edited 30-Mar-90 10:46 by nm")
(* ; "return deleted file name")
(* ; "if error, return NIL")
(WITH.MONITOR (\UFSGetMonitor DEV)
[LET ((NAME (\UFS.RECOGNIZE.FILE FILENAME 'OLDEST DEV)))
(COND
((AND NAME (NOT (\UFS.OPENP NAME DEV))) (* ;
 "file found and not open, so try to delete")
(LET ((ERRNO (CREATECELL \FIXP)))
(COND
((\UFSDeleteFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NAME DEV))
DEV ERRNO) (* ; "Success")
(\UFS.FULLNAME NAME DEV T))
(T (* ; "Failure")
(\UFSError NAME ERRNO DEV])])
(\UFSRenameFile
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 18-Dec-2024 12:52 by rmk")
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Oct-2025 08:46 by rmk")
(* ; "Edited 18-Dec-2024 12:52 by rmk")
(* ; "Edited 16-Apr-90 13:46 by nm")
(if (NEQ OLD-DEVICE NEW-DEVICE)
then
@@ -349,8 +518,10 @@
(LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE))
(ERRNO (CREATECELL \FIXP)))
(COND
((\UFSRenameFile-C (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME OLD-DEVICE)
(\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE)
((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD
OLDUNIXNAME OLD-DEVICE))
(MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME
NEW-DEVICE))
NEW-DEVICE ERRNO)
(\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE))
(T (if (EQL (IPLUS ERRNO 0)
@@ -372,32 +543,200 @@
)
(\UFSTruncateFile
(LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 22-Aug-90 16:46 by nm") (* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.") (\UPDATEOF STREAM) (OR (FIXP PAGE#) (SETQ PAGE# (fetch (STREAM EPAGE) of STREAM))) (OR (FIXP OFFSET) (SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ; "Truncate size was set to PAGE# and OFFSET") (PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM) BYTESPERPAGE) (fetch (STREAM EOFFSET) of STREAM))) (needSize (+ (UNFOLD PAGE# BYTESPERPAGE) OFFSET)) (ERRNO (CREATECELL \FIXP))) (if (> needSize curEof) then (* ; "Push 0 to extend file.") (LET ((FILEPTR (\GETFILEPTR STREAM))) (\SETFILEPTR STREAM curEof) (to (- needSize curEof) do (\BOUT STREAM 0)) (\SETFILEPTR STREAM FILEPTR)) elseif T then (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed") (OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM) needSize ERRNO) (RETURN (\UFSError STREAM ERRNO))) else (RETURN)) (* ;; "Set new value to stream") (replace (STREAM EPAGE) of STREAM with PAGE#) (replace (STREAM EOFFSET) of STREAM with OFFSET) (LET ((DT (CREATECELL \FIXP))) (* ;; "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") (if (\UFSGetFileInfo-C (fetch (UFSSTREAM UNIXNAME) of STREAM) ATTR-WDATE DT ERRNO) then (replace (STREAM VALIDATION) of STREAM with DT)))))
)
[LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 16-Oct-2025 08:56 by rmk")
(* ; "Edited 22-Aug-90 16:46 by nm")
(* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.")
(\UPDATEOF STREAM)
(OR (FIXP PAGE#)
(SETQ PAGE# (fetch (STREAM EPAGE) of STREAM)))
(OR (FIXP OFFSET)
(SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ;
 "Truncate size was set to PAGE# and OFFSET")
(PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM)
BYTESPERPAGE)
(fetch (STREAM EOFFSET) of STREAM)))
(needSize (+ (UNFOLD PAGE# BYTESPERPAGE)
OFFSET))
(ERRNO (CREATECELL \FIXP)))
(if (> needSize curEof)
then (* ; "Push 0 to extend file.")
(LET ((FILEPTR (\GETFILEPTR STREAM)))
(\SETFILEPTR STREAM curEof)
(to (- needSize curEof) do (\BOUT STREAM 0))
(\SETFILEPTR STREAM FILEPTR))
else (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed")
(OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM)
needSize ERRNO)
(RETURN (\UFSError STREAM ERRNO)))
else (RETURN))
(* ;; "Set new value to stream")
(replace (STREAM EPAGE) of STREAM with PAGE#)
(replace (STREAM EOFFSET) of STREAM with OFFSET)
(LET ((DT (CREATECELL \FIXP)))
(* ;;
 "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.")
(if (\UFSGetFileInfo-C (MTOUTF8STRING (fetch (UFSSTREAM UNIXNAME) of STREAM))
ATTR-WDATE DT ERRNO)
then (replace (STREAM VALIDATION) of STREAM with DT])
(\UFSDirectoryNameP
(LAMBDA (DIRSPEC DEV) (* ; "Edited 21-Sep-92 15:27 by jds") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") (LET ((DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DEVICE)) "") (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DIRECTORY) (QUOTE RETURN)) (\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC (QUOTE RELATIVEDIRECTORY) (QUOTE RETURN)) DEV) (\UFS.DEFAULT.DIR DEV)))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") (COND (DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))) (T NIL))))
)
[LAMBDA (DIRSPEC DEV) (* ; "Edited 16-Oct-2025 10:23 by rmk")
(* ; "Edited 21-Sep-92 15:27 by jds")
(* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.")
(LET ([DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC 'DEVICE)
"")
(OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN)
(\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC
'RELATIVEDIRECTORY
'RETURN)
DEV)
(\UFS.DEFAULT.DIR DEV]
NAMEAREA LEN)
(* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.")
(COND
(DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
(* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.")
(SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV))
(COND
((FIXP LEN) (* ;
 "LEN holds the length of the %"true%" name of DIRECTORY.")
(UTF8TOMSTRING (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN)
DEV NIL)))
(T NIL)))
(T NIL])
(\UFSEventFn
(LAMBDA (Dev Event) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 3-May-90 17:35 by nm") (WITH.MONITOR \UFStopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\UFSCloseDevice) (SELECTQ (MACHINETYPE) ((MAIKO) (\UFSOpenDevice) (* ;; "revalidate open streams (should probably move this into the SELECTQ above) ") (\UNVISIBLE.PAGED.REVALIDATEFILELST Dev) (\PAGED.REVALIDATEFILELST Dev) (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL)))) (CLRHASH \UFS.GFS.TABLE)) NIL)) ((BEFORELOGOUT) (\UNVISIBLE.FLUSH.OPEN.STREAMS Dev) (* ; "flush output buffers.") (\FLUSH.OPEN.STREAMS Dev)) NIL)))
)
(\UFSGetFileInfo
(LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 30-Mar-90 12:27 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL)))))
)
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 16-Oct-2025 08:49 by rmk")
(* ; "Edited 30-Mar-90 12:27 by nm")
(* ;;; "Get the value of the attribute for a file.")
(* ;;; "Allocate buffer to store the value.")
(* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.")
(* ;;; "Otherwise the type of the buffer is FIXP.")
(WITH.MONITOR (\UFSGetMonitor DEVICE)
(LET ((FILENAME (if (type? STREAM STREAM)
then (fetch (UFSSTREAM UNIXNAME) of STREAM)
else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM 'OLD DEVICE)
DEVICE NIL)))
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
(SELECTQ ATTRIBUTE
(LENGTH (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO)
then BUFFER
else (\UFSError FILENAME ERRNO DEVICE)))
(SIZE (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO)
then (FOLDHI BUFFER BYTESPERPAGE)
else (\UFSError FILENAME ERRNO DEVICE)))
(TYPE (\UFSGetFileType FILENAME))
((CREATIONDATE WRITEDATE)
(SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO)
then (GDATE BUFFER)
else (\UFSError FILENAME ERRNO DEVICE)))
(READDATE (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO)
then (GDATE BUFFER)
else (\UFSError FILENAME ERRNO DEVICE)))
((ICREATIONDATE IWRITEDATE)
(SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO)
then BUFFER
else (\UFSError FILENAME ERRNO DEVICE)))
(IREADDATE (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO)
then BUFFER
else (\UFSError FILENAME ERRNO DEVICE)))
(AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN))
(if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER
ERRNO))
then (UTF8TOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE))
else (\UFSError FILENAME ERRNO DEVICE)))
(PROTECTION (SETQ BUFFER (CREATECELL \FIXP))
(if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO)
then BUFFER
else (\UFSError FILENAME ERRNO DEVICE)))
(ALL (SETQ BUFFER (\UFS.CREATE.PROPS))
(if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO))
then (LET ((ALIST (ASSOC 'AUTHOR BUFFER)))
(* ; "Copy string out of buffer")
(RPLACD ALIST (CL:SUBSEQ (CDR ALIST)
0 NAMESIZE))
BUFFER)
else (\UFSError FILENAME ERRNO DEVICE)))
NIL))))])
(\UFS.CREATE.PROPS
(LAMBDA NIL (* ; "Edited 2-Mar-89 12:10 by bvm") (* ;; "Returns a data structure suitable for passing to the GetFileInfo ALL routine") (BQUOTE ((LENGTH (\,@ (CREATECELL \FIXP))) (WDATE (\,@ (CREATECELL \FIXP))) (RDATE (\,@ (CREATECELL \FIXP))) (PROTECTION (\,@ (CREATECELL \FIXP))) (AUTHOR (\,@ (ALLOCSTRING MAX-UNAME-LEN))))))
)
(\UFSSetFileInfo
(LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 30-Mar-90 12:31 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL)))))
)
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 16-Oct-2025 08:51 by rmk")
(* ; "Edited 30-Mar-90 12:31 by nm")
(* ;;; "Get the VALUE of the ATTRIBUTE for a file.")
(* ;;; "Allocate buffer to store the value.")
(* ;;; "If attribute is AUTOR, the type of the buffer is STRING.")
(* ;;; " Otherwise the type of the buffer is FIXP.")
(WITH.MONITOR (\UFSGetMonitor DEVICE)
(LET ((FILENAME (if (type? STREAM STREAM)
then (fetch (UFSSTREAM UNIXNAME) of STREAM)
else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM 'OLD DEVICE)
DEVICE NIL)))
(ERRNO (CREATECELL \FIXP))
BUFFER NAMESIZE PATHNAME)
(if FILENAME
then (SETQ FILENAME (MTOUTF8STRING FILENAME))
(SELECTQ ATTRIBUTE
(TYPE (\UFSSetFileType FILENAME VALUE))
((CREATIONDATE WRITEDATE)
(if (AND (STRINGP VALUE)
(SETQ VALUE (IDATE VALUE)))
then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO)
(\UFSError FILENAME ERRNO DEVICE))
else (ERROR "Invalid argument" VALUE)))
((ICREATIONDATE IWRITEDATE)
(if (FIXP VALUE)
then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO)
(\UFSError FILENAME ERRNO DEVICE))
else (ERROR "Invalid argument" VALUE)))
(PROTECTION (if (FIXP VALUE)
then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE
ERRNO)
(\UFSError FILENAME ERRNO DEVICE))
else (ERROR "Invalid argument" VALUE)))
NIL))))])
(\UFSGenerateFiles
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
(* ;; "Edited 16-Oct-2025 11:06 by rmk")
(* ;; "Edited 27-Mar-2022 15:55 by rmk: Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults")
(* ;; "rmk; Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults")
@@ -435,19 +774,22 @@
(COND
((STREQUAL DIRECTORY "/")
(SETQ DIRECTORY "<")))
[SETQ FILTER (COND
((STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION
'VERSION VERSION)))
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
PARSED
'HOST)
'DEVICE DEVICE 'NAME NAME 'EXTENSION EXTENSION 'VERSION
VERSION]
(* ;; "DIRECTORY is MCCS, FILTER is UTF8")
[SETQ FILTER (MTOUTF8STRING (COND
((STREQUAL DIRECTORY "<")
(CONCAT "{" (LISTGET PARSED 'HOST)
"}"
(OR DEVICE "")
"<"
(PACKFILENAME.STRING 'NAME NAME 'EXTENSION
EXTENSION 'VERSION VERSION)))
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY
'HOST
(LISTGET PARSED 'HOST)
'DEVICE DEVICE 'NAME NAME 'EXTENSION
EXTENSION 'VERSION VERSION]
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
DIRECTORY)
NAMEAREA FDEV))
@@ -455,7 +797,7 @@
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
(RETURN (\NULLFILEGENERATOR]
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8")
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
@@ -466,7 +808,8 @@
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
(COND
[(< TOTALNUM 0)
(OR (\UFSError DIRECTORY ERRNO FDEV)
(OR (\UFSError (UTF8TOMSTRING DIRECTORY)
ERRNO FDEV)
(RETURN (\NULLFILEGENERATOR]
(T (COND
((ZEROP TOTALNUM)
@@ -475,6 +818,9 @@
(EQ OPTIONS 'RESETLST))
(FMEMB 'RESETLST OPTIONS))
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
(* ;; "Everything in FILEGENOBJ is UTF8")
(RETURN (create FILEGENOBJ
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN)
@@ -496,24 +842,31 @@
CURRENT-DEPTH _ 1
MAX-DEPTH _
FILING.ENUMERATION.DEPTH
FILTER _ (
PACKFILENAME.STRING
'NAME NAME
'EXTENSION
EXTENSION
'VERSION VERSION])
])
FILTER _
(PACKFILENAME.STRING
'NAME
(AND NAME (MTOUTF8STRING
NAME))
'EXTENSION
(AND EXTENSION (
MTOUTF8STRING
EXTENSION))
'VERSION VERSION])])
(\UFS.NEXTFILEFN
[LAMBDA (GENFILESTATE NAMEONLY)
(* ;; "Edited 16-Oct-2025 16:59 by rmk")
(* ;;
 "Edited 27-Mar-2022 21:59 by rmk: Add FILTER to construct proper generator for subdirectories")
(* ;; "Edited 7-Oct-93 14:31 by jds")
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
(* ; "")
(* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS")
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE))
FILENAME NAMELEN NEWNAME)
(COND
@@ -556,6 +909,9 @@
GENFILESTATE
)
0 NAMELEN))
(* ;; "NEWNAME and DIRECTORY are both UTF8")
(SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY)
of GENFILESTATE)
NEWNAME
@@ -607,8 +963,8 @@
(* ;; "We're set up to recurse into the SUBGEN above")
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))
(NAMEONLY NEWNAME)
(T FILENAME)))
(NAMEONLY (UTF8TOMSTRING NEWNAME))
(T (UTF8TOMSTRING FILENAME))))
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
(\UFS.FILEINFOFN
@@ -720,8 +1076,25 @@
(DEFINEQ
(CHDIR
(LAMBDA (PATHNAME) (* ; "Edited 2-Apr-90 01:07 by nm") (* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.") (WITH.MONITOR \UFStopMonitor (LET ((PATH (\ADD.CONNECTED.DIR PATHNAME)) HOST) (if PATH then (SETQ HOST (U-CASE (FILENAMEFIELD PATH (QUOTE HOST)))) (if (OR (EQ HOST (QUOTE DSK)) (EQ HOST (QUOTE UNIX))) then (if (SETQ PATH (DIRECTORYNAME PATH)) then (if (\UFSCHDIR-C PATH) then (DIRECTORYNAME PATH) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "Bad Host Name" HOST)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)))))
)
[LAMBDA (PATHNAME) (* ; "Edited 16-Oct-2025 18:22 by rmk")
(* ; "Edited 2-Apr-90 01:07 by nm")
(* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.")
(WITH.MONITOR \UFStopMonitor
(LET ((PATH (\ADD.CONNECTED.DIR PATHNAME))
HOST)
(if PATH
then [SETQ HOST (U-CASE (FILENAMEFIELD PATH 'HOST]
(if (OR (EQ HOST 'DSK)
(EQ HOST 'UNIX))
then (if (SETQ PATH (DIRECTORYNAME PATH))
then (if (\UFSCHDIR-C (MTOUTF8STRING PATH))
then (DIRECTORYNAME PATH)
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))
else (ERROR "Bad Host Name" HOST))
else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))))])
)
@@ -1184,23 +1557,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
(ADDTOVAR LAMA )
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (8857 10410 (\UFSCreateDevice 8867 . 9232) (\UFS.CREATE.DEVICE 9234 . 10090) (
\UFSOpenDevice 10092 . 10269) (\UFSCloseDevice 10271 . 10408)) (14673 52047 (\UFSOpenFile 14683 .
17977) (\UFS.OPENP 17979 . 18476) (\UFS.RECOGNIZE.FILE 18478 . 19231) (\UFS.DIRECTORY.NAME 19233 .
19976) (\UFSCloseFile 19978 . 21883) (\UFSGetFileName 21885 . 22084) (\UFSDeleteFile 22086 . 22626) (
\UFSRenameFile 22628 . 24665) (\UFSReadPages 24667 . 25802) (\UFSWritePages 25804 . 27024) (
\UFSTruncateFile 27026 . 28523) (\UFSDirectoryNameP 28525 . 29579) (\UFSEventFn 29581 . 30243) (
\UFSGetFileInfo 30245 . 32527) (\UFS.CREATE.PROPS 32529 . 32882) (\UFSSetFileInfo 32884 . 34113) (
\UFSGenerateFiles 34115 . 40995) (\UFS.NEXTFILEFN 40997 . 48635) (\UFS.FILEINFOFN 48637 . 50086) (
\UFS.VALID.PROPP 50088 . 50380) (\UFS.REGISTER.GFS 50382 . 50637) (\UFS.UNREGISTER.GFS 50639 . 51222)
(\UFS.ABORT.DIRECTORY 51224 . 51572) (\UFS.ABORT.CL-DIRECTORY 51574 . 51861) (\UFS.CLEANUP.GFS.TABLE
51863 . 52045)) (52082 58766 (\UFSMakeUnixFormatName 52092 . 53113) (\UFSParseNameString 53115 . 53489
) (\UFSParse-Directory 53491 . 54032) (\UFS.PARSE.BODY 54034 . 54579) (\UFS.ADJUST.HOST 54581 . 54740)
(\UFS.FULLNAME 54742 . 55950) (\UFS.ADD.HOST.FIELD 55952 . 56312) (\UFS.REMOVE.HOST.FIELD 56314 .
57984) (\UFS.HANDLE.RELATIVEDIRECTORY 57986 . 58764)) (59582 60195 (CHDIR 59592 . 60193)) (60267 61253
(\DEVICEFILE.EOSERROR 60277 . 61251)) (61326 62563 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61336 . 62181)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 62183 . 62561)) (62596 64222 (\UFSError 62606 . 64220)) (64266 66681 (
\UFSGetFileType 64276 . 64877) (\UFSSetFileType 64879 . 65476) (\UFSeol 65478 . 66679)) (75328 76452 (
\UFSGetPrintFileType 75338 . 75750) (\UFSGetFileTypeConfirm 75752 . 76200) (\UFSPrintTypeMenu 76202 .
76450)) (76482 79320 (\UFStoOtherCopyMess 76492 . 78170) (\UFStoOtherRenameMess 78172 . 79318)))))
(FILEMAP (NIL (9321 10874 (\UFSCreateDevice 9331 . 9696) (\UFS.CREATE.DEVICE 9698 . 10554) (
\UFSOpenDevice 10556 . 10733) (\UFSCloseDevice 10735 . 10872)) (15137 63831 (\UFSOpenFile 15147 .
21723) (\UFS.OPENP 21725 . 22222) (\UFS.RECOGNIZE.FILE 22224 . 23654) (\UFS.DIRECTORY.NAME 23656 .
24746) (\UFSCloseFile 24748 . 26807) (\UFSGetFileName 26809 . 27008) (\UFSDeleteFile 27010 . 28204) (
\UFSRenameFile 28206 . 30523) (\UFSReadPages 30525 . 31660) (\UFSWritePages 31662 . 32882) (
\UFSTruncateFile 32884 . 35290) (\UFSDirectoryNameP 35292 . 37155) (\UFSEventFn 37157 . 37819) (
\UFSGetFileInfo 37821 . 42284) (\UFS.CREATE.PROPS 42286 . 42639) (\UFSSetFileInfo 42641 . 44987) (
\UFSGenerateFiles 44989 . 52601) (\UFS.NEXTFILEFN 52603 . 60419) (\UFS.FILEINFOFN 60421 . 61870) (
\UFS.VALID.PROPP 61872 . 62164) (\UFS.REGISTER.GFS 62166 . 62421) (\UFS.UNREGISTER.GFS 62423 . 63006)
(\UFS.ABORT.DIRECTORY 63008 . 63356) (\UFS.ABORT.CL-DIRECTORY 63358 . 63645) (\UFS.CLEANUP.GFS.TABLE
63647 . 63829)) (63866 70550 (\UFSMakeUnixFormatName 63876 . 64897) (\UFSParseNameString 64899 . 65273
) (\UFSParse-Directory 65275 . 65816) (\UFS.PARSE.BODY 65818 . 66363) (\UFS.ADJUST.HOST 66365 . 66524)
(\UFS.FULLNAME 66526 . 67734) (\UFS.ADD.HOST.FIELD 67736 . 68096) (\UFS.REMOVE.HOST.FIELD 68098 .
69768) (\UFS.HANDLE.RELATIVEDIRECTORY 69770 . 70548)) (71366 72511 (CHDIR 71376 . 72509)) (72583 73569
(\DEVICEFILE.EOSERROR 72593 . 73567)) (73642 74879 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73652 . 74497)
(\UNVISIBLE.FLUSH.OPEN.STREAMS 74499 . 74877)) (74912 76538 (\UFSError 74922 . 76536)) (76582 78997 (
\UFSGetFileType 76592 . 77193) (\UFSSetFileType 77195 . 77792) (\UFSeol 77794 . 78995)) (87644 88768 (
\UFSGetPrintFileType 87654 . 88066) (\UFSGetFileTypeConfirm 88068 . 88516) (\UFSPrintTypeMenu 88518 .
88766)) (88798 91636 (\UFStoOtherCopyMess 88808 . 90486) (\UFStoOtherRenameMess 90488 . 91634)))))
STOP

BIN
sources/UFS.LCOM
View File

Binary file not shown.

90
sources/XCL-EXTRAS
View File

@@ -1,13 +1,14 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
(IL:FILECREATED "18-May-90 01:15:40" IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;2| 15315
(DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10)
IL:|changes| IL:|to:| (IL:VARS IL:XCL-EXTRASCOMS)
(IL:FILECREATED "11-Dec-2025 22:27:58" IL:|{DSK}<home>matt>Interlisp>medley>sources>XCL-EXTRAS.;2| 15547
IL:|previous| IL:|date:| "11-Jan-88 16:59:17"
IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
:EDIT-BY "mth"
:CHANGES-TO (IL:FUNCTIONS DEFINE-RECORD)
:PREVIOUS-DATE "18-May-90 01:15:40" IL:|{DSK}<home>matt>Interlisp>medley>sources>XCL-EXTRAS.;1|
)
; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:XCL-EXTRASCOMS)
@@ -145,8 +146,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
IL:*INTERLISP-PACKAGE*))
(COLLECT KEYWORD-SYMBOL)
(IF (NOT (MEMBER KEYWORD-SYMBOL '(IL:USING IL:COPYING
IL:REUSING IL:SMASHING
)
IL:REUSING IL:SMASHING)
:TEST
#'EQ))
(COLLECT 'IL:_))
@@ -162,12 +162,12 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
(DEFDEFINER DEFINE-RECORD IL:STRUCTURES (RECORD-NAME INTERLISP-RECORD-NAME &KEY (CONC-NAME NIL
CONC-NAME-P
)
(CONSTRUCTOR NIL CONSTRUCTOR-P)
(PREDICATE NIL PREDICATE-P)
(FAST-ACCESSORS NIL)
(PACKAGE *PACKAGE*))
CONC-NAME-P)
(CONSTRUCTOR NIL CONSTRUCTOR-P)
(PREDICATE NIL PREDICATE-P)
(FAST-ACCESSORS NIL)
(PACKAGE *PACKAGE*))
(IL:* IL:\; "Edited 11-Dec-2025 21:43 by mth")
(IF (NOT (PACKAGEP PACKAGE))
(SETQ PACKAGE (FIND-PACKAGE PACKAGE)))
(SETQ CONC-NAME (IF CONC-NAME-P
@@ -195,7 +195,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
'SETF-RECORD-ACCESS-MACRO)
(SETF (GET ',NEW-NAME :SLOT-INFO)
',`((,INTERLISP-RECORD-NAME ,FIELD-NAME)
,FAST-ACCESSORS))))))
,FAST-ACCESSORS))
(IL:CLSMARTEN '((,NEW-NAME IL:OBJECT)))))))
FIELD-NAMES)
,@(LET ((NEW-NAME (IF PREDICATE-P
PREDICATE
@@ -214,7 +215,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
`((SETF (MACRO-FUNCTION ',NEW-NAME)
'RECORD-PREDICATE-MACRO)
(SETF (GET ',NEW-NAME :TYPE-INFO)
',INTERLISP-RECORD-NAME))))
',INTERLISP-RECORD-NAME)
(IL:CLSMARTEN '((,NEW-NAME IL:OBJECT))))))
,@(LET ((NEW-NAME (IF CONSTRUCTOR-P
CONSTRUCTOR
(INTERN (CONCATENATE 'STRING "MAKE-" (STRING RECORD-NAME))
@@ -234,7 +236,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
`((SETF (MACRO-FUNCTION ',NEW-NAME)
'RECORD-CONSTRUCTOR-MACRO)
(SETF (GET ',NEW-NAME :FIELD-INFO)
'(,INTERLISP-RECORD-NAME ,FIELD-NAMES))))))))
'(,INTERLISP-RECORD-NAME ,FIELD-NAMES))
(IL:CLSMARTEN '((,NEW-NAME &KEY ,@FIELD-NAMES)))))))))
(DEFUN RECORD-ACCESS-MACRO (FORM &OPTIONAL ENV)
(DECLARE (IGNORE ENV))
@@ -257,8 +260,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
(DEFUN RECORD-PREDICATE-MACRO (FORM &OPTIONAL ENV)
(DECLARE (IGNORE ENV))
`(IL:|type?| ,(OR (GET (CAR FORM)
:TYPE-INFO)
(ERROR "No type information cached."))
:TYPE-INFO)
(ERROR "No type information cached."))
,(SECOND FORM)))
(DEFUN RECORD-CONSTRUCTOR-MACRO (FORM &OPTIONAL ENV)
@@ -267,32 +270,35 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>XCL-EXTRAS.;1|)
(OR (GET (CAR FORM)
:FIELD-INFO)
(ERROR "No field information cached."))
`(IL:|create| ,TYPE
,@(WITH-COLLECTION (DO* ((KEYWORD (CDR FORM)
(CDDR KEYWORD))
(KEYWORD-SYMBOL (CAR KEYWORD)
(CAR KEYWORD))
(VALUE (CADR KEYWORD)
(CADR KEYWORD))
RESERVED-WORD)
((NULL KEYWORD))
(SETQ RESERVED-WORD
(CAR (MEMBER KEYWORD-SYMBOL
'(IL:USING IL:COPYING IL:REUSING
IL:SMASHING)
:TEST
'STRING=)))
(COLLECT (OR RESERVED-WORD (CAR (MEMBER KEYWORD-SYMBOL
FIELD-NAMES :TEST
'STRING=))))
(IF (NOT RESERVED-WORD)
(COLLECT 'IL:_))
(COLLECT VALUE))))))
`(IL:|create| ,TYPE ,@(WITH-COLLECTION (DO* ((KEYWORD (CDR FORM)
(CDDR KEYWORD))
(KEYWORD-SYMBOL (CAR KEYWORD)
(CAR KEYWORD))
(VALUE (CADR KEYWORD)
(CADR KEYWORD))
RESERVED-WORD)
((NULL KEYWORD))
(SETQ RESERVED-WORD
(CAR (MEMBER KEYWORD-SYMBOL
'(IL:USING IL:COPYING
IL:REUSING IL:SMASHING)
:TEST
'STRING=)))
(COLLECT (OR RESERVED-WORD
(CAR (MEMBER KEYWORD-SYMBOL
FIELD-NAMES :TEST
'STRING=))))
(IF (NOT RESERVED-WORD)
(COLLECT 'IL:_))
(COLLECT VALUE))))))
(IL:PUTPROPS IL:XCL-EXTRAS IL:FILETYPE :COMPILE-FILE)
(IL:PUTPROPS IL:XCL-EXTRAS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
(IL:PUTPROPS IL:XCL-EXTRAS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
(IL:FILEMAP (NIL (2264 4771 (ONCE-ONLY 2264 . 4771)) (4828 5137 (RECORD-FETCH 4828 . 5137)) (5139 5483
(SETF-FETCH 5139 . 5483)) (5485 5796 (RECORD-FFETCH 5485 . 5796)) (5798 6144 (SETF-FFETCH 5798 . 6144
)) (6146 7341 (RECORD-CREATE 6146 . 7341)) (12279 12699 (RECORD-ACCESS-MACRO 12279 . 12699)) (13146
13397 (RECORD-PREDICATE-MACRO 13146 . 13397)) (13399 15360 (RECORD-CONSTRUCTOR-MACRO 13399 . 15360))))
)
IL:STOP

BIN
sources/XCL-EXTRAS.DFASL
View File

Binary file not shown.

117
sources/XCL-LOOP
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LOOP" (USE "LISP" "XCL")) READTABLE "XCL" BASE 10)
(il:filecreated "14-Jun-2024 23:09:54" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;4| 62255
(il:filecreated " 3-Dec-2025 12:36:20" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;3| 62357
:edit-by "mth"
:changes-to (il:functions default-type default-value)
:changes-to (il:functions cl::symbol-macrolet)
:previous-date " 8-Apr-2024 19:38:27" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;2|
:previous-date " 3-Dec-2025 11:51:58" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;2|
)
@@ -1202,12 +1202,13 @@
(defun stray-of-type-error ()
(loop-error "OF-TYPE keyword should be followed by a type spec."))
(defmacro cl::symbol-macrolet (vardefs &body body) (il:* il:\; "Edited 24-Mar-2024 21:46 by lmm")
(defmacro cl::symbol-macrolet (vardefs &body body) (il:* il:\; "Edited 3-Dec-2025 12:34 by mth")
(il:* il:\; "Edited 24-Mar-2024 21:46 by lmm")
(il:* il:|;;| "")
`(progn ,@(il:subpair (cons 'setq (mapcar vardefs #'car))
(cons 'setf (mapcar vardefs #'cadr))
`(progn ,@(il:subpair (cons 'setq (mapcar #'car vardefs))
(cons 'setf (mapcar #'cadr vardefs))
body)))
(defun type-spec? ()
@@ -1426,56 +1427,56 @@
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.")
(il:declare\: il:dontcopy
(il:filemap (nil (6777 6862 (%keyword 6777 . 6862)) (6864 7047 (%list 6864 . 7047)) (7049 8306 (
accumulate-in-list 7049 . 8306)) (8308 9988 (accumulation-clause 8308 . 9988)) (9990 10224 (
accumulator-kind 9990 . 10224)) (10226 12115 (accumulator-spec 10226 . 12115)) (12117 12586 (
along-with 12117 . 12586)) (12588 13080 (always-never-thereis-clause 12588 . 13080)) (13082 13441 (
ambiguous-loop-result-error 13082 . 13441)) (13443 13658 (append-context 13443 . 13658)) (13737 14114
(bindings 13737 . 14114)) (14116 14456 (bound-variables 14116 . 14456)) (14458 14548 (by-step-fun
14458 . 14548)) (14550 14656 (car-type 14550 . 14656)) (14658 14764 (cdr-type 14658 . 14764)) (14766
15163 (check-multiple-bindings 14766 . 15163)) (15165 15385 (cl-external-p 15165 . 15385)) (15387
15516 (clause* 15387 . 15516)) (15518 15918 (clause1 15518 . 15918)) (15920 16077 (compound-forms*
15920 . 16077)) (16079 16203 (compound-forms+ 16079 . 16203)) (16205 17463 (conditional-clause 16205
. 17463)) (17465 18176 (constant-bindings 17465 . 18176)) (18178 18549 (constant-function-p 18178 .
18549)) (18551 18745 (constant-vector 18551 . 18745)) (18747 18838 (constant-vector-p 18747 . 18838))
(18840 19032 (d-var-spec-p 18840 . 19032)) (19034 19264 (d-var-spec1 19034 . 19264)) (19266 19591 (
d-var-type-spec 19266 . 19591)) (19593 20153 (declarations 19593 . 20153)) (20155 20265 (
default-binding 20155 . 20265)) (20267 20880 (default-bindings 20267 . 20880)) (20882 21530 (
default-type 20882 . 21530)) (21532 22302 (default-value 21532 . 22302)) (22304 23794 (
destructuring-multiple-value-bind 22304 . 23794)) (23796 25081 (destructuring-multiple-value-setq
23796 . 25081)) (25083 25610 (dispatch-for-as-subclause 25083 . 25610)) (25612 25681 (do-clause 25612
. 25681)) (25683 25859 (empty-p 25683 . 25859)) (25861 26135 (enumerate 25861 . 26135)) (26137 27863
(extended-loop 26137 . 27863)) (27865 28036 (fill-in 27865 . 28036)) (28038 28115 (finally-clause
28038 . 28115)) (28117 28235 (for 28117 . 28235)) (28237 29593 (for-as-across-subclause 28237 . 29593)
) (29595 30517 (for-as-arithmetic-possible-prepositions 29595 . 30517)) (30519 31235 (
for-as-arithmetic-step-and-test-functions 30519 . 31235)) (31237 33182 (for-as-arithmetic-subclause
31237 . 33182)) (33184 33634 (for-as-being-subclause 33184 . 33634)) (33636 34852 (for-as-clause 33636
. 34852)) (34854 36382 (for-as-equals-then-subclause 34854 . 36382)) (36384 36662 (for-as-fill-in
36384 . 36662)) (36664 38630 (for-as-hash-subclause 36664 . 38630)) (38632 38878 (
for-as-in-list-subclause 38632 . 38878)) (38880 40373 (for-as-on-list-subclause 38880 . 40373)) (40375
42077 (for-as-package-subclause 40375 . 42077)) (42079 42310 (for-as-parallel-p 42079 . 42310)) (
42312 42460 (form-or-it 42312 . 42460)) (42462 42581 (form1 42462 . 42581)) (42583 42683 (
gensym-ignorable 42583 . 42683)) (42685 42796 (globally-special-p 42685 . 42796)) (42798 42977 (
hash-d-var-spec 42798 . 42977)) (42979 43060 (initially-clause 42979 . 43060)) (43062 43219 (
invalid-accumulator-combination-error 43062 . 43219)) (43221 43838 (keyword1 43221 . 43838)) (43840
44310 (keyword? 43840 . 44310)) (44312 44421 (let-form 44312 . 44421)) (44423 44577 (loop-error 44423
. 44577)) (44579 44770 (loop-finish-test-forms 44579 . 44770)) (44772 44924 (loop-warn 44772 . 44924)
) (44926 45130 (lp 44926 . 45130)) (45132 45569 (main-clause* 45132 . 45569)) (45571 45667 (mapappend
45571 . 45667)) (45669 46199 (multiple-value-list-argument-form 45669 . 46199)) (46201 46594 (
multiple-value-list-form-p 46201 . 46594)) (46596 46934 (name-clause? 46596 . 46934)) (46936 47215 (
one 46936 . 47215)) (47217 48862 (ordinary-bindings 47217 . 48862)) (48864 49081 (preposition1 48864
. 49081)) (49083 49284 (preposition? 49083 . 49284)) (49286 49446 (psetq-forms 49286 . 49446)) (49448
49628 (quoted-form-p 49448 . 49628)) (49630 49885 (quoted-object 49630 . 49885)) (49887 50691 (
reduce-redundant-code 49887 . 50691)) (50693 50922 (repeat-clause 50693 . 50922)) (50924 51014 (
return-clause 50924 . 51014)) (51016 51851 (selectable-clause 51016 . 51851)) (51853 52004 (
simple-loop 51853 . 52004)) (52006 52084 (simple-var-p 52006 . 52084)) (52086 52270 (simple-var1 52086
. 52270)) (52272 52379 (stray-of-type-error 52272 . 52379)) (52381 52666 (cl::symbol-macrolet 52381
. 52666)) (52668 53102 (type-spec? 52668 . 53102)) (53104 53170 (until-clause 53104 . 53170)) (53172
53753 (using-other-var 53172 . 53753)) (53755 53949 (variable-clause* 53755 . 53949)) (53951 54055 (
while-clause 53951 . 54055)) (54057 54236 (with 54057 . 54236)) (54238 54683 (with-accumulators 54238
. 54683)) (54685 54935 (with-binding-forms 54685 . 54935)) (54937 56168 (with-clause 54937 . 56168))
(56170 56429 (with-iterator-forms 56170 . 56429)) (56431 57578 (with-list-accumulator 56431 . 57578))
(57580 58017 (with-loop-context 57580 . 58017)) (58019 59257 (with-numeric-accumulator 58019 . 59257))
(59259 59780 (with-temporaries 59259 . 59780)) (59782 60062 (zero 59782 . 60062)) (60064 60197 (loop
60064 . 60197)))))
(il:filemap (nil (6770 6855 (%keyword 6770 . 6855)) (6857 7040 (%list 6857 . 7040)) (7042 8299 (
accumulate-in-list 7042 . 8299)) (8301 9981 (accumulation-clause 8301 . 9981)) (9983 10217 (
accumulator-kind 9983 . 10217)) (10219 12108 (accumulator-spec 10219 . 12108)) (12110 12579 (
along-with 12110 . 12579)) (12581 13073 (always-never-thereis-clause 12581 . 13073)) (13075 13434 (
ambiguous-loop-result-error 13075 . 13434)) (13436 13651 (append-context 13436 . 13651)) (13730 14107
(bindings 13730 . 14107)) (14109 14449 (bound-variables 14109 . 14449)) (14451 14541 (by-step-fun
14451 . 14541)) (14543 14649 (car-type 14543 . 14649)) (14651 14757 (cdr-type 14651 . 14757)) (14759
15156 (check-multiple-bindings 14759 . 15156)) (15158 15378 (cl-external-p 15158 . 15378)) (15380
15509 (clause* 15380 . 15509)) (15511 15911 (clause1 15511 . 15911)) (15913 16070 (compound-forms*
15913 . 16070)) (16072 16196 (compound-forms+ 16072 . 16196)) (16198 17456 (conditional-clause 16198
. 17456)) (17458 18169 (constant-bindings 17458 . 18169)) (18171 18542 (constant-function-p 18171 .
18542)) (18544 18738 (constant-vector 18544 . 18738)) (18740 18831 (constant-vector-p 18740 . 18831))
(18833 19025 (d-var-spec-p 18833 . 19025)) (19027 19257 (d-var-spec1 19027 . 19257)) (19259 19584 (
d-var-type-spec 19259 . 19584)) (19586 20146 (declarations 19586 . 20146)) (20148 20258 (
default-binding 20148 . 20258)) (20260 20873 (default-bindings 20260 . 20873)) (20875 21523 (
default-type 20875 . 21523)) (21525 22295 (default-value 21525 . 22295)) (22297 23787 (
destructuring-multiple-value-bind 22297 . 23787)) (23789 25074 (destructuring-multiple-value-setq
23789 . 25074)) (25076 25603 (dispatch-for-as-subclause 25076 . 25603)) (25605 25674 (do-clause 25605
. 25674)) (25676 25852 (empty-p 25676 . 25852)) (25854 26128 (enumerate 25854 . 26128)) (26130 27856
(extended-loop 26130 . 27856)) (27858 28029 (fill-in 27858 . 28029)) (28031 28108 (finally-clause
28031 . 28108)) (28110 28228 (for 28110 . 28228)) (28230 29586 (for-as-across-subclause 28230 . 29586)
) (29588 30510 (for-as-arithmetic-possible-prepositions 29588 . 30510)) (30512 31228 (
for-as-arithmetic-step-and-test-functions 30512 . 31228)) (31230 33175 (for-as-arithmetic-subclause
31230 . 33175)) (33177 33627 (for-as-being-subclause 33177 . 33627)) (33629 34845 (for-as-clause 33629
. 34845)) (34847 36375 (for-as-equals-then-subclause 34847 . 36375)) (36377 36655 (for-as-fill-in
36377 . 36655)) (36657 38623 (for-as-hash-subclause 36657 . 38623)) (38625 38871 (
for-as-in-list-subclause 38625 . 38871)) (38873 40366 (for-as-on-list-subclause 38873 . 40366)) (40368
42070 (for-as-package-subclause 40368 . 42070)) (42072 42303 (for-as-parallel-p 42072 . 42303)) (
42305 42453 (form-or-it 42305 . 42453)) (42455 42574 (form1 42455 . 42574)) (42576 42676 (
gensym-ignorable 42576 . 42676)) (42678 42789 (globally-special-p 42678 . 42789)) (42791 42970 (
hash-d-var-spec 42791 . 42970)) (42972 43053 (initially-clause 42972 . 43053)) (43055 43212 (
invalid-accumulator-combination-error 43055 . 43212)) (43214 43831 (keyword1 43214 . 43831)) (43833
44303 (keyword? 43833 . 44303)) (44305 44414 (let-form 44305 . 44414)) (44416 44570 (loop-error 44416
. 44570)) (44572 44763 (loop-finish-test-forms 44572 . 44763)) (44765 44917 (loop-warn 44765 . 44917)
) (44919 45123 (lp 44919 . 45123)) (45125 45562 (main-clause* 45125 . 45562)) (45564 45660 (mapappend
45564 . 45660)) (45662 46192 (multiple-value-list-argument-form 45662 . 46192)) (46194 46587 (
multiple-value-list-form-p 46194 . 46587)) (46589 46927 (name-clause? 46589 . 46927)) (46929 47208 (
one 46929 . 47208)) (47210 48855 (ordinary-bindings 47210 . 48855)) (48857 49074 (preposition1 48857
. 49074)) (49076 49277 (preposition? 49076 . 49277)) (49279 49439 (psetq-forms 49279 . 49439)) (49441
49621 (quoted-form-p 49441 . 49621)) (49623 49878 (quoted-object 49623 . 49878)) (49880 50684 (
reduce-redundant-code 49880 . 50684)) (50686 50915 (repeat-clause 50686 . 50915)) (50917 51007 (
return-clause 50917 . 51007)) (51009 51844 (selectable-clause 51009 . 51844)) (51846 51997 (
simple-loop 51846 . 51997)) (51999 52077 (simple-var-p 51999 . 52077)) (52079 52263 (simple-var1 52079
. 52263)) (52265 52372 (stray-of-type-error 52265 . 52372)) (52374 52768 (cl::symbol-macrolet 52374
. 52768)) (52770 53204 (type-spec? 52770 . 53204)) (53206 53272 (until-clause 53206 . 53272)) (53274
53855 (using-other-var 53274 . 53855)) (53857 54051 (variable-clause* 53857 . 54051)) (54053 54157 (
while-clause 54053 . 54157)) (54159 54338 (with 54159 . 54338)) (54340 54785 (with-accumulators 54340
. 54785)) (54787 55037 (with-binding-forms 54787 . 55037)) (55039 56270 (with-clause 55039 . 56270))
(56272 56531 (with-iterator-forms 56272 . 56531)) (56533 57680 (with-list-accumulator 56533 . 57680))
(57682 58119 (with-loop-context 57682 . 58119)) (58121 59359 (with-numeric-accumulator 58121 . 59359))
(59361 59882 (with-temporaries 59361 . 59882)) (59884 60164 (zero 59884 . 60164)) (60166 60299 (loop
60166 . 60299)))))
il:stop

BIN
sources/XCL-LOOP.DFASL
View File

Binary file not shown.

33
sources/test01. Normal file
View File

@@ -0,0 +1,33 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Nov-2025 13:41:38" {DSK}<home>frank>il>medley>START-KINETIC.;2 1112
:EDIT-BY "FGH"
:CHANGES-TO (FNS START-KINETIC)
:PREVIOUS-DATE " 1-Nov-2025 13:21:22" {DSK}<home>frank>il>medley>START-KINETIC.;1)
(PRETTYCOMPRINT START-KINETICCOMS)
(RPAQQ START-KINETICCOMS ((FILES KINETIC)
(FNS START-KINETIC)
(P (START-KINETIC))))
(FILESLOAD KINETIC)
(DEFINEQ
(START-KINETIC
[LAMBDA NIL (* ; "Edited 1-Nov-2025 13:41 by FGH")
(* ; "Edited 1-Nov-2025 13:15 by FGH")
(ADD.PROCESS '(KINETIC (CREATEW (CREATEREGION (FIX (TIMES 0.25 SCREENWIDTH))
(FIX (TIMES 0.25 SCREENHEIGHT))
(FIX (TIMES 0.5 SCREENWIDTH))
(FIX (TIMES 0.5 SCREENHEIGHT])
)
(START-KINETIC)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (517 1068 (START-KINETIC 527 . 1066)))))
STOP

33
sources/test02. Normal file
View File

@@ -0,0 +1,33 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Nov-2025 13:41:38" {DSK}<home>frank>il>medley>START-KINETIC.;2 1112
:EDIT-BY "FGH"
:CHANGES-TO (FNS START-KINETIC)
:PREVIOUS-DATE " 1-Nov-2025 13:21:22" {DSK}<home>frank>il>medley>START-KINETIC.;1)
(PRETTYCOMPRINT START-KINETICCOMS)
(RPAQQ START-KINETICCOMS ((FILES KINETIC)
(FNS START-KINETIC)
(P (START-KINETIC))))
(FILESLOAD KINETIC)
(DEFINEQ
(START-KINETIC
[LAMBDA NIL (* ; "Edited 1-Nov-2025 13:41 by FGH")
(* ; "Edited 1-Nov-2025 13:15 by FGH")
(ADD.PROCESS '(KINETIC (CREATEW (CREATEREGION (FIX (TIMES 0.25 SCREENWIDTH))
(FIX (TIMES 0.25 SCREENHEIGHT))
(FIX (TIMES 0.5 SCREENWIDTH))
(FIX (TIMES 0.5 SCREENHEIGHT])
)
(START-KINETIC)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (517 1068 (START-KINETIC 527 . 1066)))))
STOP

33
sources/test02.txt Normal file
View File

@@ -0,0 +1,33 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Nov-2025 13:41:38" {DSK}<home>frank>il>medley>START-KINETIC.;2 1112
:EDIT-BY "FGH"
:CHANGES-TO (FNS START-KINETIC)
:PREVIOUS-DATE " 1-Nov-2025 13:21:22" {DSK}<home>frank>il>medley>START-KINETIC.;1)
(PRETTYCOMPRINT START-KINETICCOMS)
(RPAQQ START-KINETICCOMS ((FILES KINETIC)
(FNS START-KINETIC)
(P (START-KINETIC))))
(FILESLOAD KINETIC)
(DEFINEQ
(START-KINETIC
[LAMBDA NIL (* ; "Edited 1-Nov-2025 13:41 by FGH")
(* ; "Edited 1-Nov-2025 13:15 by FGH")
(ADD.PROCESS '(KINETIC (CREATEW (CREATEREGION (FIX (TIMES 0.25 SCREENWIDTH))
(FIX (TIMES 0.25 SCREENHEIGHT))
(FIX (TIMES 0.5 SCREENWIDTH))
(FIX (TIMES 0.5 SCREENHEIGHT])
)
(START-KINETIC)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (517 1068 (START-KINETIC 527 . 1066)))))
STOP

33
sources/test03 Normal file
View File

@@ -0,0 +1,33 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Nov-2025 13:41:38" {DSK}<home>frank>il>medley>START-KINETIC.;2 1112
:EDIT-BY "FGH"
:CHANGES-TO (FNS START-KINETIC)
:PREVIOUS-DATE " 1-Nov-2025 13:21:22" {DSK}<home>frank>il>medley>START-KINETIC.;1)
(PRETTYCOMPRINT START-KINETICCOMS)
(RPAQQ START-KINETICCOMS ((FILES KINETIC)
(FNS START-KINETIC)
(P (START-KINETIC))))
(FILESLOAD KINETIC)
(DEFINEQ
(START-KINETIC
[LAMBDA NIL (* ; "Edited 1-Nov-2025 13:41 by FGH")
(* ; "Edited 1-Nov-2025 13:15 by FGH")
(ADD.PROCESS '(KINETIC (CREATEW (CREATEREGION (FIX (TIMES 0.25 SCREENWIDTH))
(FIX (TIMES 0.25 SCREENHEIGHT))
(FIX (TIMES 0.5 SCREENWIDTH))
(FIX (TIMES 0.5 SCREENHEIGHT])
)
(START-KINETIC)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (517 1068 (START-KINETIC 527 . 1066)))))
STOP

33
sources/test03. Normal file
View File

@@ -0,0 +1,33 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Nov-2025 13:41:38" {DSK}<home>frank>il>medley>START-KINETIC.;2 1112
:EDIT-BY "FGH"
:CHANGES-TO (FNS START-KINETIC)
:PREVIOUS-DATE " 1-Nov-2025 13:21:22" {DSK}<home>frank>il>medley>START-KINETIC.;1)
(PRETTYCOMPRINT START-KINETICCOMS)
(RPAQQ START-KINETICCOMS ((FILES KINETIC)
(FNS START-KINETIC)
(P (START-KINETIC))))
(FILESLOAD KINETIC)
(DEFINEQ
(START-KINETIC
[LAMBDA NIL (* ; "Edited 1-Nov-2025 13:41 by FGH")
(* ; "Edited 1-Nov-2025 13:15 by FGH")
(ADD.PROCESS '(KINETIC (CREATEW (CREATEREGION (FIX (TIMES 0.25 SCREENWIDTH))
(FIX (TIMES 0.25 SCREENHEIGHT))
(FIX (TIMES 0.5 SCREENWIDTH))
(FIX (TIMES 0.5 SCREENHEIGHT])
)
(START-KINETIC)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (517 1068 (START-KINETIC 527 . 1066)))))
STOP