Compare commits
41 Commits
medley-220
...
medley-221
| Author | SHA1 | Date | |
|---|---|---|---|
|
d9c144d966 | ||
|
|
17dd03a358 | ||
|
382881a068 | ||
|
|
d0d952a10d | ||
|
|
d5d21397d4 | ||
|
|
7a4470ce8b | ||
|
|
32ff7b7649 | ||
|
|
096d860ac8 | ||
|
|
418b1df00d | ||
|
ba90344080 | ||
|
0eac6efb61 | ||
|
|
540aff091c | ||
|
|
3f244f6cd3 | ||
|
|
58557d383a | ||
|
|
882fbacf59 | ||
|
|
70ce516e0c | ||
|
|
fdb573c761 | ||
|
|
06368f95eb | ||
|
|
654ebc359c | ||
|
|
4e38802325 | ||
|
b43b63b287 | ||
|
|
016097e8bf | ||
|
99321e7951 | ||
|
|
8e4fc4ab74 | ||
|
|
c005cf86bf | ||
|
|
ecc2b22207 | ||
|
|
d0945f7a5f | ||
|
|
add65a9397 | ||
|
|
0474f924a4 | ||
|
|
a387094eab | ||
|
|
541a07e09b | ||
|
|
5ee5482dd2 | ||
|
|
095beef454 | ||
|
|
06a7356b00 | ||
|
|
147abac04c | ||
|
|
56a52af6b9 | ||
|
|
fad70d4947 | ||
|
|
f4c91ec419 | ||
|
|
f5e48847c9 | ||
|
|
b90bf65be9 | ||
|
|
d379bcc102 |
9
.gitattributes
vendored
Normal file
9
.gitattributes
vendored
Normal file
@@ -0,0 +1,9 @@
|
||||
# Denote all files that are truly binary and should not be modified.
|
||||
*.tedit binary
|
||||
*.lcom binary
|
||||
*.sketch binary
|
||||
*.dfasl binary
|
||||
*.TEDIT binary
|
||||
*.LCOM binary
|
||||
*.SKETCH binary
|
||||
*.DFASL binary
|
||||
1
.gitignore
vendored
1
.gitignore
vendored
@@ -36,3 +36,4 @@ core
|
||||
|
||||
# Mac OS detritus
|
||||
.DS_Store
|
||||
*.PS
|
||||
|
||||
2842
internal/COMPTEST
2842
internal/COMPTEST
File diff suppressed because it is too large
Load Diff
Binary file not shown.
10
internal/CONDITIONGRAPH.TXT
Normal file
10
internal/CONDITIONGRAPH.TXT
Normal file
@@ -0,0 +1,10 @@
|
||||
CONDITIONGRAPH
|
||||
|
||||
|
||||
Currently in internal rather than lispusers, this package shows a graph of "conditions" (Common Lisp error system).
|
||||
|
||||
(FILESLOAD CONDITIONGRAPH) to load it.
|
||||
|
||||
(GRAPH-CONDITIONS) will display a graph of conditions and their inheritance.
|
||||
|
||||
Other possible operations might be determinable by reading the source.
|
||||
BIN
internal/DO-TEST
BIN
internal/DO-TEST
Binary file not shown.
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
@@ -1 +0,0 @@
|
||||
Running DSKTEST
The Disk-file-system test utility
1. Load the file DSKTEST.DCOM from whichever directory & server it is stored on.
2. Type
(DSKTEST '{DSK}<LISPFILES>
|
||||
1493
internal/MACROTEST
1493
internal/MACROTEST
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,25 +1,17 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "17-Jul-2022 12:44:56" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;9| 15959
|
||||
(FILECREATED " 4-Aug-2022 09:50:04" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;2| 10212
|
||||
|
||||
:CHANGES-TO (FNS HCFILES)
|
||||
:CHANGES-TO (VARS MEDLEY-UTILSCOMS)
|
||||
|
||||
:PREVIOUS-DATE "16-Jul-2022 22:08:34" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;8|)
|
||||
:PREVIOUS-DATE "17-Jul-2022 12:44:56" |{DSK}<home>larry>medley>internal>MEDLEY-UTILS.;1|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
|
||||
(RPAQQ MEDLEY-UTILSCOMS
|
||||
((FNS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES PICK)
|
||||
(VARS MEDLEY-FIX-DIRS OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
|
||||
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)
|
||||
|
||||
(* |;;| "hardcopy files")
|
||||
|
||||
(FNS HCFILES BADFILE)
|
||||
(INITVARS (HCFILES)
|
||||
(BADFILES))
|
||||
(COMMANDS "pick")))
|
||||
(RPAQQ MEDLEY-UTILSCOMS ((FNS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
|
||||
(VARS MEDLEY-FIX-DIRS OKSOURCES OKLIBRARY OKLISPUSERS OKINTERNAL)
|
||||
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)))
|
||||
(DEFINEQ
|
||||
|
||||
(GATHER-INFO
|
||||
@@ -130,24 +122,6 @@
|
||||
(MEDLEY-FIX-DATES
|
||||
(LAMBDA (DIRS) (* \; "Edited 28-Jan-2021 12:15 by larry")
|
||||
(|for| X |in| (OR DIRS MEDLEY-FIX-DIRS) |join| (FIX-DIRECTORY-DATES (MEDLEYDIR (PRINT X T))))))
|
||||
|
||||
(PICK
|
||||
(LAMBDA (TYPE CHOICES) (* \; "Edited 25-Jun-2022 16:58 by larry")
|
||||
(SELECTQ (MKATOM (U-CASE (MKSTRING TYPE)))
|
||||
(NIL (PICK (PICK 'ONEOF '(FILE ISSUE PROJECT))))
|
||||
(ISSUE (LET ((ISSUE (PICK 'ONEOF (OR CHOICES (GIT-COMMAND
|
||||
"gh issue list -L 5000 -R interlisp/medley | sed 's/\\([0-9]*\\).*/\\1/'"
|
||||
))))
|
||||
(STR (OPENTEXTSTREAM)))
|
||||
(|for| S |in| (GIT-COMMAND (CL:FORMAT NIL "gh issue view ~a" ISSUE))
|
||||
|do| (CL:FORMAT STR "~a~&" S)
|
||||
|finally| (TEDIT STR NIL NIL `(READONLY T TITLE ,(CL:FORMAT NIL "Issue #~a"
|
||||
ISSUE))))))
|
||||
(DIR (PICK 'ONEOF '(LISPUSERS LIBRARY DOCTOOLS SOURCES INTERNAL)))
|
||||
(FILE (PICK 'ONEOF (DIRECTORY (MEDLEYDIR (PICK 'DIR)))))
|
||||
(PROJECT (PICK 'ONEOF '(CLOS ROOMS LOOPS NOTECARDS ONLINE TEST GITBOOK COMMUNITY ENVOS)))
|
||||
(ONEOF (CAR (NTH CHOICES (RAND 1 (LENGTH CHOICES)))))
|
||||
(HELP TYPE "Unknown type"))))
|
||||
)
|
||||
|
||||
(RPAQQ MEDLEY-FIX-DIRS ("sources" "library" "lispusers" "internal" "greetfiles" "doctools"))
|
||||
@@ -195,104 +169,8 @@
|
||||
(RENAMEFILE HASHFILE (MEDLEYDIR "tmp" "whereis.hash" T))
|
||||
(DRIBBLE))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* |;;| "hardcopy files")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(HCFILES
|
||||
(LAMBDA (TFILE DEST REDOFLG TOPDIRLEN) (* \; "Edited 17-Jul-2022 12:44 by larry")
|
||||
(* \; "Edited 21-Jun-2022 22:59 by larry")
|
||||
(* \; "Edited 31-May-2022 09:31 by larry")
|
||||
(* \; "Edited 20-Feb-2022 12:16 by larry")
|
||||
(* \; "Edited 21-Aug-2021 20:56 by larry")
|
||||
(DECLARE (SPECVARS TFILE))
|
||||
(|if| (NULL TFILE)
|
||||
|then| (SETQ TFILE MEDLEYDIR))
|
||||
(COND
|
||||
((DIRECTORYNAMEP TFILE)
|
||||
|
||||
(* |;;| "canonicalize")
|
||||
|
||||
(SETQ TFILE (DIRECTORYNAME TFILE))
|
||||
(OR TOPDIRLEN (SETQ TOPDIRLEN (CL:LENGTH (FILENAMEFIELD.STRING TFILE 'DIRECTORY))))
|
||||
(CL:UNLESS DEST
|
||||
(|ShellCommand| (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR")
|
||||
"/tmp/psfiles/"))
|
||||
(SETQ DEST (MEDLEYDIR "tmp/psfiles" NIL T T)))
|
||||
|
||||
(* |;;| "first deal with files in this directory")
|
||||
|
||||
(FOR EXT IN '("TED*" "SKETCH" "T*XT")
|
||||
DO (|for| X |in| (DIRECTORY (CONCAT TFILE "*." EXT ";*"))
|
||||
|do| (HCFILES X DEST REDOFLG TOPDIRLEN)))
|
||||
|
||||
(* |;;| " then deal with subdirs ")
|
||||
|
||||
(|for| X |in| (DIRECTORY (CONCAT TFILE "*"))
|
||||
|when| (|for| SKIP |in| '(">." ">dinfo>") |always| (NOT (STRPOS SKIP (L-CASE X))))
|
||||
|when| (DIRECTORYNAMEP X) |do| (HCFILES X DEST REDOFLG TOPDIRLEN)))
|
||||
((SETQ TFILE (INFILEP TFILE))
|
||||
(LET* ((TF (UNPACKFILENAME.STRING TFILE))
|
||||
(NAME (LISTGET TF 'NAME))
|
||||
(DIR (LISTGET TF 'DIRECTORY))
|
||||
(PSFILE (PACKFILENAME.STRING
|
||||
'EXTENSION
|
||||
(|if| (EQ REDOFLG 'IP)
|
||||
|then| "IP"
|
||||
|else| "PS")
|
||||
'NAME
|
||||
(|if| (EQ DEST T)
|
||||
|then| (* \; "with the tedit file")
|
||||
NAME
|
||||
|else| (CONCAT (PACK (SUBST '- '> (UNPACK (SUBSTRING DIR (IPLUS 2 TOPDIRLEN
|
||||
)
|
||||
-1))))
|
||||
"-" NAME))
|
||||
'HOST
|
||||
(LISTGET TF 'HOST)
|
||||
'DIRECTORY
|
||||
(|if| (EQ DEST T)
|
||||
|then| DIR
|
||||
|else| DEST)))
|
||||
(TEXTSTREAM))
|
||||
(|if| (AND (NOT REDOFLG)
|
||||
(INFILEP PSFILE))
|
||||
|then| (* \; " do nothing")
|
||||
(PRINTOUT T PSFILE " already there" T)
|
||||
|elseif| (EQ REDOFLG 'TEST)
|
||||
|then| (PRINTOUT T TFILE "-> " PSFILE T)
|
||||
(CLOSEF (OPENTEXTSTREAM TFILE))
|
||||
ELSEIF (MEMBER TFILE BADFILES)
|
||||
THEN (PRINTOUT T "Skipping " TFILE " on BADFILES")
|
||||
|else| (PRINTOUT T "Converting " TFILE " to " PSFILE "...")
|
||||
(TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM TFILE))
|
||||
PSFILE T NIL NIL NIL (|if| (EQ REDOFLG 'IP)
|
||||
|then| 'INTERPRESS
|
||||
|else| 'POSTSCRIPT))
|
||||
(|printout| T " DONE" T)
|
||||
(CLOSEF? TEXTSTREAM))))
|
||||
(T (PRINTOUT T "no such file " T)))))
|
||||
|
||||
(BADFILE
|
||||
(LAMBDA NIL (* \; "Edited 22-Jun-2022 09:40 by larry")
|
||||
(PUSHNEW BADFILES TFILE)
|
||||
(LET ((STR (OPENSTREAM "BADFILES.TXT" 'APPEND)))
|
||||
(SETFILEPTR STR -1)
|
||||
(PRINT TFILE STR)
|
||||
(CLOSEF STR))
|
||||
(RETFROM 'HCFILES)))
|
||||
)
|
||||
|
||||
(RPAQ? HCFILES )
|
||||
|
||||
(RPAQ? BADFILES )
|
||||
|
||||
(DEFCOMMAND "pick" (FIRST . REST) (PICK FIRST REST))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (727 8702 (GATHER-INFO 737 . 6147) (MAKE-FULLER-DB 6149 . 6839) (MEDLEY-FIX-LINKS 6841
|
||||
. 7238) (MEDLEY-FIX-DATES 7240 . 7482) (PICK 7484 . 8700)) (9741 11534 (MAKE-EXPORTS-ALL 9751 . 10710
|
||||
) (MAKE-WHEREIS-HASH 10712 . 11532)) (11569 15829 (HCFILES 11579 . 15514) (BADFILE 15516 . 15827)))))
|
||||
(FILEMAP (NIL (600 7357 (GATHER-INFO 610 . 6020) (MAKE-FULLER-DB 6022 . 6712) (MEDLEY-FIX-LINKS 6714
|
||||
. 7111) (MEDLEY-FIX-DATES 7113 . 7355)) (8396 10189 (MAKE-EXPORTS-ALL 8406 . 9365) (MAKE-WHEREIS-HASH
|
||||
9367 . 10187)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,105 +0,0 @@
|
||||
(FILECREATED "24-Mar-86 15:18:14" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;9 4308
|
||||
|
||||
changes to: (FNS STARTTEST STOPTEST KILLTEST)
|
||||
(VARS FLOPPYTESTERCOMS)
|
||||
|
||||
previous date: "20-Mar-86 21:06:46" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;5)
|
||||
|
||||
|
||||
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
|
||||
|
||||
(PRETTYCOMPRINT FLOPPYTESTERCOMS)
|
||||
|
||||
(RPAQQ FLOPPYTESTERCOMS ((* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
|
||||
(P (LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM)))
|
||||
(INITVARS (ALLOCATIONSW NIL))
|
||||
(FNS STARTTEST STOPTEST KILLTEST BLTALLOCS BLTALLOC)))
|
||||
(* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
|
||||
|
||||
(LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM))
|
||||
|
||||
(RPAQ? ALLOCATIONSW NIL)
|
||||
(DEFINEQ
|
||||
|
||||
(STARTTEST
|
||||
(LAMBDA (N) (* kbr: "24-Mar-86 15:15")
|
||||
(SETQ STARTTIME (GDATE))
|
||||
(CNDIR (QUOTE {FLOPPY}))
|
||||
(FLOPPY.FORMAT (QUOTE TEST))
|
||||
(DIRECTORY (QUOTE {FLOPPY}*))
|
||||
(BLTALLOCS)
|
||||
(for I from 1 to N do (DOFILEBANGER (PACK* (QUOTE {FLOPPY})
|
||||
(QUOTE TESTFILE)
|
||||
I)
|
||||
(RAND 10 30)))))
|
||||
|
||||
(STOPTEST
|
||||
(LAMBDA NIL (* kbr: "24-Mar-86 15:16")
|
||||
(SETQ STOPTIME (GDATE))
|
||||
(for P in FILEBANGERS when (NOT (EQ P (THIS.PROCESS))) do (SUSPEND.PROCESS P))))
|
||||
|
||||
(KILLTEST
|
||||
(LAMBDA NIL (* kbr: "22-Mar-86 17:18")
|
||||
(for P in FILEBANGERS do (DEL.PROCESS P))
|
||||
(SETQ FILEBANGERS NIL)))
|
||||
|
||||
(BLTALLOCS
|
||||
[LAMBDA NIL (* kbr: "18-Nov-85 12:32")
|
||||
(* Debugging fn. Puts up a window representation of
|
||||
allocations on floppy. *)
|
||||
(PROG (PIXELS XLENGTH YLENGTH)
|
||||
(SETQ PIXELS 5)
|
||||
(SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
|
||||
(SETQ YLENGTH \FLOPPY.CYLINDERS)
|
||||
[COND
|
||||
((NULL ALLOCATIONSW)
|
||||
(SETQ ALLOCATIONSW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (ITIMES PIXELS
|
||||
XLENGTH))
|
||||
(HEIGHTIFWINDOW (ITIMES PIXELS
|
||||
YLENGTH)
|
||||
T)
|
||||
NIL NIL NIL
|
||||
"Position FLOPPY ALLOCATIONS window")
|
||||
"FLOPPY ALLOCATIONS"))
|
||||
(UNADVISE (QUOTE \PFLOPPY.ALLOCATE))
|
||||
(ADVISE (QUOTE \PFLOPPY.ALLOCATE)
|
||||
(QUOTE AFTER)
|
||||
(QUOTE (COND (!VALUE (BLTALLOC !VALUE]
|
||||
(BITBLT NIL NIL NIL ALLOCATIONSW NIL NIL NIL NIL (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
WHITESHADE)
|
||||
(for Y from 0 to (SUB1 YLENGTH) do (for X from 0 to (SUB1 XLENGTH)
|
||||
do (BITMAPBIT ALLOCATIONSW
|
||||
(ITIMES PIXELS X)
|
||||
(ITIMES PIXELS Y)
|
||||
1)))
|
||||
(for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV)
|
||||
when [NOT (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
|
||||
(QUOTE (FREE]
|
||||
do (BLTALLOC PFALLOC])
|
||||
|
||||
(BLTALLOC
|
||||
[LAMBDA (PFALLOC) (* kbr: "18-Nov-85 12:21")
|
||||
(PROG (SHADE OPSHADE LEFT BOTTOM PIXELS XLENGTH)
|
||||
(SETQ PIXELS 5)
|
||||
(SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
|
||||
(SETQ SHADE (COND
|
||||
((EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
|
||||
(QUOTE (FREE)))
|
||||
WHITESHADE)
|
||||
(T BLACKSHADE)))
|
||||
(SETQ OPSHADE (IDIFFERENCE BLACKSHADE SHADE))
|
||||
(for I from (fetch (PFALLOC START) of PFALLOC) to (fetch (PFALLOC END)
|
||||
of PFALLOC)
|
||||
do (SETQ LEFT (ITIMES PIXELS (IREMAINDER (SUB1 I)
|
||||
XLENGTH)))
|
||||
(SETQ BOTTOM (ITIMES PIXELS (IQUOTIENT (SUB1 I)
|
||||
XLENGTH)))
|
||||
(BLTSHADE SHADE ALLOCATIONSW LEFT BOTTOM PIXELS PIXELS (QUOTE REPLACE))
|
||||
(BLTSHADE OPSHADE ALLOCATIONSW LEFT BOTTOM 1 1 (QUOTE REPLACE])
|
||||
)
|
||||
(PUTPROPS FLOPPYTESTER COPYRIGHT ("Xerox Corporation" 1985 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (745 4220 (STARTTEST 755 . 1203) (STOPTEST 1205 . 1463) (KILLTEST 1465 . 1665) (
|
||||
BLTALLOCS 1667 . 3253) (BLTALLOC 3255 . 4218)))))
|
||||
STOP
|
||||
@@ -1,242 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "26-Jun-90 19:15:35" |{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;2| 9419
|
||||
|
||||
|changes| |to:| (VARS RS232TESTCOMS)
|
||||
|
||||
|previous| |date:| "20-Feb-87 00:10:14"
|
||||
|{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT RS232TESTCOMS)
|
||||
|
||||
(RPAQQ RS232TESTCOMS
|
||||
((FNS RSTEST TESTCLEANUP XMITTEST)
|
||||
|
||||
(* |;;|
|
||||
"Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
|
||||
|
||||
(FNS RS232.TEST RS232.MICROTEST RS232.QUICKTEST RS232.MENU RS232TMENU.SELFN)
|
||||
(VARS RS232.TEST.MENU.ITEMS)
|
||||
|
||||
(* |;;|
|
||||
"Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
|
||||
|
||||
(FNS TTY.TEST TTY.MICROTEST TTY.QUICKTEST TTY.MENU TTYTMENU.SELFN)))
|
||||
(DEFINEQ
|
||||
|
||||
(rstest
|
||||
(lambda nil (* \; "Edited 14-Jan-87 16:00 by jds")
|
||||
(let (oo)
|
||||
(resetlst (resetsave (setq oo (openstream '{rs232} 'output))
|
||||
'closef?)
|
||||
(|for| i |from| 1 |do| (printout oo "Line " i
|
||||
": 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
|
||||
\
|
||||
")
|
||||
(printout t "Line " i t))))))
|
||||
|
||||
(testcleanup
|
||||
(lambda nil (* \; "Edited 16-Jan-87 09:51 by jds")
|
||||
|
||||
(* |;;| "Close the streams used by the rs232 test.")
|
||||
|
||||
(and (boundp 'out)
|
||||
out
|
||||
(closef? out))
|
||||
(and (boundp in)
|
||||
in
|
||||
(closef? in))))
|
||||
|
||||
(XMITTEST
|
||||
(LAMBDA (BAUDRATE XONXOFF?) (* \; "Edited 19-Feb-87 20:59 by jds")
|
||||
|
||||
(* |;;| "Set up the rs232 port at BAUDRATE with XOn-XOff flow control if XONXOFF? is T. Then print forever, lines of text. Show an indication on the screen for each line, so the user can tell if flow control has shut things off.")
|
||||
|
||||
(RS232C.INIT BAUDRATE 8 'NONE 1 (COND
|
||||
(XONXOFF? 'XONXOFF)
|
||||
(T 'NONE)))
|
||||
(SETQ OUT (OPENSTREAM '{RS232} 'OUTPUT))
|
||||
(SETQ IN (OPENSTREAM '{RS232} 'INPUT))
|
||||
(ERSETQ (FOR I FROM 1 DO (PRINTOUT OUT "Line " I ": 0 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
|
||||
\
|
||||
")
|
||||
(|printout| T "Line " I T)))
|
||||
(CLOSEF? OUT)
|
||||
(CLOSEF? IN)))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* |;;| "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(rs232.test
|
||||
(lambda nil (* \; "Edited 19-Feb-87 22:43 by jds")
|
||||
|
||||
(* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")
|
||||
|
||||
(printout t t t "Starting RS-232 port test." t
|
||||
"Make sure the line monitor is attached to the RS-232 port, "
|
||||
"and its cable goes to the DCE socket on the monitor." t)
|
||||
(mouseconfirm)
|
||||
(printout t "Set the line monitor for: " t)
|
||||
(|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
|
||||
|do| (|for| stopbits |in| '(1 1.5 2)
|
||||
|do| (rs232.microtest 9600 bits parity stopbits))))))
|
||||
|
||||
(rs232.microtest
|
||||
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:37 by jds")
|
||||
|
||||
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
|
||||
|
||||
(printout t bits "bits, " (cond
|
||||
((eq parity 'none)
|
||||
"NO")
|
||||
(t parity))
|
||||
" parity, " stopbits " stop bits..." t)
|
||||
(mouseconfirm)
|
||||
(rs232.quicktest speed bits parity stopbits)))
|
||||
|
||||
(rs232.quicktest
|
||||
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:38 by jds")
|
||||
|
||||
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
|
||||
|
||||
(rs232c.init speed bits parity stopbits 'none)
|
||||
(let ((out (openstream '{rs232} 'output)))
|
||||
(prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
|
||||
out)
|
||||
(closef out))))
|
||||
|
||||
(rs232.menu
|
||||
(lambda nil (* \; "Edited 19-Feb-87 22:45 by jds")
|
||||
(let ((ww (addmenu (|create| menu
|
||||
menucolumns _ 4
|
||||
items _ rs232.test.menu.items
|
||||
whenselectedfn _ (function rs232tmenu.selfn)))))
|
||||
(windowprop ww 'title "RS-232 Tests"))))
|
||||
|
||||
(rs232tmenu.selfn
|
||||
(lambda (item menu key) (* \; "Edited 19-Feb-87 22:57 by jds")
|
||||
|
||||
(* |;;| "Called from the RS-232 test menu")
|
||||
|
||||
(let* ((info (cadr item))
|
||||
(bits (car info))
|
||||
(parity (cadr info))
|
||||
(stopbits (caddr info)))
|
||||
(rs232.quicktest 9600 bits parity stopbits))))
|
||||
)
|
||||
|
||||
(RPAQQ RS232.TEST.MENU.ITEMS
|
||||
((|5/N/1| (5 NONE 1))
|
||||
(|6/N/1| (6 NONE 1))
|
||||
(|7/N/1| (7 NONE 1))
|
||||
(|8/N/1| (8 NONE 1))
|
||||
(|5/N/1.5| (5 NONE 1.5))
|
||||
(|6/N/1.5| (6 NONE 1.5))
|
||||
(|7/N/1.5| (7 NONE 1.5))
|
||||
(|8/N/1.5| (8 NONE 1.5))
|
||||
(|5/N/2| (5 NONE 2))
|
||||
(|6/N/2| (6 NONE 2))
|
||||
(|7/N/2| (7 NONE 2))
|
||||
(|8/N/2| (8 NONE 2))
|
||||
(|5/O/1| (5 ODD 1))
|
||||
(|6/O/1| (6 ODD 1))
|
||||
(|7/O/1| (7 ODD 1))
|
||||
(|8/O/1| (8 ODD 1))
|
||||
(|5/O/1.5| (5 ODD 1.5))
|
||||
(|6/O/1.5| (6 ODD 1.5))
|
||||
(|7/O/1.5| (7 ODD 1.5))
|
||||
(|8/O/1.5| (8 ODD 1.5))
|
||||
(|5/O/2| (5 ODD 2))
|
||||
(|6/O/2| (6 ODD 2))
|
||||
(|7/O/2| (7 ODD 2))
|
||||
(|8/O/2| (8 ODD 2))
|
||||
(|5/E/1| (5 EVEN 1))
|
||||
(|6/E/1| (6 EVEN 1))
|
||||
(|7/E/1| (7 EVEN 1))
|
||||
(|8/E/1| (8 EVEN 1))
|
||||
(|5/E/1.5| (5 EVEN 1.5))
|
||||
(|6/E/1.5| (6 EVEN 1.5))
|
||||
(|7/E/1.5| (7 EVEN 1.5))
|
||||
(|8/E/1.5| (8 EVEN 1.5))
|
||||
(|5/E/2| (5 EVEN 2))
|
||||
(|6/E/2| (6 EVEN 2))
|
||||
(|7/E/2| (7 EVEN 2))
|
||||
(|8/E/2| (8 EVEN 2))))
|
||||
|
||||
|
||||
|
||||
(* |;;|
|
||||
"Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(tty.test
|
||||
(lambda nil (* \; "Edited 19-Feb-87 22:42 by jds")
|
||||
|
||||
(* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")
|
||||
|
||||
(printout t t t "Starting TTY port test." t
|
||||
"Make sure the line monitor is attached to the TTY port, "
|
||||
"and its cable goes to the DTE socket on the monitor." t)
|
||||
(mouseconfirm)
|
||||
(printout t "Set the line monitor for: " t)
|
||||
(|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
|
||||
|do| (|for| stopbits |in| '(1 1.5 2)
|
||||
|do| (tty.microtest 9600 bits parity stopbits))))))
|
||||
|
||||
(tty.microtest
|
||||
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:41 by jds")
|
||||
|
||||
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
|
||||
|
||||
(printout t bits "bits, " (cond
|
||||
((eq parity 'none)
|
||||
"NO")
|
||||
(t parity))
|
||||
" parity, " stopbits " stop bits..." t)
|
||||
(mouseconfirm)
|
||||
(tty.init speed bits parity stopbits)))
|
||||
|
||||
(tty.quicktest
|
||||
(lambda (speed bits parity stopbits) (* \; "Edited 19-Feb-87 22:40 by jds")
|
||||
|
||||
(* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")
|
||||
|
||||
(tty.init speed bits parity stopbits 'none)
|
||||
(let ((out (openstream '{tty} 'output)))
|
||||
(prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
|
||||
out)
|
||||
(closef out))))
|
||||
|
||||
(tty.menu
|
||||
(lambda nil (* \; "Edited 19-Feb-87 22:57 by jds")
|
||||
(let ((ww (addmenu (|create| menu
|
||||
menucolumns _ 4
|
||||
items _ rs232.test.menu.items
|
||||
whenselectedfn _ (function ttytmenu.selfn)))))
|
||||
(windowprop ww 'title "TTY Tests"))))
|
||||
|
||||
(ttytmenu.selfn
|
||||
(lambda (item menu key) (* \; "Edited 19-Feb-87 22:59 by jds")
|
||||
|
||||
(* |;;| "Called from the RS-232 test menu")
|
||||
|
||||
(let* ((info (cadr item))
|
||||
(bits (car info))
|
||||
(parity (cadr info))
|
||||
(stopbits (caddr info)))
|
||||
(tty.quicktest 9600 bits parity stopbits))))
|
||||
)
|
||||
(PUTPROPS RS232TEST COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (979 2623 (RSTEST 989 . 1466) (TESTCLEANUP 1468 . 1789) (XMITTEST 1791 . 2621)) (2732
|
||||
5433 (RS232.TEST 2742 . 3570) (RS232.MICROTEST 3572 . 4151) (RS232.QUICKTEST 4153 . 4640) (RS232.MENU
|
||||
4642 . 5042) (RS232TMENU.SELFN 5044 . 5431)) (6665 9325 (TTY.TEST 6675 . 7493) (TTY.MICROTEST 7495 .
|
||||
8061) (TTY.QUICKTEST 8063 . 8543) (TTY.MENU 8545 . 8938) (TTYTMENU.SELFN 8940 . 9323)))))
|
||||
STOP
|
||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
@@ -1 +0,0 @@
|
||||
12345
|
||||
Binary file not shown.
@@ -1 +0,0 @@
|
||||
aδσγδφβc
|
||||
Binary file not shown.
Binary file not shown.
@@ -1 +0,0 @@
|
||||
012345X1245
|
||||
@@ -1,495 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 3-Jul-2022 14:07:11"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>internal>test>filepos>TFP.;31 27425
|
||||
|
||||
:CHANGES-TO (FNS TFP TFP1)
|
||||
|
||||
:PREVIOUS-DATE " 3-Jul-2022 13:32:16"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>internal>test>filepos>TFP.;27)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TFPCOMS)
|
||||
|
||||
(RPAQQ TFPCOMS
|
||||
((FNS TFP TFP1 FPC FPCS)
|
||||
(FNS OLDFILEPOS OLDFFILEPOS)
|
||||
(FILES FPTESTS)
|
||||
(ADDVARS (DIRECTORIES {WMEDLEY}<internal>test>filepos>))
|
||||
|
||||
(* ;; "Compiling also requires EXPORTS.ALL")
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
IOCHAR))))
|
||||
(DEFINEQ
|
||||
|
||||
(TFP
|
||||
[LAMBDA (TESTNAMES TAGS FN) (* ; "Edited 3-Jul-2022 14:06 by rmk")
|
||||
(CL:UNLESS TESTNAMES (SETQ TESTNAMES ALLTESTS))
|
||||
(LET [(TESTS (FOR TN INSIDE TESTNAMES FIRST (PRINTOUT T "Testing")
|
||||
JOIN (PRINTOUT T " " TN)
|
||||
(CONS (MKSTRING TN)
|
||||
(COPY (EVALV TN))) FINALLY (TERPRI T]
|
||||
(CL:WHEN TAGS
|
||||
(SETQ TESTS (FOR TEST IN TESTS WHEN (THEREIS TAG INSIDE TAGS
|
||||
SUCHTHAT (MEMB TAG TEST)) COLLECT TEST)))
|
||||
(PRINTOUT T (LENGTH TESTS)
|
||||
" tests" T)
|
||||
(FOR TEST VAL COMMENT PRINTED IN TESTS EACHTIME (CL:WHEN (STRINGP TEST)
|
||||
(SETQ COMMENT TEST)
|
||||
(SETQ PRINTED NIL))
|
||||
WHEN [AND (LISTP TEST)
|
||||
(NOT (AND FN (CADDR TEST] UNLESS (EQUAL (CAR TEST)
|
||||
(SETQ VAL (TFP1 (CADR TEST)
|
||||
FN)))
|
||||
COLLECT (CL:WHEN COMMENT
|
||||
(CL:UNLESS PRINTED (PRINTOUT T COMMENT T)))
|
||||
(PRINTOUT T 5 VAL " <- " .P2 TEST T)
|
||||
(CONS VAL TEST])
|
||||
|
||||
(TFP1
|
||||
[LAMBDA (FPARGS FN) (* ; "Edited 3-Jul-2022 14:04 by rmk")
|
||||
|
||||
(* ;; "FN is the search function to apply: NIL = FILEPOS, OLDFILEPOS, FFILEPOS. OLDFFILEPOS")
|
||||
|
||||
(* ;; "For convenience: NIL -> FILEPOS, OF -> OLDFILEPOS, FF -> FFILEPOS, OFF -> OLDFFILEPOS.")
|
||||
|
||||
(* ;; "OLDFILEPOS and OLDFFILEPOS do only a byte searches.")
|
||||
|
||||
(* ;;
|
||||
"FPARGS is a list of FILEPOS args. CASEARRAY=T means Transparent case array, pushes to FFILEPOS. ")
|
||||
|
||||
(* ;; "The file extension gives the format, defaulting to *DEFAULT-EXTERNALFORMAT* = :XCCS")
|
||||
|
||||
(SETQ FN (SELECTQ FN
|
||||
((NIL FILEPOS)
|
||||
'FILEPOS)
|
||||
((FF FFILEPOS)
|
||||
'FFILEPOS)
|
||||
((OF OLDFILEPOS)
|
||||
'OLDFILEPOS)
|
||||
((OFF OLDFFILEPOS)
|
||||
'OLDFFILEPOS)
|
||||
(HELP "BAD FN" FN)))
|
||||
(CL:WHEN (OR (FIXP (CAR FPARGS))
|
||||
(NULL (CAR FPARGS))
|
||||
(AND (LISTP (CAR FPARGS))
|
||||
(FIXP (CAAR FPARGS))
|
||||
(FIXP (CDAR FPARGS)))
|
||||
(LISTP (CADR FPARGS)))
|
||||
(SETQ FPARGS (CADR FPARGS)))
|
||||
(LET (STREAM VAL PATTERN FILE START END SKIP TAIL CASEARRAY EXT (FORMAT *DEFAULT-EXTERNALFORMAT*)
|
||||
)
|
||||
(SETQ PATTERN (EVAL (POP FPARGS))) (* ;
|
||||
"So we can do substrings, CHARACTER etc.")
|
||||
(SETQ FILE (POP FPARGS))
|
||||
(SETQ START (POP FPARGS))
|
||||
(SETQ END (POP FPARGS))
|
||||
(SETQ SKIP (POP FPARGS))
|
||||
(SETQ TAIL (POP FPARGS))
|
||||
(SETQ CASEARRAY (POP FPARGS))
|
||||
(SETQ EXT (FILENAMEFIELD.STRING FILE 'EXTENSION))
|
||||
(CL:WHEN EXT
|
||||
(CL:WHEN (STRPOS "UTF8" EXT)
|
||||
(SETQ EXT "UTF-8"))
|
||||
[SETQ FORMAT (FIND-FORMAT (CL:INTERN EXT 'KEYWORD])
|
||||
[SETQ STREAM (OPENSTREAM (OR (FINDFILE FILE T)
|
||||
FILE)
|
||||
'INPUT NIL `((FORMAT ,FORMAT]
|
||||
(SETQ CASEARRAY (IF (EQ CASEARRAY T)
|
||||
THEN (CASEARRAY)
|
||||
ELSE (EVAL CASEARRAY)))
|
||||
(SETQ VAL (APPLY* FN PATTERN STREAM START END SKIP TAIL CASEARRAY))
|
||||
(CLOSEF? STREAM)
|
||||
VAL])
|
||||
|
||||
(FPC
|
||||
[LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 29-Jun-2022 21:22 by rmk")
|
||||
|
||||
(* ;; "Compare old and new filepos")
|
||||
|
||||
(LET (OLD NEW EXT FORMAT)
|
||||
(CL:UNLESS (STREAMP FILE)
|
||||
(SETQ EXT (FILENAMEFIELD.STRING FILE 'EXTENSION))
|
||||
(SETQ FORMAT (CL:INTERN EXT 'KEYWORD))
|
||||
(CL:UNLESS (FIND-FORMAT FORMAT T)
|
||||
(SETQ FORMAT :XCCS))
|
||||
(STREAMPROP FILE 'FORMAT FORMAT))
|
||||
(SETQ OLD (OLDFILEPOS STR FILE START END SKIP TAIL CASEARRAY))
|
||||
(SETQ NEW (FILEPOS STR FILE START END SKIP TAIL CASEARRAY))
|
||||
(CLOSEF FILE)
|
||||
(CL:UNLESS (EQUAL OLD (IF (EQ TAIL 'BOTH)
|
||||
THEN (CDR NEW)
|
||||
ELSE NEW))
|
||||
(HELP (CONCAT "OLD=" (OR OLD "NIL")
|
||||
" NEW="
|
||||
(OR NEW "NIL"))))
|
||||
(LIST OLD NEW])
|
||||
|
||||
(FPCS
|
||||
[LAMBDA (STR FILE START END SKIP TAIL) (* ; "Edited 29-Jun-2022 23:56 by rmk")
|
||||
(* ; "Edited 28-Jun-2022 22:21 by rmk")
|
||||
|
||||
(* ;; "Compare old and new slow filepos")
|
||||
|
||||
(LET (FAST SLOW EXT FORMAT)
|
||||
(CL:UNLESS (STREAMP FILE)
|
||||
(SETQ EXT (FILENAMEFIELD.STRING FILE 'EXTENSION))
|
||||
(SETQ FORMAT (CL:INTERN EXT 'KEYWORD))
|
||||
(CL:UNLESS (FIND-FORMAT FORMAT T)
|
||||
(SETQ FORMAT :XCCS))
|
||||
(STREAMPROP FILE 'FORMAT FORMAT))
|
||||
(SETQ FAST (FILEPOS STR FILE START END SKIP TAIL))
|
||||
(SETQ SLOW (FILEPOS STR FILE START END SKIP TAIL (CASEARRAY)))
|
||||
(CLOSEF FILE)
|
||||
(CL:UNLESS (EQUAL FAST SLOW)
|
||||
(HELP (CONCAT "FAST=" (OR FAST "NIL")
|
||||
" SLOW="
|
||||
(OR SLOW "NIL"))))
|
||||
(LIST FAST SLOW])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(OLDFILEPOS
|
||||
[LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 27-Jun-2022 23:35 by rmk")
|
||||
(* ; "Edited 10-Aug-2020 21:44 by rmk:")
|
||||
(* Pavel "12-Oct-86 15:13")
|
||||
|
||||
(* ;; "RMK: Added coercion from internal XCCS string to UTF8 if searching a UTF8 file")
|
||||
|
||||
(* ;; "NB: this function now works on non-PAGEMAPPED files. It must use only IO functions that respect that.")
|
||||
|
||||
(PROG ((SKIPCHAR (AND SKIP (CHCON1 SKIP)))
|
||||
[CA (fetch (ARRAYP BASE) of (COND
|
||||
[CASEARRAY (COND
|
||||
((AND (ARRAYP CASEARRAY)
|
||||
(EQ (fetch (ARRAYP TYP) of CASEARRAY)
|
||||
\ST.BYTE))
|
||||
CASEARRAY)
|
||||
(T (CASEARRAY CASEARRAY]
|
||||
(T \TRANSPARENT]
|
||||
(STREAM (\GETSTREAM FILE 'INPUT))
|
||||
CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE
|
||||
BIGENDBYTE STARTSEG ENDSEG)
|
||||
(CL:WHEN (EQ :UTF-8 (\EXTERNALFORMAT STREAM))
|
||||
(SETQ STR (XTOUSTRING STR)))
|
||||
[COND
|
||||
((LITATOM STR)
|
||||
(SETQ STRBASE (fetch (LITATOM PNAMEBASE) of STR))
|
||||
(SETQ STRINDEX 1)
|
||||
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of STR)))
|
||||
(T (OR (STRINGP STR)
|
||||
(SETQ STR (MKSTRING STR)))
|
||||
(SETQ STRBASE (fetch (STRINGP BASE) of STR))
|
||||
(SETQ STRINDEX (fetch (STRINGP OFFST) of STR))
|
||||
(SETQ PATLEN (fetch (STRINGP LENGTH) of STR] (* ;
|
||||
"calculate start addr and set file ptr.")
|
||||
[SETQ STARTBYTE (COND
|
||||
(START (COND
|
||||
((NOT (AND (FIXP START)
|
||||
(IGEQ START 0)))
|
||||
(LISPERROR "ILLEGAL ARG" START)))
|
||||
(SETQ ORGFILEPTR (\GETFILEPTR STREAM))
|
||||
(\SETFILEPTR STREAM START)
|
||||
START)
|
||||
(T (SETQ ORGFILEPTR (\GETFILEPTR STREAM]
|
||||
(* ;
|
||||
"calculate the character address of the character after the last possible match.")
|
||||
[SETQ ENDBYTE (ADD1 (COND
|
||||
((NULL END) (* ; "Default is end of file")
|
||||
(IDIFFERENCE (\GETEOFPTR STREAM)
|
||||
PATLEN))
|
||||
((IGEQ END 0) (* ; "Absolute byte pointer given")
|
||||
(IMIN END (IDIFFERENCE (\GETEOFPTR STREAM)
|
||||
PATLEN)))
|
||||
((IGREATERP PATLEN (IMINUS END))
|
||||
(* ;
|
||||
"END is too far, use eof less length")
|
||||
(IDIFFERENCE (\GETEOFPTR STREAM)
|
||||
PATLEN))
|
||||
(T (IDIFFERENCE (IPLUS (\GETEOFPTR STREAM)
|
||||
END 1)
|
||||
PATLEN]
|
||||
|
||||
(* ;; "use STARTBYTE and ENDBYTE instead of START and END because vm functions shouldn't change their arguments.")
|
||||
|
||||
(COND
|
||||
((IGEQ STARTBYTE ENDBYTE) (* ; "nothing to search")
|
||||
(GO FAILED)))
|
||||
(SETQ LASTINDEX PATLEN)
|
||||
SKIPLP
|
||||
(* ;
|
||||
"set the first character to FIRSTCHAR, handling leading skips.")
|
||||
(COND
|
||||
((EQ LASTINDEX 0) (* ; "null case")
|
||||
(GO FOUNDIT))
|
||||
((EQ (SETQ FIRSTCHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE STRINDEX)))
|
||||
SKIPCHAR) (* ;
|
||||
"first character in pattern is skip.")
|
||||
(SETQ LASTINDEX (SUB1 LASTINDEX))
|
||||
(\BIN STREAM) (* ; "Move forward a character.")
|
||||
(add STRINDEX 1)
|
||||
(add STARTBYTE 1)
|
||||
(GO SKIPLP)))
|
||||
(SETQ LASTINDEX (IPLUS LASTINDEX STRINDEX)) (* ;
|
||||
"Used for end of pattern check, comparing against current INDEX")
|
||||
[COND
|
||||
((SMALLP ENDBYTE)
|
||||
(SETQ STARTSEG (SETQ ENDSEG 0)))
|
||||
(T
|
||||
(* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts. The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary (can get around that here by decrementing everyone, but can't in FFILEPOS). Note that STARTBYTE and ENDBYTE are never actually used as file ptrs, just for counting.")
|
||||
|
||||
(SETQ ENDSEG (FOLDLO ENDBYTE FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ BIGENDBYTE (IMOD ENDBYTE FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ STARTSEG (FOLDLO STARTBYTE FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ STARTBYTE (IMOD STARTBYTE FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ ENDBYTE (COND
|
||||
((EQ STARTSEG ENDSEG)
|
||||
BIGENDBYTE)
|
||||
(T
|
||||
|
||||
(* ;; "In different segments, so we'll have to search all the way to the end of this seg; hence, `end' is currently as big as it gets")
|
||||
|
||||
FILEPOS.SEGMENT.SIZE]
|
||||
FIRSTCHARLP
|
||||
|
||||
|
||||
(* ;; "STARTBYTE is the possible beginning of a match. the file ptr of the file is always at STARTBYTE position when the FIRSTCHAR loop is passed.")
|
||||
|
||||
(COND
|
||||
((EQ STARTBYTE ENDBYTE) (* ; "end of this part of search")
|
||||
(COND
|
||||
((EQ STARTSEG ENDSEG) (* ; "failed")
|
||||
(GO FAILED))) (* ;
|
||||
"Finished this segment, roll over into new one")
|
||||
(SETQ STARTBYTE 0) (* ; "= STARTBYTE-FILEPOS.SEGMENT.SIZE")
|
||||
[COND
|
||||
((EQ (add STARTSEG 1)
|
||||
ENDSEG) (* ;
|
||||
"Entering final segment, so set ENDBYTE to actual end instead of segment end")
|
||||
(COND
|
||||
((EQ (SETQ ENDBYTE BIGENDBYTE)
|
||||
0)
|
||||
(GO FAILED]
|
||||
(GO FIRSTCHARLP))
|
||||
((NEQ FIRSTCHAR (\GETBASEBYTE CA (\BIN STREAM)))
|
||||
(add STARTBYTE 1)
|
||||
(GO FIRSTCHARLP)))
|
||||
(SETQ PATINDEX STRINDEX)
|
||||
MATCHLP
|
||||
(* ;
|
||||
"At this point, STR is matched thru offset PATINDEX")
|
||||
(COND
|
||||
((EQ (SETQ PATINDEX (ADD1 PATINDEX))
|
||||
LASTINDEX) (* ; "matched for entire length")
|
||||
(GO FOUNDIT))
|
||||
((OR (EQ (SETQ CHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE PATINDEX)))
|
||||
(\GETBASEBYTE CA (\BIN STREAM)))
|
||||
(EQ CHAR SKIPCHAR)) (* ;
|
||||
"Char from file matches char from STR")
|
||||
(GO MATCHLP))
|
||||
(T (* ;
|
||||
"Match failed, so we have to start again with first char")
|
||||
(\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM)
|
||||
(IDIFFERENCE PATINDEX STRINDEX)))
|
||||
|
||||
(* ;; "Back up over the chars we have just read in trying to match, less one. I.e. go back to one past the previous starting point")
|
||||
|
||||
(add STARTBYTE 1)
|
||||
(GO FIRSTCHARLP)))
|
||||
FOUNDIT
|
||||
(* ;
|
||||
"set fileptr, adjust for beginning skips and return proper value.")
|
||||
[COND
|
||||
((NOT TAIL) (* ;
|
||||
"Fileptr wants to be at start of string")
|
||||
(\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM)
|
||||
PATLEN]
|
||||
(RETURN (\GETFILEPTR STREAM))
|
||||
FAILED
|
||||
(* ;
|
||||
"return the fileptr to its initial position.")
|
||||
(\SETFILEPTR STREAM ORGFILEPTR)
|
||||
(RETURN NIL])
|
||||
|
||||
(OLDFFILEPOS
|
||||
[LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 10-Aug-2020 21:44 by rmk:")
|
||||
|
||||
(* ;; "RMK: Added coercion from internal XCCS string to UTF8 if searching a UTF8 file")
|
||||
(* Pavel "12-Oct-86 15:20")
|
||||
(PROG ([STREAM (\GETSTREAM (OR FILE (INPUT]
|
||||
PATBASE PATOFFSET PATLEN ORGFILEPTR STARTOFFSET ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG EOF
|
||||
)
|
||||
(COND
|
||||
(SKIP (* ; "Slow case--use FILEPOS")
|
||||
(GO TRYFILEPOS))
|
||||
((NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM)))
|
||||
(* ;
|
||||
"This is a non-page-oriented file. Use FILEPOS instead.")
|
||||
(GO TRYFILEPOS))) (* ;
|
||||
"calculate start addr and set file ptr.")
|
||||
(CL:WHEN (EQ :UTF8 (\EXTERNALFORMAT STREAM))
|
||||
(SETQ PATTERN (XTOUSTRING PATTERN)))
|
||||
[COND
|
||||
((LITATOM PATTERN)
|
||||
(SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PATTERN))
|
||||
(SETQ PATOFFSET 1)
|
||||
(SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PATTERN)))
|
||||
(T (OR (STRINGP PATTERN)
|
||||
(SETQ PATTERN (MKSTRING PATTERN)))
|
||||
(SETQ PATBASE (fetch (STRINGP BASE) of PATTERN))
|
||||
(SETQ PATOFFSET (fetch (STRINGP OFFST) of PATTERN))
|
||||
(SETQ PATLEN (fetch (STRINGP LENGTH) of PATTERN]
|
||||
(COND
|
||||
((OR (IGREATERP PATLEN \MAX.PATTERN.SIZE)
|
||||
(ILESSP PATLEN \MIN.PATTERN.SIZE))
|
||||
(GO TRYFILEPOS)))
|
||||
(SETQ ORGFILEPTR (\GETFILEPTR STREAM))
|
||||
(SETQ STARTOFFSET (IPLUS (COND
|
||||
(START (COND
|
||||
((NOT (AND (FIXP START)
|
||||
(IGEQ START 0)))
|
||||
(LISPERROR "ILLEGAL ARG" START)))
|
||||
START)
|
||||
(T ORGFILEPTR))
|
||||
(SUB1 PATLEN))) (* ;
|
||||
"STARTOFFSET is the address of the character corresponding to the last character of PATTERN.")
|
||||
(SETQ EOF (\GETEOFPTR STREAM)) (* ;
|
||||
"calculate the character address of the character after the last possible match.")
|
||||
[SETQ ENDOFFSET (COND
|
||||
((NULL END) (* ; "Default is end of file")
|
||||
EOF)
|
||||
(T (IMIN (IPLUS (COND
|
||||
((ILESSP END 0)
|
||||
(IPLUS EOF END 1))
|
||||
(T END))
|
||||
PATLEN)
|
||||
EOF]
|
||||
|
||||
(* ;; "use STARTOFFSET and ENDOFFSET instead of START and END because vm functions shouldn't change their arguments.")
|
||||
|
||||
(COND
|
||||
((IGEQ STARTOFFSET ENDOFFSET) (* ; "nothing to search")
|
||||
(RETURN))
|
||||
((ILESSP (IDIFFERENCE ENDOFFSET STARTOFFSET)
|
||||
\MIN.SEARCH.LENGTH) (* ;
|
||||
"too small to make FFILEPOS worthwhile")
|
||||
(GO TRYFILEPOS)))
|
||||
(\SETFILEPTR STREAM STARTOFFSET)
|
||||
[RETURN (GLOBALRESOURCE
|
||||
(\FFDELTA1 \FFDELTA2 \FFPATCHAR)
|
||||
(PROG ((CASE (fetch (ARRAYP BASE)
|
||||
of (COND
|
||||
[CASEARRAY (COND
|
||||
((AND (ARRAYP CASEARRAY)
|
||||
(EQ (fetch (ARRAYP TYP) of CASEARRAY)
|
||||
\ST.BYTE))
|
||||
CASEARRAY)
|
||||
(T (CASEARRAY CASEARRAY]
|
||||
(T \TRANSPARENT))))
|
||||
(DELTA1 (fetch (ARRAYP BASE) of \FFDELTA1))
|
||||
(DELTA2 (fetch (ARRAYP BASE) of \FFDELTA2))
|
||||
(PATCHAR (fetch (ARRAYP BASE) of \FFPATCHAR))
|
||||
(MAXPATINDEX (SUB1 PATLEN))
|
||||
CHAR CURPATINDEX LASTCHAR INC)
|
||||
|
||||
(* ;; "Use Boyer-Moore string search algorithm. Use two auxiliary tables, DELTA1 and DELTA2, to tell how far ahead to move in the file when a partial match fails. DELTA1 contains, for each character code, the distance of that character from the right end of the pattern, or PATLEN if the character does not occur in the pattern. DELTA2 contains, for each character position in the pattern, how far ahead to move such that the partial substring discovered to the right of the position now matches some other substring (to the left) in the pattern. PATCHAR is just PATTERN translated thru CASEARRAY")
|
||||
|
||||
(\SETUP.FFILEPOS PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE)
|
||||
[COND
|
||||
((SMALLP ENDOFFSET)
|
||||
(SETQ STARTSEG (SETQ ENDSEG 0)))
|
||||
(T
|
||||
(* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts. The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary. Note that STARTOFFSET and ENDOFFSET are never actually used as file ptrs, just for counting.")
|
||||
|
||||
(SETQ ENDSEG (FOLDLO ENDOFFSET FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ BIGENDOFFSET (MOD ENDOFFSET FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ STARTSEG (FOLDLO STARTOFFSET FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ STARTOFFSET (MOD STARTOFFSET FILEPOS.SEGMENT.SIZE))
|
||||
(SETQ ENDOFFSET (COND
|
||||
((EQ STARTSEG ENDSEG)
|
||||
BIGENDOFFSET)
|
||||
(T
|
||||
|
||||
(* ;; "In different segments, so we'll have to search all the way to the end of this seg; hence, `end' is currently as big as it gets")
|
||||
|
||||
FILEPOS.SEGMENT.SIZE]
|
||||
(SETQ LASTCHAR (GETBASEBYTE PATCHAR MAXPATINDEX))
|
||||
FIRSTCHARLP
|
||||
(COND
|
||||
[(IGEQ STARTOFFSET ENDOFFSET) (* ; "End of this chunk")
|
||||
(COND
|
||||
((EQ STARTSEG ENDSEG) (* ; "failed")
|
||||
(GO FAILED))
|
||||
(T (* ;
|
||||
"Finished this segment, roll over into new one")
|
||||
(add STARTSEG 1)
|
||||
(SETQ STARTOFFSET (IDIFFERENCE STARTOFFSET FILEPOS.SEGMENT.SIZE))
|
||||
(COND
|
||||
((EQ STARTSEG ENDSEG)
|
||||
(SETQ ENDOFFSET BIGENDOFFSET)))
|
||||
(GO FIRSTCHARLP]
|
||||
((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN STREAM)))
|
||||
LASTCHAR)
|
||||
(add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR)))
|
||||
(OR (EQ INC 1)
|
||||
(\INCFILEPTR STREAM (SUB1 INC)))
|
||||
(* ;
|
||||
"advance file pointer accordingly (\BIN already advanced it one)")
|
||||
(GO FIRSTCHARLP)))
|
||||
(SETQ CURPATINDEX (SUB1 MAXPATINDEX))
|
||||
MATCHLP
|
||||
(COND
|
||||
((ILESSP CURPATINDEX 0)
|
||||
(GO FOUNDIT)))
|
||||
(\DECFILEPTR STREAM 2) (* ; "back up to read previous char")
|
||||
(COND
|
||||
((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN STREAM)))
|
||||
(GETBASEBYTE PATCHAR CURPATINDEX))
|
||||
(* ;
|
||||
"Mismatch, advance by greater of delta1 and delta2")
|
||||
(add STARTOFFSET (IDIFFERENCE (SETQ INC (IMAX (GETBASEBYTE DELTA1 CHAR)
|
||||
(GETBASEBYTE DELTA2
|
||||
CURPATINDEX)))
|
||||
(IDIFFERENCE MAXPATINDEX CURPATINDEX)))
|
||||
(OR (EQ INC 1)
|
||||
(\INCFILEPTR STREAM (SUB1 INC)))
|
||||
(GO FIRSTCHARLP)))
|
||||
(SETQ CURPATINDEX (SUB1 CURPATINDEX))
|
||||
(GO MATCHLP)
|
||||
FOUNDIT
|
||||
(* ;
|
||||
"set fileptr, adjust for beginning skips and return proper value.")
|
||||
(\INCFILEPTR STREAM (COND
|
||||
(TAIL (* ; "Put fileptr at end of string")
|
||||
(SUB1 PATLEN))
|
||||
(T (* ;
|
||||
"back up over the last char we looked at, i.e. the first char of string")
|
||||
-1)))
|
||||
(RETURN (\GETFILEPTR STREAM))
|
||||
FAILED
|
||||
(* ;
|
||||
"return the fileptr to its initial position.")
|
||||
(\SETFILEPTR STREAM ORGFILEPTR)
|
||||
(RETURN NIL]
|
||||
TRYFILEPOS
|
||||
(RETURN (FILEPOS PATTERN STREAM START END SKIP TAIL CASEARRAY])
|
||||
)
|
||||
|
||||
(FILESLOAD FPTESTS)
|
||||
|
||||
(ADDTOVAR DIRECTORIES {WMEDLEY}<internal>test>filepos>)
|
||||
|
||||
|
||||
|
||||
(* ;; "Compiling also requires EXPORTS.ALL")
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
IOCHAR)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (759 6571 (TFP 769 . 2219) (TFP1 2221 . 4656) (FPC 4658 . 5619) (FPCS 5621 . 6569)) (
|
||||
6572 27191 (OLDFILEPOS 6582 . 16284) (OLDFFILEPOS 16286 . 27189)))))
|
||||
STOP
|
||||
Binary file not shown.
@@ -1 +0,0 @@
|
||||
012
|
||||
@@ -1 +0,0 @@
|
||||
(HCFILES "{DSK}<home>larry>ilisp>envos>" "{DSK}<home>larry>medley>tmp>psfiles>")
|
||||
@@ -1,66 +0,0 @@
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>DOC>PUBS>admin>doc-dirs>ERIS-DOC-WO-LOOPS.TEDIT;2
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>DOC>medley1.2>RS6000>keybaord-layout.tedit;3
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>DOC>medley2.0>final>ug>APP-D-DIFFERENCES.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>DOC>printers>recommendation.tedit;3
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>1982BUGS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>BRIEFINGBLURB-DRAFT.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>CHAT-GENERIC.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>HELLO.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>IDDESCRIPTION.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>LISPARFIELDS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>NSCHARACTERS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>DOC>SOURCEFILES.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>library>COLOROBJ.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>internal>library>DSKTEST.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>notecards>library>BOONE-V-COE.TED;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>LISPCORE>notecards>library>NCPLOTCARD.TED;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>MISC>test>GC>HAND-AUX>ADVDICT-N-Z.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>MISC>test>Library>TEdit>Hand-Aux>AR10063.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>MISC>test>i>o>Hardcopy>Hand>testfiles>04PARA.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>OTHER>lafite>Doc>LAFITEDELTA.TED;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>OTHER>lafite>Doc>LAFITEIMPL.TED;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>OTHER>lafite>Doc>Manual>LAFITEMANUAL-INDEXINTERNAL.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>lispusers>2.0>src>EQUATIONEXAMPLES.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>1.2>doc>03-SOFTWARE-INSTALLATION.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>1.2>doc>05-NOTECARDS-BASICS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>1.2>doc>11-SYSTEM-CARDS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd0e>RELEASE>notecards>2.0>src>library>BOONE-V-COE.TED;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>nilsson>intercalc>inter-calc>INTERCALCDEMO.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>nilsson>intercalc>inter-calc>INTERCALCDOCUMENTATION.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>JELLINEK>graphics>DDLCOLORHAX.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>JELLINEK>graphics>LUCASFILMFORMAT.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>basics>INVOICE.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>genis>FLYER-COV-CHOICE.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>genis>FLYER-COV.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>inter-calc>INTERCALCDEMO.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>inter-calc>INTERCALCDOCUMENTATION.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>ADVERTS>Cherry-RidgeWFH.TEdit;5
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Adv-Committee>Defns>ADVDEFNS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Board>CALLERLAB-BYLAWCHANGE.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Challenge-Committee>C1-NEW-DEFNS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Challenge-Committee>C1DEFNS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>Callerlab>Challenge-Committee>C2DEFNS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>sd>NUMBERART.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>ADVDICT-A-M.TEDIT;13
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>ADVDICT-N-Z.TEDIT;9
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C1DEFNS-I-R.TEDIT;9
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C1DEFNS-S.TEDIT;7
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C1DEFNS-T-Z.TEDIT;9
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-A-E.TEDIT;11
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-F-O.TEDIT;5
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-P-S.TEDIT;6
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>C2DEFNS-T-Z.TEDIT;6
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>DICT-PREFACE.TEDIT;14
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>Dictionaries>leftover-calls.tedit;3
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>top10-87>FRA>ARRANGEMENTS.TEDIT;28
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>sybalsky>venue>ads>aaai>top-rapid-dev.TEdit;4
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>24-STREAMS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>25-IO.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>27-GRAPHICS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>28-WINDOWS.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>29-HARDCOPY.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>30-ETHERNET.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>30-TERMINAL.TEDIT;1
|
||||
{DSK}<home>larry>ilisp>envos>xd1d>users>turpin>IRM-3>old>31-ETHERNET.TEDIT;1
|
||||
{DSK}<home>larry>medley>lispusers>ACE>ACE-MAINTAINERS-NOTES.TEDIT;1
|
||||
{DSK}<home>larry>medley>lispusers>EQUATIONEXAMPLES.TEDIT;1
|
||||
@@ -1,546 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-May-2022 12:30:29"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>TESTUPF.;1 32843 )
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TESTUPFCOMS)
|
||||
|
||||
(RPAQQ TESTUPFCOMS
|
||||
((COMS (* ; "Original code")
|
||||
(FNS OLD-UNPACKFILENAME.STRING \UPF.NEXTPOS \UPF.TEMPFILEP)
|
||||
(DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY UNPACKFILE1)))
|
||||
|
||||
(* ;; "Debugging")
|
||||
|
||||
|
||||
(* ;; "DOTTEDNAMES: mismatch intended")
|
||||
|
||||
|
||||
(* ;; "RETURNFAILS: mismatch with DIRFLG=RETURN, DIRECTORY and SUBDIRECTORY are swapped. But original doesn't agree with its own complete analaysis.")
|
||||
|
||||
(VARS DOTTEDNAMES TESTS RETURNFAILS)
|
||||
(FNS TRY TRYALL DT)))
|
||||
|
||||
|
||||
|
||||
(* ; "Original code")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(OLD-UNPACKFILENAME.STRING
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 25-Jan-2022 17:16 by rmk")
|
||||
(* ; "Edited 5-Jan-2022 11:03 by rmk")
|
||||
(* ; "Edited 30-Mar-90 22:37 by nm")
|
||||
|
||||
(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts")
|
||||
|
||||
(* ;;; "rmk: devices must come before directories.")
|
||||
|
||||
(PROG ((POS 1)
|
||||
(LEN (NCHARS FILE))
|
||||
TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI)
|
||||
(COND
|
||||
((NULL FILE)
|
||||
(RETURN NIL))
|
||||
((OR (LITATOM FILE)
|
||||
(STRINGP FILE)
|
||||
(NUMBERP FILE)))
|
||||
((TYPEP FILE 'PATHNAME)
|
||||
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
|
||||
[(STREAMP FILE) (* ;
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
|
||||
(RETURN (COND
|
||||
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
|
||||
FILE))
|
||||
(T (LIST 'NAME FILE]
|
||||
(T (\ILLEGAL.ARG FILE)))
|
||||
(COND
|
||||
((SELCHARQ (NTHCHARCODE FILE 1)
|
||||
({ (* ; "normal use in Interlisp-D")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
|
||||
FILE 2)
|
||||
0))))
|
||||
(%[ (* ;
|
||||
"some Xerox and Arpanet systems use '[' for host")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
|
||||
FILE 2)
|
||||
0))))
|
||||
(%( (* ;
|
||||
"this is the 'proposed standard' for Xerox servers")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
|
||||
FILE 2)
|
||||
0))))
|
||||
NIL)
|
||||
(UNPACKFILE1 'HOST 2 TEM)
|
||||
[COND
|
||||
((EQ TEM -1) (* ;
|
||||
"Started with the host field delimiter, but there was no corresponding terminating delimiter .")
|
||||
(* ;
|
||||
"I'm not sure why the name is dealt with the host name.")
|
||||
(RETURN (DREVERSE VAL]
|
||||
(SETQ POS (IPLUS TEM 2))
|
||||
[if (EQ OSTYPE T)
|
||||
then (* ;
|
||||
"Use actual host to determine os type")
|
||||
(SETQ OSTYPE (GETHOSTINFO (CAR VAL)
|
||||
'OSTYPE]
|
||||
(SETQ HOSTP T)))
|
||||
|
||||
(* ;; "rmk: if there is a colon before the next < or /, then we must be looking at a device. A device appears to end after the last colon, i.e., a device name can have a colon inside it.")
|
||||
|
||||
(COND
|
||||
((AND (SETQ TEM (\UPF.NEXTPOS (CHARCODE (%: < /))
|
||||
FILE POS))
|
||||
(EQ (CHARCODE %:)
|
||||
(NTHCHARCODE FILE TEM))) (* ;
|
||||
"all device returned have DEVICE.END on it so that NIL: will work")
|
||||
(UNPACKFILE1 'DEVICE POS (if CLFLG
|
||||
then (SUB1 TEM)
|
||||
else TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SETQ HOSTP T)))
|
||||
(COND
|
||||
((EQ DIRFLG 'RETURN) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")
|
||||
(LET ((TYPE 'DIRECTORY)
|
||||
(START (SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(NIL (* ; "just host, return")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((/ <) (* ;
|
||||
"Started with the initial directory delimiter.")
|
||||
(ADD1 POS))
|
||||
POS))
|
||||
END)
|
||||
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
|
||||
((/ >)
|
||||
[COND
|
||||
((EQ START POS) (* ;
|
||||
"Didn't start with a directory delimiter,")
|
||||
(COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
|
||||
(SETQ TYPE 'SUBDIRECTORY))
|
||||
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(COND
|
||||
((EQ LEN POS) (* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}/%").")
|
||||
(SETQ START POS)
|
||||
-1)
|
||||
(T -2)))
|
||||
(PROGN [COND
|
||||
[(EQ START POS) (* ;
|
||||
"Both of the initial and trail delimiters are omitted.")
|
||||
(COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory")
|
||||
(SETQ TYPE 'SUBDIRECTORY))
|
||||
(T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.")
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(T (COND
|
||||
((EQ LEN POS)
|
||||
(* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}<%").")
|
||||
(SETQ START POS]
|
||||
-1)))
|
||||
(UNPACKFILE1.DIRECTORY TYPE START END))
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(/ (* ;
|
||||
"unix and the 'xerox standard' use / for delimiter")
|
||||
(* ;
|
||||
"In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (/ >))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
T)
|
||||
((< >) (* ;
|
||||
"Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
|
||||
(* ;
|
||||
"In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
T)
|
||||
NIL)
|
||||
|
||||
(* ;; "allow {DSK}/etc to be a directory specification.")
|
||||
|
||||
(if TEM
|
||||
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
|
||||
(SUB1 TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
else
|
||||
(* ;; "{DSK}/foo: the directory is /, the name is foo")
|
||||
|
||||
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
|
||||
(SETQ POS (ADD1 POS)))
|
||||
(SETQ HOSTP T))
|
||||
((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
|
||||
FILE POS)) (* ; " {eris}abc> relative")
|
||||
|
||||
(* ;;
|
||||
" This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
|
||||
|
||||
[COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
|
||||
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
|
||||
then 'DIRECTORY
|
||||
else 'SUBDIRECTORY)
|
||||
POS
|
||||
(SUB1 TEM)))
|
||||
(T (* ; "True %"relative pathname%".")
|
||||
(UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
|
||||
then 'DIRECTORY
|
||||
else 'RELATIVEDIRECTORY)
|
||||
POS
|
||||
(SUB1 TEM]
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SETQ HOSTP T)))
|
||||
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(if (EQ OSTYPE T)
|
||||
then (* ;
|
||||
"There wasn't a host field in the name, so we have no clue")
|
||||
(SETQ OSTYPE NIL))
|
||||
NAMELP
|
||||
|
||||
|
||||
(* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.")
|
||||
|
||||
(SELCHARQ CODE
|
||||
(%. (* ;
|
||||
"Note position for later--we only want to deal with the last set of dots")
|
||||
(if BEYONDNAME
|
||||
then (* ;
|
||||
"no longer of interest (probably a bad name, too)")
|
||||
elseif FIRSTDOT
|
||||
then (* ; "We're recording the second dot")
|
||||
(if SECONDDOT
|
||||
then (* ;
|
||||
"Note only the two most recent dots")
|
||||
(SETQ FIRSTDOT SECONDDOT))
|
||||
(SETQ SECONDDOT TEM)
|
||||
else (SETQ FIRSTDOT TEM)))
|
||||
((! ; NIL) (* ;
|
||||
"SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
|
||||
(if (SELCHARQ CODE
|
||||
(! (* ;
|
||||
"! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
|
||||
(AND OSTYPE (NEQ OSTYPE 'IFS)))
|
||||
(; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S")
|
||||
[AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
|
||||
NIL)
|
||||
then (GO NEXTCHAR))
|
||||
(if FIRSTDOT
|
||||
then (* ;
|
||||
"Have a name and/or extension to parse now")
|
||||
(if
|
||||
[AND SECONDDOT
|
||||
(NOT (if OSTYPE
|
||||
then (* ;
|
||||
"Known OS type must be Tops20 for second dot to mean version")
|
||||
(EQ OSTYPE 'TOPS20)
|
||||
else (* ;
|
||||
"Unknown OS type, so check that %"version%" is numeric or wildcard")
|
||||
(AND [for I from (ADD1 SECONDDOT) to (SUB1 TEM)
|
||||
bind CH
|
||||
always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I
|
||||
)))
|
||||
(EQ CH (CHARCODE *]
|
||||
(SELCHARQ CODE
|
||||
(NIL (* ; "end of file name, ok")
|
||||
T)
|
||||
(; (* ;
|
||||
"This semi-colon better not be introducing a version")
|
||||
(\UPF.TEMPFILEP FILE (ADD1 TEM)))
|
||||
NIL]
|
||||
then (* ;
|
||||
"Second dot is not intoducing a version")
|
||||
(SETQ FIRSTDOT SECONDDOT)
|
||||
(SETQ SECONDDOT NIL))
|
||||
(UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
|
||||
(SETQ POS (ADD1 (if SECONDDOT
|
||||
then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
|
||||
(SUB1 SECONDDOT))
|
||||
(SETQ BEYONDEXT T)
|
||||
SECONDDOT
|
||||
else FIRSTDOT)))
|
||||
(SETQ BEYONDNAME T)
|
||||
(SETQ FIRSTDOT NIL))
|
||||
(UNPACKFILE1 (COND
|
||||
((NOT BEYONDNAME)
|
||||
(SETQQ BEYONDNAME NAME))
|
||||
((NOT BEYONDEXT)
|
||||
'EXTENSION)
|
||||
((AND (EQ BEYONDEXT (CHARCODE ";"))
|
||||
(\UPF.TEMPFILEP FILE POS)))
|
||||
(T (* ;
|
||||
"Everything after the semi was version")
|
||||
'VERSION))
|
||||
POS
|
||||
(SUB1 TEM))
|
||||
(if (NULL CODE)
|
||||
then (* ; "End of string")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(SETQ BEYONDEXT CODE) (* ;
|
||||
"Note the character that terminated the name/ext")
|
||||
(SETQ POS (ADD1 TEM)))
|
||||
(%' (* ; "Quoter")
|
||||
(add TEM 1))
|
||||
NIL)
|
||||
NEXTCHAR
|
||||
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
|
||||
(GO NAMELP])
|
||||
|
||||
(\UPF.NEXTPOS
|
||||
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
|
||||
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND
|
||||
((EQMEMB NCH CHAR)
|
||||
(RETURN POS))
|
||||
((EQ NCH (CHARCODE %'))
|
||||
(add POS 1)))
|
||||
(add POS 1])
|
||||
|
||||
(\UPF.TEMPFILEP
|
||||
[LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:")
|
||||
|
||||
(* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.")
|
||||
|
||||
(SELCHARQ (NTHCHARCODE FILENAME START)
|
||||
((T S) (* ; "Funny temp stuff")
|
||||
(AND (EQ START (NCHARS FILENAME))
|
||||
'TEMPORARY))
|
||||
NIL])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS CANONICAL.DIRECTORY MACRO
|
||||
[OPENLAMBDA (SRCSTRING)
|
||||
(AND
|
||||
SRCSTRING
|
||||
(LET
|
||||
((LEN (NCHARS SRCSTRING)))
|
||||
(COND
|
||||
((EQ LEN 1)
|
||||
(if (STREQUAL SRCSTRING "/")
|
||||
then "<"
|
||||
else SRCSTRING))
|
||||
(T
|
||||
(LET*
|
||||
((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
|
||||
(DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
|
||||
(DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
|
||||
(DSTPOS 0)
|
||||
(NEXTPOS -1))
|
||||
(if (NOT FATP)
|
||||
then [for SRCPOS from 1 to LEN bind CODE
|
||||
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
|
||||
(CHARCODE (< / >))) do (add SRCPOS 1))
|
||||
(if (> SRCPOS LEN)
|
||||
then (RETURN "<"))
|
||||
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
|
||||
((> /)
|
||||
(if (> DSTPOS NEXTPOS)
|
||||
then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
|
||||
(SETQ NEXTPOS (add DSTPOS 1))))
|
||||
(%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)
|
||||
(if (NEQ SRCPOS LEN)
|
||||
then (\PUTBASETHIN DSTBASE DSTPOS
|
||||
(NTHCHARCODE SRCSTRING (add SRCPOS 1)))
|
||||
(add DSTPOS 1)))
|
||||
(PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)))
|
||||
finally (RETURN (if (EQ DSTPOS LEN)
|
||||
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 -2)
|
||||
else DSTSTRING)
|
||||
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
|
||||
else (SUBSTRING DSTSTRING 1 DSTPOS]
|
||||
else (for SRCPOS from 1 to LEN bind CODE
|
||||
first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
|
||||
(CHARCODE (< / >))) do (add SRCPOS 1))
|
||||
do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
|
||||
((> /)
|
||||
(if (> DSTPOS NEXTPOS)
|
||||
then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
|
||||
(SETQ NEXTPOS (add DSTPOS 1))))
|
||||
(%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)
|
||||
(if (NEQ SRCPOS LEN)
|
||||
then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE
|
||||
SRCSTRING
|
||||
(add SRCPOS 1)))
|
||||
(add DSTPOS 1)))
|
||||
(PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
|
||||
(add DSTPOS 1)))
|
||||
finally (RETURN (if (EQ DSTPOS LEN)
|
||||
then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 -2)
|
||||
else DSTSTRING)
|
||||
elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
|
||||
(CHARCODE (> /)))
|
||||
then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
|
||||
else (SUBSTRING DSTSTRING 1 DSTPOS])
|
||||
|
||||
(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
|
||||
(LET* ((OLDDIR (SUBSTRING FILE ST END))
|
||||
(NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (AND NEWDIR
|
||||
(MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR "")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR ""])
|
||||
|
||||
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
"")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
""])
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Debugging")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;; "DOTTEDNAMES: mismatch intended")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"RETURNFAILS: mismatch with DIRFLG=RETURN, DIRECTORY and SUBDIRECTORY are swapped. But original doesn't agree with its own complete analaysis."
|
||||
)
|
||||
|
||||
|
||||
(RPAQQ DOTTEDNAMES (".x" ">.git" "x.y.100"))
|
||||
|
||||
(RPAQQ TESTS
|
||||
("*,;" "*.*;*" "*.;" "*.;*" "///abc/x" "/abc.x" "<" "<<<abc" "<<<abc>" "<<<abc>>" "<<<abc>x"
|
||||
"<<abc" "<<xyz>>>zz" "<<xyz>>>zzz/" "<<xyz>>zz" "<<xyz>zz" "<ABC>" "<XYZ>aa" "<a.b>"
|
||||
"<a;b>" "<ab;c" "<ab>" "<abc" "<abc*." "<abc.x" "<abc.x;1" "<abc;x" "<abc<<<x"
|
||||
"<abc<xyz<foo" "<abc<xyz>qrs" "<abc>" "<abc>;1" "<abc>xyz" "<abc>xyz>foo" "<xxx"
|
||||
"<xy>>zz" "<xyz>>>zzz/" ">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx"
|
||||
"A.B.C" "XXX<yyy" "a;b" "a;b/d" "a;b;c" "a;b;c;d" "aa" "aa;" "aa;NEWEST" "aa;newest"
|
||||
"aaa" "aaa/bbb" "aaa/bbb/" "aaa/xyz;x;m" "aaa<bbb" "aaa<bbb/" "aaa<xyz>" "aaa>bbb>"
|
||||
"aaa>xyz.e;m;n" "aaa>xyz>qrs" "abc" "abc...c" "abc///XYZ//" "abc/d" "abc/xyz"
|
||||
"abc/xyz.qrs" "abc/xyz.qrs;2" "abc:x<qrs>z" "abc<<<XYZ//" "abc<x" "abc<xyz"
|
||||
"abc<xyz>qq" "abc<xyzqq" "abc>;1" "abc>qr.x" "abc>xy" "abc>xyz" "abc>xyz;2"
|
||||
"dev:aaa>xyz>qrs" "foo:" "foo:aaa<xyz" "foo:aaa<xyz>" "foo:x<qrs>z" "foo<a:B>" "s;n;b"
|
||||
"x.y.z;w" "x.y;z" "x;y" "x<abc<xyz>qrs" "x<abc<z" "x<abc>z" "xxx<yyy" "xxx<yyy>"
|
||||
"xxx<yyy>zzz" "xxx>yyy" "xxx>yyy>" "{ABC}" "{ABC}XXX:" "{DSK}" "{DSK}*.;*" "{DSK}...<a"
|
||||
"{DSK}<a" "{DSK}xxx<a" "{DSK}xxx<xxx>yyy" "{DSK}xxx>xxx" "{DSK}xxx>yyy"
|
||||
"{HOST}foo:x<qrs>z" "{HOST}x<qrs>z" "{abc}" "{dsk}foo:aaa>b>.c.e.g;f"
|
||||
"{dsk}foo:aaa>b>.c.e;f" "{dsk}foo:aaa>b>c.e;f" "{eris}abc>" "{host}abc/xyz;2"
|
||||
"{host}abc>xyz;2" "{x}abc<xyz>qq" "{x}abc<xyzqq" "<abc<xyz>abc" "<abc<xyz>qrs"
|
||||
"<abc<xyz>"))
|
||||
|
||||
(RPAQQ RETURNFAILS (">" ">>>abc/x" ">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx" ">" ">>>abc/x"
|
||||
">abc" ">abc;1" ">abc>" ">abc>xyz>foo" ">xxx"))
|
||||
(DEFINEQ
|
||||
|
||||
(TRY
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG) (* ; "Edited 23-May-2022 12:09 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 14:15 by rmk")
|
||||
(* ; "Edited 24-Apr-2022 08:45 by rmk")
|
||||
(* ; "Edited 21-Apr-2022 15:36 by rmk")
|
||||
(CL:WHEN (LISTP (CAR (LISTP FILE)))
|
||||
(SETQ FILE (CAR FILE)))
|
||||
(LET (ORIG NEW)
|
||||
(CL:WHEN (LISTP FILE)
|
||||
(SETQ ONEFIELDFLG (CADR FILE))
|
||||
(SETQ DIRFLG (CADDR FILE))
|
||||
(SETQ FILE (CAR FILE)))
|
||||
(SETQ ORIG (OLD-UNPACKFILENAME.STRING FILE ONEFIELDFLG DIRFLG))
|
||||
(SETQ NEW (UNPACKFILENAME.STRING FILE ONEFIELDFLG DIRFLG))
|
||||
(LIST (LIST FILE ONEFIELDFLG DIRFLG)
|
||||
(AND (EQUAL ORIG NEW)
|
||||
'=)
|
||||
ORIG NEW])
|
||||
|
||||
(TRYALL
|
||||
[LAMBDA (FILES ALLFLAG ONEFIELDFLG DIRFLG) (* ; "Edited 21-Apr-2022 17:56 by rmk")
|
||||
(* ; "Edited 2-Apr-2022 23:50 by rmk")
|
||||
(* ; "Edited 31-Mar-2022 22:57 by rmk")
|
||||
(CL:WHEN (LISTP FILES)
|
||||
(SETQ FILES (FOR F IN FILES COLLECT (CL:IF (LISTP (CAR (LISTP F)))
|
||||
(CAR F)
|
||||
F))))
|
||||
(FOR FILE INFO (SAME _ 0)
|
||||
(DIFF _ 0) IN FILES EACHTIME (SETQ INFO (TRY FILE ONEFIELDFLG DIRFLG))
|
||||
(CL:IF (CADR INFO)
|
||||
(ADD SAME 1)
|
||||
(ADD DIFF 1)) UNLESS (AND (CADR INFO)
|
||||
(NOT ALLFLAG))
|
||||
COLLECT (PRINTOUT T .P2 (CAAR INFO)
|
||||
31)
|
||||
(IF (CADR INFO)
|
||||
THEN (PRINTOUT T " = " .P2 (CADDR INFO))
|
||||
(CL:WHEN (OR (CADAR INFO)
|
||||
(CADDAR INFO))
|
||||
(PRINTOUT T 60 (CADAR INFO)
|
||||
%,,
|
||||
(CADDAR INFO))
|
||||
(TERPRI T))
|
||||
ELSE (PRINTOUT T " ~= " -2 "old: " .P2 (CADDR INFO))
|
||||
(CL:WHEN (OR (CADAR INFO)
|
||||
(CADDAR INFO))
|
||||
(PRINTOUT T 60 (CADAR INFO)
|
||||
%,,
|
||||
(CADDAR INFO))
|
||||
(TERPRI T))
|
||||
(PRINTOUT T 37 "new: " .P2 (CADDDR INFO)
|
||||
T))
|
||||
INFO FINALLY (PRINTOUT T SAME " matches, " DIFF " mismatches" T])
|
||||
|
||||
(DT
|
||||
[LAMBDA (STRINGS ALLFLAG) (* ; "Edited 21-Apr-2022 17:53 by rmk")
|
||||
(* ; "Edited 19-Apr-2022 20:55 by rmk")
|
||||
|
||||
(* ;; "Tests the DIRFLG options on STRINGS. If an element of STRINGS is a list, it is assumed to be a (STRING ONEFIELD DIRFLG), STRING is extracted.")
|
||||
|
||||
(SETQ STRINGS (FOR S INSIDE STRINGS COLLECT (CL:IF (LISTP S)
|
||||
(CAR S)
|
||||
S)))
|
||||
[AND NIL (FOR ONEFIELD IN '(NAME DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY)
|
||||
JOIN (FOR DIR ORIG NEW SAME IN '(FIELD RETURN)
|
||||
JOIN (PRINTOUT T T "ONEFIELDFLG = " ONEFIELD -3 "DIRFLG = " DIR T T)
|
||||
(TRYALL STRINGS ALLFLAG ONEFIELD DIR))
|
||||
FINALLY (FOR INFO SAME (DIFF _ 0) IN $$VAL DO (CL:IF (CADR INFO)
|
||||
(ADD SAME 1)
|
||||
(ADD DIFF 1))
|
||||
FINALLY (SETQ SAME (IDIFFERENCE (LENGTH STRINGS)
|
||||
DIFF))
|
||||
(PRINTOUT T T "Overall: " SAME " matched, " DIFF " mismatched" T]
|
||||
(TRYALL (FOR S IN STRINGS JOIN (FOR ONEFIELD IN '(NAME DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY)
|
||||
JOIN (FOR DIR IN '(FIELD RETURN)
|
||||
COLLECT (LIST S ONEFIELD DIR])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (893 18981 (OLD-UNPACKFILENAME.STRING 903 . 17808) (\UPF.NEXTPOS 17810 . 18396) (
|
||||
\UPF.TEMPFILEP 18398 . 18979)) (28216 32820 (TRY 28226 . 29192) (TRYALL 29194 . 31111) (DT 31113 .
|
||||
32818)))))
|
||||
STOP
|
||||
Binary file not shown.
@@ -1,23 +0,0 @@
|
||||
TESTUPF contains functions for testing the new implementation of UNPACKFILENAME.STRING (now in ADIR) and the original definition.
|
||||
|
||||
The original definition is also provided here, under the name OLD-UNPACKFILENAME.STRING
|
||||
|
||||
TESTUPF also includes some test functions, and some of the strings that I have been testing with.
|
||||
|
||||
(TRY FILE ONEDIRFLG DIRFLG)
|
||||
|
||||
returns a comparison of the behavior of the original version and the new version in a list of the form
|
||||
|
||||
(FILE ONEDIRFLG DIRFLG) MATCH ORIG NEW)
|
||||
|
||||
where MATCH is = if ORIG and NEW are EQUAL, otherwise NIL. (For convenience, a list of this form can also be passed in as an argument.)
|
||||
|
||||
(TRYALL FILES ALLFLG ONDIRFLG DIRFLG)
|
||||
|
||||
applies TRY to each file-string in FILES, prints and reports what it discovers. If ALLFLG, it prints the result on every file, otherwise just the mismatches. Value is a list of TRY values that it printed.
|
||||
|
||||
(DT FILES) sets up a call to TRYALL for DIRFLG testing (setting DIRFLG NIL, FIELD, RETURN for each file in FILES).
|
||||
|
||||
The variable TESTS has the strings that I have tested against, the variable DOTTEDNAMES has the strings that I intend to be different (.cshrc as NAME, not EXTENSION). The new behavior avoids the bug that (PACKFILENAME.STRING 'EXTENSION "txt "BODY ".bashrc") produces ".txt" instead of ".bashrc.txt".
|
||||
|
||||
The variable RETURNFAILS is a list of strings with DIRFLG=RETURN that also don¹t match, in that the DIRECTORY and SUBDIRECTORY classifications are inverted between old and new for strings beginning with ª>". But the old code is inconsistent for these inputs: it returns different classifications of those substrings with or without the RETURN. (I think RETURN is for the case "/Users/kaplan" where the caller knows that the whole thing is a directory, doesn¹t want ªkaplanº to be parsed as a name. Just wants it to be normalized, with host and device stripped off.)
|
||||
@@ -1,22 +1,20 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "15-Jan-2022 20:17:21" |{DSK}<home>larry>medley>library>MSCOMMON.;4| 24053
|
||||
(FILECREATED " 2-Nov-2022 10:13:59" |{DSK}<home>larry>ilisp>medley>library>MSCOMMON.;3| 23999
|
||||
|
||||
:CHANGES-TO (TEMPLATES ADD-EXEC CL:ASSOC CL:COMPILE-FILE EXEC CL:IN-PACKAGE CL:MAKE-STRING OPEN
|
||||
CL:PUSH CL:PUSHNEW CL:RASSOC CL:WRITE-LINE CL:WRITE-STRING CL:WHEN CL:UNLESS
|
||||
)
|
||||
(FNS FUNCTIONSMSGETDEF FUNCTIONSMSMC VARIABLESMSGETDEF)
|
||||
(VARS MSCOMMONCOMS)
|
||||
:CHANGES-TO (VARS MSCOMMONCOMS)
|
||||
(TEMPLATES CL:UNLESS CL:WHEN)
|
||||
|
||||
:PREVIOUS-DATE " 4-May-92 13:10:53" |{DSK}<home>larry>medley>library>MSCOMMON.;3|)
|
||||
:PREVIOUS-DATE "15-Jan-2022 20:17:21" |{DSK}<home>larry>ilisp>medley>library>MSCOMMON.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.
|
||||
; Copyright (c) 1988, 1990, 1992, 2022 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT MSCOMMONCOMS)
|
||||
|
||||
(RPAQQ MSCOMMONCOMS
|
||||
((PROP FILETYPE MSCOMMON)
|
||||
(DECLARE\: EVAL@COMPILE (GLOBALVARS USERTEMPLATES MSTEMPLATES))
|
||||
(FNS FUNCTIONSMSGETDEF FUNCTIONSMSMC VARIABLESMSGETDEF)
|
||||
|
||||
(* |;;| "Templates for CL stuff that need them.")
|
||||
@@ -89,6 +87,12 @@
|
||||
(CLRHASH USERTEMPLATES))))
|
||||
|
||||
(PUTPROPS MSCOMMON FILETYPE :COMPILE-FILE)
|
||||
(DECLARE\: EVAL@COMPILE
|
||||
(DECLARE\: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS USERTEMPLATES MSTEMPLATES)
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(FUNCTIONSMSGETDEF
|
||||
@@ -470,13 +474,13 @@
|
||||
|
||||
(SETTEMPLATE 'CL:UNION '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
|
||||
|
||||
(SETTEMPLATE 'CL:UNLESS '(TEST |..| EFECT RETURN))
|
||||
(SETTEMPLATE 'CL:UNLESS '(TEST |..| EFFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'CL:VECTOR-PUSH '(EVAL SMASH))
|
||||
|
||||
(SETTEMPLATE 'CL:VECTOR-PUSH-EXTEND '(EVAL SMASH EVAL))
|
||||
|
||||
(SETTEMPLATE 'CL:WHEN '(TEST |..| EFECT RETURN))
|
||||
(SETTEMPLATE 'CL:WHEN '(TEST |..| EFFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'WRITE '(EVAL KEYWORDS :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE
|
||||
:GENSYM :ARRAY))
|
||||
@@ -552,8 +556,8 @@
|
||||
(PUTHASH KEY VAL MSTEMPLATES)))
|
||||
|
||||
(CLRHASH USERTEMPLATES)
|
||||
(PUTPROPS MSCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
|
||||
(PUTPROPS MSCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992 2022))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (5280 7291 (FUNCTIONSMSGETDEF 5290 . 6258) (FUNCTIONSMSMC 6260 . 6731) (
|
||||
VARIABLESMSGETDEF 6733 . 7289)))))
|
||||
(FILEMAP (NIL (5219 7230 (FUNCTIONSMSGETDEF 5229 . 6197) (FUNCTIONSMSMC 6199 . 6670) (
|
||||
VARIABLESMSGETDEF 6672 . 7228)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Jul-2022 10:42:46"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>library>UNIXCOMM.;6 20326
|
||||
(FILECREATED " 8-Oct-2022 16:06:36" {DSK}<cygdrive>c>Users>Larry>home>medley>library>UNIXCOMM.;2 20352
|
||||
|
||||
:CHANGES-TO (FNS INITIALIZE-NEW-SHELL-DEVICE)
|
||||
:CHANGES-TO (FNS CREATE-PROCESS-STREAM)
|
||||
|
||||
:PREVIOUS-DATE " 3-Jul-2022 16:16:31"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>library>UNIXCOMM.;5)
|
||||
:PREVIOUS-DATE " 7-Jul-2022 10:42:46"
|
||||
{DSK}<cygdrive>c>Users>Larry>home>medley>library>UNIXCOMM.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -133,6 +132,8 @@ Copyright (c) 1988-1990, 2018, 2022 by Venue & Xerox Corporation.
|
||||
(CREATE-PROCESS-STREAM
|
||||
[LAMBDA (COMM)
|
||||
|
||||
(* ;; "Edited 8-Oct-2022 16:04 by lmm")
|
||||
|
||||
(* ;; "Edited 3-Jul-2022 16:04 by rmk: Removed external format here, the device has the environmental defaultg")
|
||||
|
||||
(* ;; "Edited 26-Jun-2022 13:52 by larry")
|
||||
@@ -141,7 +142,7 @@ Copyright (c) 1988-1990, 2018, 2022 by Venue & Xerox Corporation.
|
||||
|
||||
(* ;; "Edited 21-May-90 15:39 by jrb:")
|
||||
|
||||
(LET* ((SHELL-DEV (if (AND (BOUNDP '*NEW-SHELL-DEVICE)
|
||||
(LET* ((SHELL-DEV (if (AND (BOUNDP '*NEW-SHELL-DEVICE*)
|
||||
(SUBRCALL UNIX-HANDLECOMM 8))
|
||||
then (* ;
|
||||
"SUBRCALL tests that this is supported")
|
||||
@@ -455,12 +456,12 @@ Copyright (c) 1988-1990, 2018, 2022 by Venue & Xerox Corporation.
|
||||
(PUTPROPS UNIXCOMM FILETYPE FAKE-COMPILE-FILE)
|
||||
(PUTPROPS UNIXCOMM COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 2018 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2492 8463 (FORK-SHELL 2502 . 3699) (FORK-UNIX 3701 . 3877) (UNIX-KILL 3879 . 4068) (
|
||||
UNIX-WRITE 4070 . 4781) (CREATE-SHELL-STREAM 4783 . 6099) (CREATE-PROCESS-STREAM 6101 . 7560) (
|
||||
UNIXCOMM-AROUNDEXITFN 7562 . 8461)) (8511 13805 (INITIALIZE-NEW-SHELL-DEVICE 8521 . 9920) (
|
||||
UNIX-GET-NEXT-BUFFER 9922 . 12122) (UNIX-BACKFILEPTR-NEW 12124 . 12603) (UNIX-STREAM-EOFP-NEW 12605 .
|
||||
13151) (UNIX-STREAM-OUT 13153 . 13409) (UNIX-STREAM-CLOSE 13411 . 13803)) (14061 15926 (
|
||||
CREATE-UNIX-SOCKET-STREAM 14071 . 14932) (ACCEPT-UNIX-SOCKET-STREAM 14934 . 15924)) (16275 19735 (
|
||||
UNIX-BACKFILEPTR 16285 . 16783) (UNIX-READ 16785 . 17307) (INITIALIZE-SHELL-DEVICE 17309 . 18329) (
|
||||
UNIX-STREAM-IN 18331 . 18707) (UNIX-STREAM-EOFP 18709 . 19483) (UNIX-STREAM-PEEK 19485 . 19733)))))
|
||||
(FILEMAP (NIL (2467 8489 (FORK-SHELL 2477 . 3674) (FORK-UNIX 3676 . 3852) (UNIX-KILL 3854 . 4043) (
|
||||
UNIX-WRITE 4045 . 4756) (CREATE-SHELL-STREAM 4758 . 6074) (CREATE-PROCESS-STREAM 6076 . 7586) (
|
||||
UNIXCOMM-AROUNDEXITFN 7588 . 8487)) (8537 13831 (INITIALIZE-NEW-SHELL-DEVICE 8547 . 9946) (
|
||||
UNIX-GET-NEXT-BUFFER 9948 . 12148) (UNIX-BACKFILEPTR-NEW 12150 . 12629) (UNIX-STREAM-EOFP-NEW 12631 .
|
||||
13177) (UNIX-STREAM-OUT 13179 . 13435) (UNIX-STREAM-CLOSE 13437 . 13829)) (14087 15952 (
|
||||
CREATE-UNIX-SOCKET-STREAM 14097 . 14958) (ACCEPT-UNIX-SOCKET-STREAM 14960 . 15950)) (16301 19761 (
|
||||
UNIX-BACKFILEPTR 16311 . 16809) (UNIX-READ 16811 . 17333) (INITIALIZE-SHELL-DEVICE 17335 . 18355) (
|
||||
UNIX-STREAM-IN 18357 . 18733) (UNIX-STREAM-EOFP 18735 . 19509) (UNIX-STREAM-PEEK 19511 . 19759)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,18 +1,15 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Feb-2022 12:04:09"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>lafite>LAFITESEND.;2 100778
|
||||
(FILECREATED "16-Oct-2022 10:02:19" {DSK}<Users>briggs>projects>medley>library>lafite>LAFITESEND.;2 100794
|
||||
|
||||
:CHANGES-TO (FILES LAFITEDECLS)
|
||||
(FNS \SENDMESSAGE.RESTARTABLE \SENDMESSAGE LAFITE.SENDMESSAGE MAKEXXXSUPPORTFORM
|
||||
MAKENEWMESSAGEFORM MAKEANSWERFORM LAFITE.FILL.IN.ANSWER.FORM MAKEFORWARDFORM)
|
||||
:CHANGES-TO (FNS \SENDMESSAGE.RESTARTABLE)
|
||||
|
||||
:PREVIOUS-DATE "30-Sep-2021 22:58:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>lafite>LAFITESEND.;1)
|
||||
:PREVIOUS-DATE " 7-Feb-2022 12:04:09"
|
||||
{DSK}<Users>briggs>projects>medley>library>lafite>LAFITESEND.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984-1990, 1993, 1999-2000, 2021 by Xerox Corporation.
|
||||
Copyright (c) 1984-1990, 1993, 1999-2000, 2021-2022 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LAFITESENDCOMS)
|
||||
@@ -529,7 +526,8 @@ Copyright (c) 1984-1990, 1993, 1999-2000, 2021 by Xerox Corporation.
|
||||
(RETURN (\SENDMESSAGE.RESTARTABLE FORM TEDITPROPS NIL FORMNAME])
|
||||
|
||||
(\SENDMESSAGE.RESTARTABLE
|
||||
[LAMBDA (FORM TEDITPROPS EDITORWINDOW FORMNAME) (* ; "Edited 7-Feb-2022 11:50 by rmk")
|
||||
[LAMBDA (FORM TEDITPROPS EDITORWINDOW FORMNAME) (* ; "Edited 16-Oct-2022 09:59 by briggs")
|
||||
(* ; "Edited 7-Feb-2022 11:50 by rmk")
|
||||
(* ; "Edited 3-Nov-89 15:06 by bvm")
|
||||
(bind (CURRENTMESSAGE _ FORM)
|
||||
(FIRSTTIME _ T)
|
||||
@@ -558,7 +556,9 @@ Copyright (c) 1984-1990, 1993, 1999-2000, 2021 by Xerox Corporation.
|
||||
EDITORWINDOW))
|
||||
(push LAFITECURRENTEDITORWINDOWS EDITORWINDOW)
|
||||
(SETQ FIRSTTIME)))
|
||||
[SETQ EDITORRESULT (TEDIT (OPENSTRINGSTREAM FORM)
|
||||
[SETQ EDITORRESULT (TEDIT (CL:IF (STRINGP FORM)
|
||||
(OPENSTRINGSTREAM FORM)
|
||||
FORM)
|
||||
EDITORWINDOW T (APPEND TEDITPROPS (LIST 'FONT LAFITEEDITORFONT]
|
||||
(COND
|
||||
((TTY.PROCESSP) (* ; "give back the keyboard")
|
||||
@@ -1764,31 +1764,31 @@ cc: ~A
|
||||
)
|
||||
)
|
||||
(PUTPROPS LAFITESEND COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1993 1999 2000
|
||||
2021))
|
||||
2021 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5539 28516 (DOLAFITESENDINGCOMMAND 5549 . 6039) (\SENDMESSAGE.INITIATE 6041 . 7980) (
|
||||
\SENDMSG.DELIVER 7982 . 8590) (\SENDMSG.EXIT.TEDIT 8592 . 8963) (\SENDMSG.SAVE.FORM 8965 . 10952) (
|
||||
\LAFITE.HEADER.EOF 10954 . 11247) (\LAFITE.INSERT.REPLYTO 11249 . 11857) (\SENDMSG.REPLYTO 11859 .
|
||||
12418) (\SENDMSG.CHANGE.MODE 12420 . 17996) (\SENDMSG.FIND.FIELD 17998 . 18508) (\SENDMESSAGE.PARSE
|
||||
18510 . 19306) (\LAFITE.PREPARE.SEND 19308 . 22141) (\LAFITE.PREPARE.ERROR 22143 . 23325) (
|
||||
\LAFITE.CHOOSE.MSG.FORMAT 23327 . 25968) (LAFITE.MAKE.PLAIN.TEXTSTREAM 25970 . 26895) (
|
||||
\SENDMESSAGE.MENUPROMPT 26897 . 27760) (\SENDMESSAGE.PROMPT 27762 . 28298) (\SENDMESSAGEFAIL 28300 .
|
||||
28514)) (28517 52962 (\SENDMESSAGE 28527 . 29879) (\SENDMESSAGE.RESTARTABLE 29881 . 34865) (
|
||||
\SENDMESSAGE.CLEANUP 34867 . 35083) (\SENDMESSAGE.MAKEWINDOW 35085 . 41258) (MAKELAFITEDELIVERMENU
|
||||
41260 . 41567) (\LAFITE.CLOSEMSG? 41569 . 42519) (\LAFITE.AFTER.DELIVER 42521 . 45840) (
|
||||
\LAFITE.UNSENT.ICON 45842 . 46152) (\LAFITE.FETCH.SUBJECT 46154 . 46954) (LAFITE.SENDMESSAGE 46956 .
|
||||
47849) (\SENDMESSAGE0 47851 . 50715) (LA.ASSURE.PROMPT.WINDOW 50717 . 51614) (\LAFITE.SEND.FAIL 51616
|
||||
. 52087) (\LAFITE.INVALID.RECIPIENTS 52089 . 52547) (\SENDMESSAGE.ABORT 52549 . 52960)) (52994 62907
|
||||
(\OUTBOX.CREATE 53004 . 54467) (\OUTBOX.RESET 54469 . 54962) (\OUTBOX.CLOSEFN 54964 . 55104) (
|
||||
\OUTBOX.REPAINTFN 55106 . 55769) (\OUTBOX.RESHAPEFN 55771 . 57054) (\OUTBOX.SHADEITEM 57056 . 57729) (
|
||||
\OUTBOX.BUTTONFN 57731 . 60579) (\OUTBOX.DISPLAYLINE 60581 . 61075) (\OUTBOX.ADD.ITEM 61077 . 62905))
|
||||
(63203 79611 (\LAFITE.MESSAGEFORM 63213 . 67556) (MAKELAFITESUPPORTFORM 67558 . 67747) (
|
||||
MAKELISPSUPPORTFORM 67749 . 67915) (MAKEXXXSUPPORTFORM 67917 . 71966) (MAKENEWMESSAGEFORM 71968 .
|
||||
72924) (MAKELAFITEPRIVATEFORMSITEMS 72926 . 73354) (\LAFITE.UNCACHE.MESSAGEFORM 73356 . 73809) (
|
||||
\LAFITE.DELETE.MESSAGEFORM 73811 . 74412) (\LAFITE.SELECT.FORM 74414 . 74769) (
|
||||
\LAFITE.DELETE.FORM.INTERNAL 74771 . 75915) (\LAFITE.READ.FORM 75917 . 78654) (\LAFITE.FIND.TEMPLATE
|
||||
78656 . 79609)) (79635 87366 (\LAFITE.ANSWER 79645 . 80050) (\LAFITE.ANSWER.PROC 80052 . 81946) (
|
||||
MAKEANSWERFORM 81948 . 84478) (LA.PRINT.COMMA.LIST 84480 . 84966) (LAFITE.FILL.IN.ANSWER.FORM 84968 .
|
||||
87364)) (87391 93587 (\LAFITE.FORWARD 87401 . 87809) (\LAFITE.FORWARD.PROC 87811 . 89800) (
|
||||
MAKEFORWARDFORM 89802 . 93585)))))
|
||||
(FILEMAP (NIL (5333 28310 (DOLAFITESENDINGCOMMAND 5343 . 5833) (\SENDMESSAGE.INITIATE 5835 . 7774) (
|
||||
\SENDMSG.DELIVER 7776 . 8384) (\SENDMSG.EXIT.TEDIT 8386 . 8757) (\SENDMSG.SAVE.FORM 8759 . 10746) (
|
||||
\LAFITE.HEADER.EOF 10748 . 11041) (\LAFITE.INSERT.REPLYTO 11043 . 11651) (\SENDMSG.REPLYTO 11653 .
|
||||
12212) (\SENDMSG.CHANGE.MODE 12214 . 17790) (\SENDMSG.FIND.FIELD 17792 . 18302) (\SENDMESSAGE.PARSE
|
||||
18304 . 19100) (\LAFITE.PREPARE.SEND 19102 . 21935) (\LAFITE.PREPARE.ERROR 21937 . 23119) (
|
||||
\LAFITE.CHOOSE.MSG.FORMAT 23121 . 25762) (LAFITE.MAKE.PLAIN.TEXTSTREAM 25764 . 26689) (
|
||||
\SENDMESSAGE.MENUPROMPT 26691 . 27554) (\SENDMESSAGE.PROMPT 27556 . 28092) (\SENDMESSAGEFAIL 28094 .
|
||||
28308)) (28311 52973 (\SENDMESSAGE 28321 . 29673) (\SENDMESSAGE.RESTARTABLE 29675 . 34876) (
|
||||
\SENDMESSAGE.CLEANUP 34878 . 35094) (\SENDMESSAGE.MAKEWINDOW 35096 . 41269) (MAKELAFITEDELIVERMENU
|
||||
41271 . 41578) (\LAFITE.CLOSEMSG? 41580 . 42530) (\LAFITE.AFTER.DELIVER 42532 . 45851) (
|
||||
\LAFITE.UNSENT.ICON 45853 . 46163) (\LAFITE.FETCH.SUBJECT 46165 . 46965) (LAFITE.SENDMESSAGE 46967 .
|
||||
47860) (\SENDMESSAGE0 47862 . 50726) (LA.ASSURE.PROMPT.WINDOW 50728 . 51625) (\LAFITE.SEND.FAIL 51627
|
||||
. 52098) (\LAFITE.INVALID.RECIPIENTS 52100 . 52558) (\SENDMESSAGE.ABORT 52560 . 52971)) (53005 62918
|
||||
(\OUTBOX.CREATE 53015 . 54478) (\OUTBOX.RESET 54480 . 54973) (\OUTBOX.CLOSEFN 54975 . 55115) (
|
||||
\OUTBOX.REPAINTFN 55117 . 55780) (\OUTBOX.RESHAPEFN 55782 . 57065) (\OUTBOX.SHADEITEM 57067 . 57740) (
|
||||
\OUTBOX.BUTTONFN 57742 . 60590) (\OUTBOX.DISPLAYLINE 60592 . 61086) (\OUTBOX.ADD.ITEM 61088 . 62916))
|
||||
(63214 79622 (\LAFITE.MESSAGEFORM 63224 . 67567) (MAKELAFITESUPPORTFORM 67569 . 67758) (
|
||||
MAKELISPSUPPORTFORM 67760 . 67926) (MAKEXXXSUPPORTFORM 67928 . 71977) (MAKENEWMESSAGEFORM 71979 .
|
||||
72935) (MAKELAFITEPRIVATEFORMSITEMS 72937 . 73365) (\LAFITE.UNCACHE.MESSAGEFORM 73367 . 73820) (
|
||||
\LAFITE.DELETE.MESSAGEFORM 73822 . 74423) (\LAFITE.SELECT.FORM 74425 . 74780) (
|
||||
\LAFITE.DELETE.FORM.INTERNAL 74782 . 75926) (\LAFITE.READ.FORM 75928 . 78665) (\LAFITE.FIND.TEMPLATE
|
||||
78667 . 79620)) (79646 87377 (\LAFITE.ANSWER 79656 . 80061) (\LAFITE.ANSWER.PROC 80063 . 81957) (
|
||||
MAKEANSWERFORM 81959 . 84489) (LA.PRINT.COMMA.LIST 84491 . 84977) (LAFITE.FILL.IN.ANSWER.FORM 84979 .
|
||||
87375)) (87402 93598 (\LAFITE.FORWARD 87412 . 87820) (\LAFITE.FORWARD.PROC 87822 . 89811) (
|
||||
MAKEFORWARDFORM 89813 . 93596)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "11-Aug-2022 21:10:25"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;249 128449
|
||||
(FILECREATED " 3-Oct-2022 12:03:37"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;252 128695
|
||||
|
||||
:CHANGES-TO (FNS CDBROWSER.STRINGS)
|
||||
:CHANGES-TO (FNS CDFILES)
|
||||
|
||||
:PREVIOUS-DATE "25-Jul-2022 15:31:50"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>release-medley>lispusers>COMPAREDIRECTORIES.;1)
|
||||
:PREVIOUS-DATE "14-Aug-2022 12:13:45"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>COMPAREDIRECTORIES.;250)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -388,7 +388,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(DEFINEQ
|
||||
|
||||
(CDFILES
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 25-Apr-2022 08:42 by rmk")
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 3-Oct-2022 12:03 by rmk")
|
||||
(* ; "Edited 25-Apr-2022 08:42 by rmk")
|
||||
(* ; "Edited 5-Mar-2022 15:05 by rmk")
|
||||
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
|
||||
|
||||
@@ -416,6 +417,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(SETQ EXCLUDEDFILES (LDIFFERENCE EXCLUDEDFILES INCLUDEDFILES))
|
||||
(LET ([INCLUDES (CDFILES.PATS (OR INCLUDEDFILES '*.*]
|
||||
(EXCLUDES (AND EXCLUDEDFILES (CDFILES.PATS EXCLUDEDFILES)))
|
||||
(*UPPER-CASE-FILE-NAMES* NIL)
|
||||
HOST ENUMPAT)
|
||||
(SETQ HOST (FILENAMEFIELD.STRING DIR 'HOST))
|
||||
(SETQ DIR (FILENAMEFIELD.STRING DIR 'DIRECTORY))
|
||||
@@ -1707,7 +1709,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
BROWSER)])
|
||||
|
||||
(CDBROWSER.STRINGS
|
||||
[LAMBDA (CDVALUE COLHEADINGS SEPARATEDIRECTIONS) (* ; "Edited 11-Aug-2022 20:23 by rmk")
|
||||
[LAMBDA (CDVALUE COLHEADINGS SEPARATEDIRECTIONS) (* ; "Edited 14-Aug-2022 12:13 by rmk")
|
||||
(* ; "Edited 11-Aug-2022 20:23 by rmk")
|
||||
(* ; "Edited 25-Jul-2022 15:31 by rmk")
|
||||
(* ; "Edited 20-Jul-2022 21:14 by rmk")
|
||||
(* ; "Edited 22-Feb-2022 18:30 by rmk")
|
||||
@@ -1759,8 +1762,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(* ;; "Stick a blank object between")
|
||||
|
||||
(SETQ PAIRS (NCONC (DREVERSE L2R)
|
||||
[APPEND '(("")
|
||||
(""]
|
||||
[COPY '(("")
|
||||
(""]
|
||||
(DREVERSE R2L)))))
|
||||
(CL:WHEN COLHEADERS
|
||||
(PUSH PAIRS (LIST COLHEADERS)))
|
||||
@@ -2154,25 +2157,25 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998
|
||||
2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2632 22189 (COMPAREDIRECTORIES 2642 . 7475) (COMPAREDIRECTORIES.INFOS 7477 . 10351) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10353 . 13738) (CDENTRIES.SELECT 13740 . 18515) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 18517 . 19423) (MATCHNAME 19425 . 20105) (CD.INSURECDVALUE 20107 . 21721
|
||||
) (CD.UPDATEWIDTHS 21723 . 22187)) (22190 31859 (CDFILES 22200 . 27953) (CDFILES.MATCH 27955 . 29580)
|
||||
(CDFILES.PATS 29582 . 31857)) (31860 49681 (CDPRINT 31870 . 34387) (CDPRINT.HEADER 34389 . 35286) (
|
||||
CDPRINT.LINE 35288 . 38520) (CDPRINT.MAXWIDTHS 38522 . 42637) (CDPRINT.COLHEADERS 42639 . 43924) (
|
||||
CDPRINT.COLUMNS 43926 . 49046) (CDTEDIT 49048 . 49679)) (49682 58051 (CDMAP 49692 . 51124) (CDENTRY
|
||||
51126 . 51435) (CDSUBSET 51437 . 52876) (CDMERGE 52878 . 56732) (CDMERGE.COMMON 56734 . 58049)) (58052
|
||||
65590 (BINCOMP 58062 . 62351) (EOLTYPE 62353 . 64915) (EOLTYPE.SHOW 64917 . 65588)) (66118 78645 (
|
||||
FIND-UNCOMPILED-FILES 66128 . 69771) (FIND-UNSOURCED-FILES 69773 . 72157) (FIND-SOURCE-FILES 72159 .
|
||||
73897) (FIND-COMPILED-FILES 73899 . 75776) (FIND-UNLOADED-FILES 75778 . 76631) (FIND-LOADED-FILES
|
||||
76633 . 77061) (FIND-MULTICOMPILED-FILES 77063 . 78643)) (78646 87077 (CREATED-AS 78656 . 83453) (
|
||||
SOURCE-FOR-COMPILED-P 83455 . 86382) (COMPILE-SOURCE-DATE-DIFF 86384 . 87075)) (87078 97384 (
|
||||
FIX-DIRECTORY-DATES 87088 . 90081) (FIX-EQUIV-DATES 90083 . 91608) (COPY-COMPARED-FILES 91610 . 93431)
|
||||
(COPY-MISSING-FILES 93433 . 95590) (COMPILED-ON-SAME-SOURCE 95592 . 97382)) (97578 105311 (CDBROWSER
|
||||
97588 . 101515) (CDBROWSER.STRINGS 101517 . 105309)) (105473 107209 (CD.TABLEITEM 105483 . 105703) (
|
||||
CD.TABLEITEM.PRINTFN 105705 . 105904) (CD.TABLEITEM.COPYFN 105906 . 106964) (
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN 106966 . 107207)) (107210 127865 (CDTABLEBROWSER.WHENSELECTEDFN
|
||||
107220 . 107688) (CD.COMMANDSELECTEDFN 107690 . 112791) (CD-MENUFN 112793 . 117104) (CD-COMPARE-FILES
|
||||
117106 . 120458) (CDBROWSER-COPY 120460 . 124129) (CDBROWSER-DELETE-FILE 124131 . 127344) (CD-SWAPDIRS
|
||||
127346 . 127863)))))
|
||||
(FILEMAP (NIL (2624 22181 (COMPAREDIRECTORIES 2634 . 7467) (COMPAREDIRECTORIES.INFOS 7469 . 10343) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10345 . 13730) (CDENTRIES.SELECT 13732 . 18507) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 18509 . 19415) (MATCHNAME 19417 . 20097) (CD.INSURECDVALUE 20099 . 21713
|
||||
) (CD.UPDATEWIDTHS 21715 . 22179)) (22182 32000 (CDFILES 22192 . 28094) (CDFILES.MATCH 28096 . 29721)
|
||||
(CDFILES.PATS 29723 . 31998)) (32001 49822 (CDPRINT 32011 . 34528) (CDPRINT.HEADER 34530 . 35427) (
|
||||
CDPRINT.LINE 35429 . 38661) (CDPRINT.MAXWIDTHS 38663 . 42778) (CDPRINT.COLHEADERS 42780 . 44065) (
|
||||
CDPRINT.COLUMNS 44067 . 49187) (CDTEDIT 49189 . 49820)) (49823 58192 (CDMAP 49833 . 51265) (CDENTRY
|
||||
51267 . 51576) (CDSUBSET 51578 . 53017) (CDMERGE 53019 . 56873) (CDMERGE.COMMON 56875 . 58190)) (58193
|
||||
65731 (BINCOMP 58203 . 62492) (EOLTYPE 62494 . 65056) (EOLTYPE.SHOW 65058 . 65729)) (66259 78786 (
|
||||
FIND-UNCOMPILED-FILES 66269 . 69912) (FIND-UNSOURCED-FILES 69914 . 72298) (FIND-SOURCE-FILES 72300 .
|
||||
74038) (FIND-COMPILED-FILES 74040 . 75917) (FIND-UNLOADED-FILES 75919 . 76772) (FIND-LOADED-FILES
|
||||
76774 . 77202) (FIND-MULTICOMPILED-FILES 77204 . 78784)) (78787 87218 (CREATED-AS 78797 . 83594) (
|
||||
SOURCE-FOR-COMPILED-P 83596 . 86523) (COMPILE-SOURCE-DATE-DIFF 86525 . 87216)) (87219 97525 (
|
||||
FIX-DIRECTORY-DATES 87229 . 90222) (FIX-EQUIV-DATES 90224 . 91749) (COPY-COMPARED-FILES 91751 . 93572)
|
||||
(COPY-MISSING-FILES 93574 . 95731) (COMPILED-ON-SAME-SOURCE 95733 . 97523)) (97719 105557 (CDBROWSER
|
||||
97729 . 101656) (CDBROWSER.STRINGS 101658 . 105555)) (105719 107455 (CD.TABLEITEM 105729 . 105949) (
|
||||
CD.TABLEITEM.PRINTFN 105951 . 106150) (CD.TABLEITEM.COPYFN 106152 . 107210) (
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN 107212 . 107453)) (107456 128111 (CDTABLEBROWSER.WHENSELECTEDFN
|
||||
107466 . 107934) (CD.COMMANDSELECTEDFN 107936 . 113037) (CD-MENUFN 113039 . 117350) (CD-COMPARE-FILES
|
||||
117352 . 120704) (CDBROWSER-COPY 120706 . 124375) (CDBROWSER-DELETE-FILE 124377 . 127590) (CD-SWAPDIRS
|
||||
127592 . 128109)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
247
lispusers/GITFNS
247
lispusers/GITFNS
@@ -1,13 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "11-Aug-2022 17:54:59"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>GITFNS.;444 115395
|
||||
(FILECREATED " 1-Oct-2022 12:14:04" {WMEDLEY}<lispusers>GITFNS.;5 118357
|
||||
|
||||
:CHANGES-TO (FNS GIT-MAKE-PROJECT GIT-INIT)
|
||||
(VARS GITFNSCOMS)
|
||||
:CHANGES-TO (FNS GIT-INIT)
|
||||
|
||||
:PREVIOUS-DATE "25-Jul-2022 15:14:26"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>release-medley>lispusers>GITFNS.;1)
|
||||
:PREVIOUS-DATE "29-Sep-2022 10:52:34" {DSK}<home>frank>il>medley>wmedley>lispusers>GITFNS.;4)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT GITFNSCOMS)
|
||||
@@ -26,13 +23,13 @@
|
||||
|
||||
(COMS (FNS GIT-CLONEP GIT-INIT GIT-MAKE-PROJECT GIT-GET-PROJECT GIT-PROJECT-PATH
|
||||
FIND-ANCESTOR-DIRECTORY GIT-FIND-CLONE GIT-MAINBRANCH GIT-MAINBRANCH?)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS GIT-PROJECT))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS GIT-PROJECT PULLREQUEST))
|
||||
(INITVARS (GIT-DEFAULT-PROJECT 'MEDLEY)
|
||||
[GIT-DEFAULT-PROJECTS '((MEDLEY T T
|
||||
(EXPORTS.ALL RDSYS RDSYS.LCOM loadups/ patches/
|
||||
tmp/ fontsold/ clos/ cltl2/)
|
||||
(greetfiles scripts sources library lispusers
|
||||
internal doctools eooma))
|
||||
internal doctools rooms))
|
||||
(NOTECARDS T T)
|
||||
(LOOPS T T)
|
||||
(TEST T T]
|
||||
@@ -152,9 +149,10 @@
|
||||
ELSE (ERROR "NOT A GIT CLONE" HOST/DIR])
|
||||
|
||||
(GIT-INIT
|
||||
[LAMBDA (EVENT) (* ; "Edited 8-Aug-2022 21:52 by lmm")
|
||||
[LAMBDA (EVENT) (* ; "Edited 1-Oct-2022 12:13 by FGH")
|
||||
(* ; "Edited 8-Aug-2022 21:52 by lmm")
|
||||
(SELECTQ EVENT
|
||||
((NIL AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM)
|
||||
((NIL AFTERMAKESYS AFTERSYSOUT)
|
||||
(SETQ GIT-PROJECTS NIL)
|
||||
(for X in GIT-DEFAULT-PROJECTS do (APPLY (FUNCTION GIT-MAKE-PROJECT)
|
||||
X))
|
||||
@@ -370,8 +368,10 @@
|
||||
MB)])
|
||||
|
||||
(GIT-MAINBRANCH?
|
||||
[LAMBDA (BRANCH PROJECT NOERROR) (* ; "Edited 9-May-2022 15:06 by rmk")
|
||||
(IF (STRING.EQUAL (STRIPWHERE (GIT-MAINBRANCH PROJECT NIL T))
|
||||
[LAMBDA (BRANCH PROJECT NOERROR) (* ; "Edited 9-Aug-2022 10:40 by rmk")
|
||||
(* ; "Edited 9-May-2022 15:06 by rmk")
|
||||
(IF (STRING.EQUAL (STRIPWHERE (GIT-MAINBRANCH PROJECT NIL T)
|
||||
T)
|
||||
(STRIPWHERE BRANCH))
|
||||
ELSEIF NOERROR
|
||||
THEN NIL
|
||||
@@ -381,6 +381,8 @@
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(TYPERECORD GIT-PROJECT (PROJECTNAME GITHOST WHOST EXCLUSIONS DEFAULTSUBDIRS CLONEPATH MAINBRANCH))
|
||||
|
||||
(RECORD PULLREQUEST (PRNUMBER PRDESCRIPTION PRNAME PRSTATUS))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -388,7 +390,7 @@
|
||||
|
||||
(RPAQ? GIT-DEFAULT-PROJECTS
|
||||
'((MEDLEY T T (EXPORTS.ALL RDSYS RDSYS.LCOM loadups/ patches/ tmp/ fontsold/ clos/ cltl2/)
|
||||
(greetfiles scripts sources library lispusers internal doctools eooma))
|
||||
(greetfiles scripts sources library lispusers internal doctools rooms))
|
||||
(NOTECARDS T T)
|
||||
(LOOPS T T)
|
||||
(TEST T T)))
|
||||
@@ -473,8 +475,8 @@
|
||||
(IF PRS
|
||||
THEN (CL:WHEN (OR RB (SETQ RB (GIT-PICK-BRANCH (GIT-PRC-MENU DR PROJECT PRS)
|
||||
"Pull requests")))
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES RB (GIT-MAINBRANCH PROJECT)
|
||||
NIL PROJECT))
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES (GIT-MAINBRANCH PROJECT)
|
||||
RB NIL PROJECT))
|
||||
ELSE "No open pull requests")))
|
||||
|
||||
(DEFCOMMAND cob (BRANCH NEXTTITLESTRING PROJECT)
|
||||
@@ -726,9 +728,17 @@
|
||||
NIL])
|
||||
|
||||
(STRIPWHERE
|
||||
[LAMBDA (BRANCH) (* ; "Edited 9-May-2022 14:31 by rmk")
|
||||
[LAMBDA (BRANCH ORIGINTOO) (* ; "Edited 9-Aug-2022 10:39 by rmk")
|
||||
(* ; "Edited 4-Aug-2022 10:31 by rmk")
|
||||
(* ; "Edited 9-May-2022 14:31 by rmk")
|
||||
|
||||
(* ;; "Leave origin/ unless ORIGINTOO")
|
||||
|
||||
(LET ((POS (STRPOS "/" BRANCH)))
|
||||
(CL:IF POS
|
||||
(CL:IF [AND POS (MEMB [L-CASE (MKATOM (SUBSTRING BRANCH 1 (SUB1 POS]
|
||||
(CL:IF ORIGINTOO
|
||||
'(local origin)
|
||||
'(local))]
|
||||
(SUBSTRING BRANCH (ADD1 POS))
|
||||
BRANCH)])
|
||||
)
|
||||
@@ -982,6 +992,10 @@
|
||||
(GIT-BRANCH-DIFF
|
||||
[LAMBDA (BRANCH1 BRANCH2 PROJECT)
|
||||
|
||||
(* ;; "Edited 29-Sep-2022 10:52 by rmk")
|
||||
|
||||
(* ;; "Edited 12-Sep-2022 14:13 by rmk")
|
||||
|
||||
(* ;; "Edited 17-Jul-2022 09:36 by rmk")
|
||||
|
||||
(* ;; "Edited 4-Jun-2022 20:43 by rmk")
|
||||
@@ -996,18 +1010,20 @@
|
||||
(SETQ BRANCH1 (GIT-MAINBRANCH PROJECT)))
|
||||
(CL:UNLESS BRANCH2
|
||||
(SETQ BRANCH2 (GIT-MAINBRANCH PROJECT)))
|
||||
(GIT-REMOTE-UPDATE NIL PROJECT) (* (* ;; "Returns the status (M, R, D, A, C), but not sure what comparison is used for the letters. With --name-only, you just get the list of files in the commit. (GIT-COMMIT-DIFFS gives the commits that differ between 2 branches. But what if a given file shows up in 2 different commits in a sequence? E.g. it was changed and then deleted? For each files we can calculate the sequence of changes and figure out what the net effect is? e.g (file D (R file2) (C file3) A) would say that that file didn't exist at the beginning and doesn't exist at the end, so don't report it?")
|
||||
(GIT-COMMAND (CONCAT
|
||||
"git diff-tree --no-commit-id --name-STATUS -r "
|
||||
COMMIT) NIL NIL PROJECT))
|
||||
(GIT-REMOTE-UPDATE NIL PROJECT)
|
||||
|
||||
(* ;; "We don't use GIT-COMMAND because we want to deal with the warning messages here, to give the option of increasing the rename limit..")
|
||||
|
||||
(PROG (POS LIMIT ERRORFILE RLINES ELINES RESULTFILE)
|
||||
RETRY
|
||||
|
||||
|
||||
(* ;; "Nick previously suggested: %"git diff --name-status -C --find-copies-harder <merge> branch1%", but that brought in too many files. The merge-base seems to match the Git desktop.")
|
||||
|
||||
(SETQ RESULTFILE (GIT-COMMAND-TO-FILE (CONCAT
|
||||
"git diff --name-status -C --find-copies-harder "
|
||||
BRANCH1 " " BRANCH2)
|
||||
"git diff -C --find-copies-harder $(git merge-base "
|
||||
BRANCH1 " " BRANCH2 ") " BRANCH2
|
||||
" --name-status")
|
||||
PROJECT))
|
||||
(SETQ ELINES NIL)
|
||||
(SETQ RLINES NIL)
|
||||
@@ -1085,7 +1101,8 @@
|
||||
NIL NIL PROJECT])
|
||||
|
||||
(GIT-BRANCH-RELATIONS
|
||||
[LAMBDA (BRANCHES BRANCH2 STRIPWHERE PROJECT) (* ; "Edited 29-May-2022 21:59 by rmk")
|
||||
[LAMBDA (BRANCHES BRANCH2 STRIPWHERE PROJECT) (* ; "Edited 4-Aug-2022 10:38 by rmk")
|
||||
(* ; "Edited 29-May-2022 21:59 by rmk")
|
||||
(* ; "Edited 9-May-2022 16:12 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
|
||||
@@ -1093,8 +1110,12 @@
|
||||
|
||||
(LET
|
||||
((MAIN (GIT-MAINBRANCH PROJECT)))
|
||||
(CL:WHEN STRIPWHERE
|
||||
(SETQ MAIN (STRIPWHERE MAIN)))
|
||||
(FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
|
||||
ON (FOR B IN BRANCHES COLLECT (CONS B (GIT-COMMIT-DIFFS B MAIN PROJECT)))
|
||||
ON (FOR B IN BRANCHES COLLECT (CL:WHEN STRIPWHERE
|
||||
(SETQ B (STRIPWHERE B)))
|
||||
(CONS B (GIT-COMMIT-DIFFS B MAIN PROJECT)))
|
||||
DO
|
||||
(* ;; "For each branch we now have the list of commit identifiers (hexstrings) that they do not share with the main branch.")
|
||||
|
||||
@@ -1231,7 +1252,8 @@
|
||||
NIL])
|
||||
|
||||
(GIT-BRANCHES
|
||||
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 18-Jul-2022 08:11 by rmk")
|
||||
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 9-Aug-2022 10:45 by rmk")
|
||||
(* ; "Edited 18-Jul-2022 08:11 by rmk")
|
||||
(* ; "Edited 8-Jul-2022 10:33 by rmk")
|
||||
(* ; "Edited 23-May-2022 14:25 by rmk")
|
||||
(* ; "Edited 19-May-2022 10:06 by rmk")
|
||||
@@ -1253,6 +1275,8 @@
|
||||
0])]
|
||||
BRANCHES)
|
||||
(SETQ BRANCHES (UNION LOCAL REMOTE))
|
||||
(CL:WHEN (THEREIS B IN BRANCHES SUCHTHAT (STRPOS "HEAD detached" B))
|
||||
(PRINTOUT T "Execute %"git gc%" to eliminate a branch with a detached HEAD" T))
|
||||
(CL:WHEN EXCLUDEMERGED
|
||||
(SETQ BRANCHES (FOR B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) IN BRANCHES
|
||||
WHEN (EQUAL (GIT-COMMAND (CONCAT "git merge-base " B " " MAINBRANCH))
|
||||
@@ -1282,53 +1306,64 @@
|
||||
MENUFONT _ DEFAULTFONT)))])
|
||||
|
||||
(GIT-PRC-MENU
|
||||
[LAMBDA (DRAFT PROJECT PRS) (* ; "Edited 9-Jul-2022 19:01 by rmk")
|
||||
[LAMBDA (DRAFT PROJECT PRS) (* ; "Edited 8-Aug-2022 18:15 by rmk")
|
||||
(* ; "Edited 4-Aug-2022 18:55 by rmk")
|
||||
(* ; "Edited 9-Jul-2022 19:01 by rmk")
|
||||
(* ; "Edited 16-May-2022 19:44 by rmk")
|
||||
(CL:UNLESS PRS
|
||||
(SETQ PRS (GIT-PULL-REQUESTS T DRAFT PROJECT)))
|
||||
(CL:WHEN PRS
|
||||
(LET ((RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS COLLECT (GITORIGIN (CADDR PR)))
|
||||
NIL T PROJECT)))
|
||||
(SORT [FOR PR REL LABEL (SUPERSETS _ (CAR RELATIONS))
|
||||
(SORT [FOR PR REL LABEL PRNAME (SUPERSETS _ (CAR RELATIONS))
|
||||
(EQUALS _ (CADR RELATIONS)) IN PRS
|
||||
COLLECT (SETQ LABEL (IF [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
|
||||
SUPERSETS]
|
||||
THEN (CONCAT (CADDR PR)
|
||||
" > " REL)
|
||||
ELSEIF [SETQ REL (CAR (CDR (SASSOC (CADDR PR)
|
||||
EQUALS]
|
||||
THEN (CONCAT (CADDR PR)
|
||||
" = " REL)
|
||||
ELSE (CADDR PR)))
|
||||
(LIST (CL:IF (MEMB 'DRAFT PR)
|
||||
COLLECT (SETQ PRNAME (fetch PRNAME of PR))
|
||||
(SETQ LABEL (CONCAT "#" (fetch (PULLREQUEST PRNUMBER) of PR)
|
||||
" "
|
||||
(IF [SETQ REL (CAR (CDR (SASSOC PRNAME SUPERSETS]
|
||||
THEN (CONCAT PRNAME " > " REL)
|
||||
ELSEIF [SETQ REL (CAR (CDR (SASSOC PRNAME EQUALS]
|
||||
THEN (CONCAT PRNAME " = " REL)
|
||||
ELSE PRNAME)))
|
||||
(LIST (CL:IF (EQ 'DRAFT (FETCH PRSTATUS OF PR))
|
||||
(CONCAT LABEL " (draft)")
|
||||
LABEL)
|
||||
(GITORIGIN (CADDR PR))
|
||||
(CONCAT " " (CADR PR)
|
||||
(GITORIGIN PRNAME)
|
||||
(CONCAT " " (FETCH PRDESCRIPTION OF PR)
|
||||
" #"
|
||||
(CAR PR]
|
||||
(FETCH PRNUMBER OF PR]
|
||||
T)))])
|
||||
|
||||
(GIT-PULL-REQUESTS
|
||||
[LAMBDA (ALLINFO INCLUDEDRAFTS PROJECT) (* ; "Edited 17-Jul-2022 11:12 by rmk")
|
||||
[LAMBDA (ALLINFO INCLUDEDRAFTS PROJECT) (* ; "Edited 8-Aug-2022 13:12 by rmk")
|
||||
(* ; "Edited 4-Aug-2022 19:01 by rmk")
|
||||
(* ; "Edited 17-Jul-2022 11:12 by rmk")
|
||||
(* ; "Edited 9-May-2022 16:54 by rmk")
|
||||
(* ; "Edited 25-Feb-2022 09:26 by rmk")
|
||||
(CL:UNLESS (EQ 0 (PROCESS-COMMAND "command -v gh"))
|
||||
(ERROR "gh must be installed in order to enumerate pull requests:"))
|
||||
(FOR LINE TAB1 TAB2 TAB3 VAL IN (GIT-COMMAND "gh pr list" T NIL PROJECT)
|
||||
(FOR LINE PR TAB1 TAB2 TAB3 VAL IN (GIT-COMMAND "gh pr list" T NIL PROJECT)
|
||||
WHEN [AND (SETQ TAB1 (STRPOS " " LINE))
|
||||
(SETQ TAB2 (STRPOS " " LINE (ADD1 TAB1)))
|
||||
(SETQ TAB3 (STRPOS " " LINE (ADD1 TAB2)))
|
||||
(OR INCLUDEDRAFTS (NEQ 'DRAFT (SUBATOM LINE (ADD1 TAB3]
|
||||
COLLECT (IF ALLINFO
|
||||
THEN `[,(SUBATOM LINE 1 (SUB1 TAB1))
|
||||
,(SUBSTRING LINE (ADD1 TAB1)
|
||||
(SUB1 TAB2))
|
||||
,(SUBSTRING LINE (ADD1 TAB2)
|
||||
(SUB1 TAB3))
|
||||
,(SUBATOM LINE (ADD1 TAB3]
|
||||
ELSE (SUBATOM LINE (ADD1 TAB2)
|
||||
(SUB1 TAB3])
|
||||
COLLECT [SETQ PR (IF ALLINFO
|
||||
THEN (CREATE PULLREQUEST
|
||||
PRNUMBER _ (SUBATOM LINE 1 (SUB1 TAB1))
|
||||
PRDESCRIPTION _ (SUBSTRING LINE (ADD1 TAB1)
|
||||
(SUB1 TAB2))
|
||||
PRNAME _ (SUBSTRING LINE (ADD1 TAB2)
|
||||
(SUB1 TAB3))
|
||||
PRSTATUS _ (SUBATOM LINE (ADD1 TAB3)))
|
||||
ELSE (CREATE PULLREQUEST
|
||||
PRNAME _ (SUBSTRING LINE (ADD1 TAB2)
|
||||
(SUB1 TAB3]
|
||||
(CL:WHEN (STRPOS ":" (fetch (PULLREQUEST PRNAME) of PR))
|
||||
(PRINTOUT T "Ignoring PR for forked repo %%%"" (fetch (PULLREQUEST PRNAME)
|
||||
of PR)
|
||||
"%"" T)
|
||||
(GO $$ITERATE))
|
||||
PR])
|
||||
|
||||
(GIT-SHORT-BRANCH-NAME
|
||||
[LAMBDA (BRANCH) (* ; "Edited 22-May-2022 22:36 by rmk")
|
||||
@@ -1502,6 +1537,8 @@
|
||||
[LAMBDA (BRANCH1 BRANCH2 DIR1 DIR2 PROJECT)
|
||||
(DECLARE (USEDFREE FROMGITN))
|
||||
|
||||
(* ;; "Edited 12-Sep-2022 14:58 by rmk")
|
||||
|
||||
(* ;; "Edited 21-May-2022 23:38 by rmk")
|
||||
|
||||
(* ;; "Edited 9-May-2022 14:17 by rmk: Ask git for the files that differ between the branches, copy those files down to local DIR1 and DIR2, return the directories and a list of (dir1-file1 file2) mappings for renamed and copied files.")
|
||||
@@ -1561,8 +1598,8 @@
|
||||
|
||||
(* ;; "For copied files, presumably 2 files are exactly the same. But we hope we can show them on the same line, by virtue of the mapping.")
|
||||
|
||||
(LET ((GFILE (CDR D))
|
||||
F1)
|
||||
[LET ((GFILE (CDR D))
|
||||
F1 F1)
|
||||
|
||||
(* ;; "GFILE is a triple (F2 F1 N )")
|
||||
|
||||
@@ -1571,31 +1608,41 @@
|
||||
(SETQ F1 (GIT-GET-FILE BRANCH1 (CADR GFILE)
|
||||
(CONCAT DIR1 (CADR GFILE))
|
||||
T PROJECT))
|
||||
(IF (EQ (CADDR GFILE)
|
||||
100)
|
||||
THEN
|
||||
(SETQ F2 (GIT-GET-FILE BRANCH2 (CADR GFILE)
|
||||
(CONCAT DIR2 (CADR GFILE))
|
||||
T PROJECT))
|
||||
|
||||
(* ;; "Let the directories figure it out")
|
||||
|
||||
(AND NIL (IF (EQ (CADDR GFILE)
|
||||
100)
|
||||
THEN
|
||||
|
||||
(* ;; "A little tricky to figure out what corresponds to the real file in the mapping, which directory it belongs to. Maybe the first one should always be one that exists, the second may just be a useful name. But we have to know whether to match against INFO1 or INFO2")
|
||||
|
||||
(PUSH MAPPINGS (LIST (FULLNAME F1)
|
||||
(HELP GFILE 100)
|
||||
(PUSH MAPPINGS
|
||||
(LIST (LIST)
|
||||
(FULLNAME F1)
|
||||
(SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE))
|
||||
)
|
||||
T)
|
||||
(NTHCHAR (CAR D)
|
||||
1)
|
||||
100))
|
||||
ELSE
|
||||
(* ;;
|
||||
ELSE
|
||||
(* ;;
|
||||
"If not a perfect match, then the directory should figure it out")
|
||||
|
||||
(GIT-GET-FILE BRANCH2 (CAR GFILE)
|
||||
(CONCAT DIR2 (CAR GFILE))
|
||||
T PROJECT))))
|
||||
(GIT-GET-FILE BRANCH2 (CAR GFILE)
|
||||
(CONCAT DIR2 (CAR GFILE))
|
||||
T PROJECT])
|
||||
(HELP "UNKNOWN GIT-DIFF TAG" D)))
|
||||
(LIST DIR1 DIR2 MAPPINGS))])
|
||||
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 20-Jul-2022 21:18 by rmk")
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 12-Sep-2022 14:41 by rmk")
|
||||
(* ; "Edited 20-Jul-2022 21:18 by rmk")
|
||||
(* ; "Edited 22-May-2022 22:47 by rmk")
|
||||
(* ; "Edited 9-May-2022 15:14 by rmk")
|
||||
(* ; "Edited 3-May-2022 23:04 by rmk")
|
||||
@@ -1632,6 +1679,7 @@
|
||||
(FETCH (CDINFO FULLNAME)
|
||||
OF INFO1)
|
||||
FILEDIRCASEARRAY)))]
|
||||
(CL:WHEN MAP (HELP MAP))
|
||||
(CL:WHEN INFO1
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
|
||||
(SLASHIT (PACKFILENAME.STRING 'VERSION NIL
|
||||
@@ -1926,7 +1974,8 @@
|
||||
(OR LABEL2 FILE2])
|
||||
|
||||
(GIT-CD-MENUFN
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 22-May-2022 19:13 by rmk")
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 21-Sep-2022 21:34 by rmk")
|
||||
(* ; "Edited 22-May-2022 19:13 by rmk")
|
||||
(* ; "Edited 8-May-2022 09:26 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 08:52 by rmk")
|
||||
|
||||
@@ -1944,12 +1993,14 @@
|
||||
(|Delete ALL <-|
|
||||
(FLASHWINDOW PWINDOW)
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN [OR (EQ KEY 'MIDDLE)
|
||||
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of " (NAMEFIELD LABEL1
|
||||
T)
|
||||
" ? "]
|
||||
(MYMEDLEY-DELETE-FILES FILE1 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM)))
|
||||
(if (NAMEFIELD LABEL1 T)
|
||||
then (CL:WHEN [OR (EQ KEY 'MIDDLE)
|
||||
(EQ 'Y (ASKUSER NIL 'N (CONCAT "Delete ALL versions of "
|
||||
(NAMEFIELD LABEL1 T)
|
||||
" ? "]
|
||||
(MYMEDLEY-DELETE-FILES FILE1 (LISTGET USERDATA 'PROJECT))
|
||||
(TB.DELETE.ITEM CDBROWSER TBITEM))
|
||||
else (PRINTOUT T "Nothing to delete")))
|
||||
(Delete% BOTH (FLASHWINDOW PWINDOW)
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(CL:WHEN (EQ 'Y (ASKUSER NIL 'N (CONCAT
|
||||
@@ -2160,31 +2211,31 @@
|
||||
|
||||
(PUTPROPS GITFNS FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4005 19253 (GIT-CLONEP 4015 . 5278) (GIT-INIT 5280 . 5707) (GIT-MAKE-PROJECT 5709 .
|
||||
14094) (GIT-GET-PROJECT 14096 . 16021) (GIT-PROJECT-PATH 16023 . 17067) (FIND-ANCESTOR-DIRECTORY 17069
|
||||
. 17418) (GIT-FIND-CLONE 17420 . 18501) (GIT-MAINBRANCH 18503 . 18898) (GIT-MAINBRANCH? 18900 . 19251
|
||||
)) (25634 28422 (ALLSUBDIRS 25644 . 26930) (MEDLEYSUBDIRS 26932 . 27625) (GITSUBDIRS 27627 . 28420)) (
|
||||
28423 33213 (TOGIT 28433 . 29839) (FROMGIT 29841 . 30822) (GIT-DELETE-FILE 30824 . 31670) (
|
||||
MYMEDLEY-DELETE-FILES 31672 . 33211)) (33214 35746 (MYMEDLEYSUBDIR 33224 . 33680) (GITSUBDIR 33682 .
|
||||
34125) (STRIPDIR 34127 . 34498) (STRIPHOST 34500 . 34740) (STRIPNAME 34742 . 35495) (STRIPWHERE 35497
|
||||
. 35744)) (35747 37649 (GFILE4MFILE 35757 . 36120) (MFILE4GFILE 36122 . 36691) (GIT-REPO-FILENAME
|
||||
36693 . 37647)) (37698 47520 (GIT-COMMIT 37708 . 38534) (GIT-PUSH 38536 . 39180) (GIT-PULL 39182 .
|
||||
39794) (GIT-APPROVAL 39796 . 40145) (GIT-GET-FILE 40147 . 42112) (GIT-FILE-EXISTS? 42114 . 42388) (
|
||||
GIT-REMOTE-UPDATE 42390 . 43114) (GIT-REMOTE-ADD 43116 . 43423) (GIT-FILE-DATE 43425 . 44356) (
|
||||
GIT-FILE-HISTORY 44358 . 46292) (GIT-PRINT-FILE-HISTORY 46294 . 47344) (GIT-FETCH 47346 . 47518)) (
|
||||
47550 58282 (GIT-BRANCH-DIFF 47560 . 54344) (GIT-COMMIT-DIFFS 54346 . 54899) (GIT-BRANCH-RELATIONS
|
||||
54901 . 58280)) (58327 69129 (GIT-BRANCH-NUM 58337 . 58910) (GIT-CHECKOUT 58912 . 59971) (
|
||||
GIT-WHICH-BRANCH 59973 . 60271) (GIT-MAKE-BRANCH 60273 . 62486) (GIT-BRANCHES 62488 . 64461) (
|
||||
GIT-BRANCH-EXISTS? 64463 . 65167) (GIT-PICK-BRANCH 65169 . 65497) (GIT-PRC-MENU 65499 . 67247) (
|
||||
GIT-PULL-REQUESTS 67249 . 68515) (GIT-SHORT-BRANCH-NAME 68517 . 68808) (GIT-LONG-NAME 68810 . 69127))
|
||||
(69159 72494 (GIT-MY-CURRENT-BRANCH 69169 . 69539) (GIT-MY-BRANCHP 69541 . 70046) (GIT-MY-NEXT-BRANCH
|
||||
70048 . 70542) (GIT-MY-BRANCHES 70544 . 72492)) (72540 76492 (GIT-ADD-WORKTREE 72550 . 74034) (
|
||||
GIT-REMOVE-WORKTREE 74036 . 74966) (GIT-LIST-WORKTREES 74968 . 75772) (WORKTREEDIR 75774 . 76490)) (
|
||||
76540 106741 (GIT-GET-DIFFERENT-FILES 76550 . 82375) (GIT-BRANCHES-COMPARE-DIRECTORIES 82377 . 88358)
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES 88360 . 93186) (GIT-COMPARE-WORKTREE 93188 . 97166) (GITCDOBJBUTTONFN
|
||||
97168 . 101658) (GIT-CD-LABELFN 101660 . 102742) (GIT-CD-MENUFN 102744 . 104951) (
|
||||
GIT-WORKING-COMPARE-FILES 104953 . 105573) (GIT-BRANCHES-COMPARE-FILES 105575 . 106739)) (106811
|
||||
115328 (CDGITDIR 106821 . 107381) (GIT-COMMAND 107383 . 108941) (GITORIGIN 108943 . 109640) (
|
||||
GIT-INITIALS 109642 . 109946) (GIT-COMMAND-TO-FILE 109948 . 113437) (PROCESS-COMMAND 113439 . 114052)
|
||||
(GIT-RESULT-TO-LINES 114054 . 114661) (STRIPLOCAL 114663 . 115326)))))
|
||||
(FILEMAP (NIL (3905 19378 (GIT-CLONEP 3915 . 5178) (GIT-INIT 5180 . 5692) (GIT-MAKE-PROJECT 5694 .
|
||||
14079) (GIT-GET-PROJECT 14081 . 16006) (GIT-PROJECT-PATH 16008 . 17052) (FIND-ANCESTOR-DIRECTORY 17054
|
||||
. 17403) (GIT-FIND-CLONE 17405 . 18486) (GIT-MAINBRANCH 18488 . 18883) (GIT-MAINBRANCH? 18885 . 19376
|
||||
)) (25826 28614 (ALLSUBDIRS 25836 . 27122) (MEDLEYSUBDIRS 27124 . 27817) (GITSUBDIRS 27819 . 28612)) (
|
||||
28615 33405 (TOGIT 28625 . 30031) (FROMGIT 30033 . 31014) (GIT-DELETE-FILE 31016 . 31862) (
|
||||
MYMEDLEY-DELETE-FILES 31864 . 33403)) (33406 36409 (MYMEDLEYSUBDIR 33416 . 33872) (GITSUBDIR 33874 .
|
||||
34317) (STRIPDIR 34319 . 34690) (STRIPHOST 34692 . 34932) (STRIPNAME 34934 . 35687) (STRIPWHERE 35689
|
||||
. 36407)) (36410 38312 (GFILE4MFILE 36420 . 36783) (MFILE4GFILE 36785 . 37354) (GIT-REPO-FILENAME
|
||||
37356 . 38310)) (38361 48183 (GIT-COMMIT 38371 . 39197) (GIT-PUSH 39199 . 39843) (GIT-PULL 39845 .
|
||||
40457) (GIT-APPROVAL 40459 . 40808) (GIT-GET-FILE 40810 . 42775) (GIT-FILE-EXISTS? 42777 . 43051) (
|
||||
GIT-REMOTE-UPDATE 43053 . 43777) (GIT-REMOTE-ADD 43779 . 44086) (GIT-FILE-DATE 44088 . 45019) (
|
||||
GIT-FILE-HISTORY 45021 . 46955) (GIT-PRINT-FILE-HISTORY 46957 . 48007) (GIT-FETCH 48009 . 48181)) (
|
||||
48213 58806 (GIT-BRANCH-DIFF 48223 . 54563) (GIT-COMMIT-DIFFS 54565 . 55118) (GIT-BRANCH-RELATIONS
|
||||
55120 . 58804)) (58851 71083 (GIT-BRANCH-NUM 58861 . 59434) (GIT-CHECKOUT 59436 . 60495) (
|
||||
GIT-WHICH-BRANCH 60497 . 60795) (GIT-MAKE-BRANCH 60797 . 63010) (GIT-BRANCHES 63012 . 65280) (
|
||||
GIT-BRANCH-EXISTS? 65282 . 65986) (GIT-PICK-BRANCH 65988 . 66316) (GIT-PRC-MENU 66318 . 68321) (
|
||||
GIT-PULL-REQUESTS 68323 . 70469) (GIT-SHORT-BRANCH-NAME 70471 . 70762) (GIT-LONG-NAME 70764 . 71081))
|
||||
(71113 74448 (GIT-MY-CURRENT-BRANCH 71123 . 71493) (GIT-MY-BRANCHP 71495 . 72000) (GIT-MY-NEXT-BRANCH
|
||||
72002 . 72496) (GIT-MY-BRANCHES 72498 . 74446)) (74494 78446 (GIT-ADD-WORKTREE 74504 . 75988) (
|
||||
GIT-REMOVE-WORKTREE 75990 . 76920) (GIT-LIST-WORKTREES 76922 . 77726) (WORKTREEDIR 77728 . 78444)) (
|
||||
78494 109703 (GIT-GET-DIFFERENT-FILES 78504 . 84928) (GIT-BRANCHES-COMPARE-DIRECTORIES 84930 . 91087)
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES 91089 . 95915) (GIT-COMPARE-WORKTREE 95917 . 99895) (GITCDOBJBUTTONFN
|
||||
99897 . 104387) (GIT-CD-LABELFN 104389 . 105471) (GIT-CD-MENUFN 105473 . 107913) (
|
||||
GIT-WORKING-COMPARE-FILES 107915 . 108535) (GIT-BRANCHES-COMPARE-FILES 108537 . 109701)) (109773
|
||||
118290 (CDGITDIR 109783 . 110343) (GIT-COMMAND 110345 . 111903) (GITORIGIN 111905 . 112602) (
|
||||
GIT-INITIALS 112604 . 112908) (GIT-COMMAND-TO-FILE 112910 . 116399) (PROCESS-COMMAND 116401 . 117014)
|
||||
(GIT-RESULT-TO-LINES 117016 . 117623) (STRIPLOCAL 117625 . 118288)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
645
lispusers/HANOI
645
lispusers/HANOI
@@ -1,70 +1,74 @@
|
||||
(FILECREATED "25-Feb-86 19:07:01" {ERIS}<LISPUSERS>KOTO>HANOI.;7 19947
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to: (VARS HANOICOMS)
|
||||
(FILECREATED "21-Aug-2022 18:08:56" {DSK}<home>larry>medley>lispusers>HANOI.;2 22228
|
||||
|
||||
previous date: "17-Feb-86 14:59:01" {ERIS}<LISPUSERS>KOTO>HANOI.;5)
|
||||
:CHANGES-TO (VARS HANOICOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Feb-86 19:07:01" {DSK}<home>larry>medley>lispusers>HANOI.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
|
||||
(* ; "
|
||||
Copyright (c) 1982-1986 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT HANOICOMS)
|
||||
|
||||
(RPAQQ HANOICOMS ((FNS DISPLAYPEGSANDRINGS DOHANOI FINDOTHER HANOI HANOIDEMO MOVEDIS MOVERING
|
||||
RINGSHADE SETUPRINGBITMAPS TRACK WHANOI XHANOI)
|
||||
(VARS (HANOIWINDOW))
|
||||
(DECLARE: DONTCOPY (RECORDS PEG RING)
|
||||
(CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE)
|
||||
(CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30)
|
||||
(MAXHORIZSPEED 44))
|
||||
(MACROS PEGN))
|
||||
(VARS EVENRINGSHADE ODDRINGSHADE PEGSHADE)
|
||||
(ALISTS (IDLE.FUNCTIONS Hanoi HanoiUsername))))
|
||||
(RPAQQ HANOICOMS
|
||||
((FNS DISPLAYPEGSANDRINGS DOHANOI FINDOTHER HANOI HANOIDEMO MOVEDIS MOVERING RINGSHADE
|
||||
SETUPRINGBITMAPS TRACK WHANOI XHANOI)
|
||||
(VARS (HANOIWINDOW))
|
||||
(DECLARE%: DONTCOPY (RECORDS PEG RING)
|
||||
(CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE)
|
||||
(CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30)
|
||||
(MAXHORIZSPEED 44))
|
||||
(MACROS PEGN))
|
||||
(VARS EVENRINGSHADE ODDRINGSHADE PEGSHADE)
|
||||
(ALISTS (IDLE.FUNCTIONS Hanoi HanoiUsername))))
|
||||
(DEFINEQ
|
||||
|
||||
(DISPLAYPEGSANDRINGS
|
||||
[LAMBDA (PEGS W) (* edited: " 1-Oct-84 12:41")
|
||||
(* displays the pegs and the rings on them.)
|
||||
(for PEG in PEGS
|
||||
do (\CLEARBM W PEGSHADE (fetch PEGREGION of PEG))
|
||||
(for RING in (fetch RINGS of PEG)
|
||||
do (\CLEARBM W (RINGSHADE (fetch RINGNUMBER of RING))
|
||||
(fetch RINGREGION of RING))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING)
|
||||
(CENTERPRINTINREGION (fetch RINGLABEL of RING)
|
||||
(fetch RINGREGION of RING)
|
||||
W])
|
||||
[LAMBDA (PEGS W) (* edited%: " 1-Oct-84 12:41")
|
||||
(* displays the pegs and the rings on
|
||||
them.)
|
||||
(for PEG in PEGS do (\CLEARBM W PEGSHADE (fetch PEGREGION of PEG))
|
||||
(for RING in (fetch RINGS of PEG)
|
||||
do (\CLEARBM W (RINGSHADE (fetch RINGNUMBER of RING))
|
||||
(fetch RINGREGION of RING))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING)
|
||||
(CENTERPRINTINREGION (fetch RINGLABEL of RING)
|
||||
(fetch RINGREGION of RING)
|
||||
W])
|
||||
|
||||
(DOHANOI
|
||||
[LAMBDA (N SRC DST W) (* lmm " 8-MAR-82 12:05")
|
||||
(COND
|
||||
((EQ N 1)
|
||||
(MOVERING SRC DST W))
|
||||
(T (DOHANOI (SUB1 N)
|
||||
SRC
|
||||
(FINDOTHER SRC DST)
|
||||
W)
|
||||
(MOVERING SRC DST W)
|
||||
(DOHANOI (SUB1 N)
|
||||
(FINDOTHER SRC DST)
|
||||
DST W])
|
||||
[LAMBDA (N SRC DST W) (* lmm " 8-MAR-82 12:05")
|
||||
(COND
|
||||
((EQ N 1)
|
||||
(MOVERING SRC DST W))
|
||||
(T (DOHANOI (SUB1 N)
|
||||
SRC
|
||||
(FINDOTHER SRC DST)
|
||||
W)
|
||||
(MOVERING SRC DST W)
|
||||
(DOHANOI (SUB1 N)
|
||||
(FINDOTHER SRC DST)
|
||||
DST W])
|
||||
|
||||
(FINDOTHER
|
||||
[LAMBDA (S D) (* bas: "10-DEC-80 14:01")
|
||||
(for Z from 1 to 3 thereis (NOT (OR (EQ Z S)
|
||||
(EQ Z D])
|
||||
[LAMBDA (S D) (* bas%: "10-DEC-80 14:01")
|
||||
(for Z from 1 to 3 thereis (NOT (OR (EQ Z S)
|
||||
(EQ Z D])
|
||||
|
||||
(HANOI
|
||||
[LAMBDA (NRINGS WINDOW FONT ONCE) (* lmm " 9-MAR-82 09:52")
|
||||
[LAMBDA (NRINGS WINDOW FONT ONCE) (* lmm " 9-MAR-82 09:52")
|
||||
(WHANOI NRINGS WINDOW FONT ONCE])
|
||||
|
||||
(HANOIDEMO
|
||||
[LAMBDA NIL (* lmm
|
||||
"17-Feb-86 14:58")
|
||||
[LAMBDA NIL (* lmm "17-Feb-86 14:58")
|
||||
(PROG (HANOI.MOUSE.SPEED)
|
||||
(WHANOI 7
|
||||
[COND
|
||||
((TYPENAMEP HANOIWINDOW (QUOTE WINDOW))
|
||||
((TYPENAMEP HANOIWINDOW 'WINDOW)
|
||||
HANOIWINDOW)
|
||||
(T (SETQ HANOIWINDOW
|
||||
(CREATEW (create REGION
|
||||
@@ -75,18 +79,16 @@
|
||||
NIL T])
|
||||
|
||||
(MOVEDIS
|
||||
[LAMBDA (RING DY SX DX W) (* lmm
|
||||
"17-Feb-86 14:58")
|
||||
|
||||
(* moves RING from its position on the source peg whose left is SX to
|
||||
the peg whose left is DX at a height of DY)
|
||||
[LAMBDA (RING DY SX DX W) (* lmm "17-Feb-86 14:58")
|
||||
|
||||
(* moves RING from its position on the source peg whose left is SX to the peg
|
||||
whose left is DX at a height of DY)
|
||||
|
||||
(PROG ((RINGREGION (fetch RINGREGION of RING))
|
||||
RINGWIDTH HORIZWIDTH MOVERIGHTFLG)
|
||||
[COND
|
||||
(HANOI.MOUSE.SPEED (GETMOUSESTATE) (* IPLUS 16 is
|
||||
because cursor can go
|
||||
negative.)
|
||||
(HANOI.MOUSE.SPEED (GETMOUSESTATE) (* IPLUS 16 is because cursor can go
|
||||
negative.)
|
||||
(SETQ VERTSPEED (IMIN (IMAX (IDIFFERENCE 17 (IQUOTIENT LASTMOUSEY 50))
|
||||
1)
|
||||
MAXVERTSPEED))
|
||||
@@ -95,333 +97,298 @@
|
||||
MAXHORIZSPEED]
|
||||
(SETUPRINGBITMAPS RING (SETQ RINGWIDTH (fetch WIDTH of RINGREGION))
|
||||
(SETQ MOVERIGHTFLG (IGREATERP DX SX))
|
||||
W) (* PROG is because
|
||||
FOR loop bug.)
|
||||
W) (* PROG is because FOR loop bug.)
|
||||
(PROG ((I (fetch BOTTOM of RINGREGION))
|
||||
(TOPLIMIT (IDIFFERENCE PEGTOP VERTSPEED)))
|
||||
LP (COND
|
||||
((IGREATERP TOPLIMIT I)
|
||||
(BITBLT UPRINGBM 0 0 W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ I (IPLUS VERTSPEED I))
|
||||
(GO LP)))
|
||||
(BITBLT UPRINGBM 0 (IDIFFERENCE I TOPLIMIT)
|
||||
W SX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE)))
|
||||
'INPUT
|
||||
'REPLACE))
|
||||
(BITBLT TOPUPRINGBM 0 0 W SX PEGTOP RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ HORIZWIDTH (IPLUS RINGWIDTH HORIZSPEED))
|
||||
(for I from (COND
|
||||
(MOVERIGHTFLG SX)
|
||||
(T (IDIFFERENCE SX HORIZSPEED)))
|
||||
(MOVERIGHTFLG SX)
|
||||
(T (IDIFFERENCE SX HORIZSPEED)))
|
||||
to (COND
|
||||
(MOVERIGHTFLG (SUB1 (IDIFFERENCE DX HORIZSPEED)))
|
||||
(T (ADD1 DX))) by (ITIMES (COND
|
||||
((IGREATERP DX SX)
|
||||
1)
|
||||
(T -1))
|
||||
HORIZSPEED)
|
||||
do (BITBLT HORIZRINGBM 0 0 W I (IPLUS PEGTOP VERTSPEED)
|
||||
HORIZWIDTH RINGHEIGHT (QUOTE INPUT)
|
||||
(QUOTE REPLACE)))
|
||||
(MOVERIGHTFLG (SUB1 (IDIFFERENCE DX HORIZSPEED)))
|
||||
(T (ADD1 DX))) by (ITIMES (COND
|
||||
((IGREATERP DX SX)
|
||||
1)
|
||||
(T -1))
|
||||
HORIZSPEED) do (BITBLT HORIZRINGBM 0 0 W I
|
||||
(IPLUS PEGTOP VERTSPEED)
|
||||
HORIZWIDTH RINGHEIGHT 'INPUT
|
||||
'REPLACE))
|
||||
(BITBLT HORIZRINGBM 0 0 W (COND
|
||||
(MOVERIGHTFLG (IDIFFERENCE DX HORIZSPEED))
|
||||
(T DX))
|
||||
(IPLUS PEGTOP VERTSPEED)
|
||||
HORIZWIDTH NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE)) (* Update the ring
|
||||
region's left)
|
||||
HORIZWIDTH NIL 'INPUT 'REPLACE) (* Update the ring region's left)
|
||||
(replace LEFT of RINGREGION with (IPLUS (fetch LEFT of RINGREGION)
|
||||
(IDIFFERENCE DX SX)))
|
||||
(for I from PEGTOP to (SUB1 (IDIFFERENCE PEGTOP RINGHEIGHT))
|
||||
by (IMINUS VERTSPEED) do (BITBLT TOPDOWNRINGBM NIL NIL W DX I RINGWIDTH
|
||||
(IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE)))
|
||||
(IDIFFERENCE DX SX)))
|
||||
(for I from PEGTOP to (SUB1 (IDIFFERENCE PEGTOP RINGHEIGHT)) by (IMINUS VERTSPEED)
|
||||
do (BITBLT TOPDOWNRINGBM NIL NIL W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
'INPUT
|
||||
'REPLACE))
|
||||
(BITBLT TOPDOWNRINGBM NIL NIL W DX (IDIFFERENCE PEGTOP RINGHEIGHT)
|
||||
RINGWIDTH
|
||||
(IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(PROG [(I (IDIFFERENCE PEGTOP (IPLUS VERTSPEED RINGHEIGHT]
|
||||
LP (COND
|
||||
((IGREATERP DY I) (* blt last ring
|
||||
image)
|
||||
((IGREATERP DY I) (* blt last ring image)
|
||||
(BITBLT DOWNRINGBM 0 0 W DX DY RINGWIDTH (COND
|
||||
((IGREATERP VERTSPEED RINGHEIGHT)
|
||||
(IDIFFERENCE (IPLUS RINGHEIGHT
|
||||
VERTSPEED)
|
||||
(IDIFFERENCE DY I)))
|
||||
(T (IPLUS RINGHEIGHT VERTSPEED)))
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(RETURN)))
|
||||
(BITBLT DOWNRINGBM 0 0 W DX I RINGWIDTH (IPLUS RINGHEIGHT VERTSPEED)
|
||||
(QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ I (IDIFFERENCE I VERTSPEED))
|
||||
(GO LP))
|
||||
(replace BOTTOM of RINGREGION with DY)
|
||||
(RETURN RING])
|
||||
|
||||
(MOVERING
|
||||
[LAMBDA (SRC DST W) (* rrb " 2-AUG-82 17:41")
|
||||
(PROG ([X (fetch RINGREGION of (CAR (fetch RINGS of (PEGN DST]
|
||||
RING)
|
||||
[LAMBDA (SRC DST W) (* rrb " 2-AUG-82 17:41")
|
||||
(PROG ([X (fetch RINGREGION of (CAR (fetch RINGS of (PEGN DST]
|
||||
RING)
|
||||
(push (fetch RINGS of (PEGN DST))
|
||||
(MOVEDIS [SETQ RING (pop (fetch RINGS of (PEGN SRC]
|
||||
(IPLUS (fetch BOTTOM of X)
|
||||
(fetch HEIGHT of X))
|
||||
(TRACK SRC (fetch RINGREGION of RING))
|
||||
(TRACK DST (fetch RINGREGION of RING))
|
||||
W))
|
||||
(BLOCK])
|
||||
(MOVEDIS [SETQ RING (pop (fetch RINGS of (PEGN SRC]
|
||||
(IPLUS (fetch BOTTOM of X)
|
||||
(fetch HEIGHT of X))
|
||||
(TRACK SRC (fetch RINGREGION of RING))
|
||||
(TRACK DST (fetch RINGREGION of RING))
|
||||
W))
|
||||
(BLOCK])
|
||||
|
||||
(RINGSHADE
|
||||
[LAMBDA (RINGN) (* rrb " 9-JUN-81 15:11")
|
||||
(COND
|
||||
((EQ RINGN (QUOTE BASE))
|
||||
PEGSHADE)
|
||||
((ZEROP (LOGAND RINGN 1))
|
||||
EVENRINGSHADE)
|
||||
(T ODDRINGSHADE])
|
||||
[LAMBDA (RINGN) (* rrb " 9-JUN-81 15:11")
|
||||
(COND
|
||||
((EQ RINGN 'BASE)
|
||||
PEGSHADE)
|
||||
((ZEROP (LOGAND RINGN 1))
|
||||
EVENRINGSHADE)
|
||||
(T ODDRINGSHADE])
|
||||
|
||||
(SETUPRINGBITMAPS
|
||||
[LAMBDA (RING RINGWIDTH MOVERIGHTFLG W) (* edited: " 1-Oct-84 12:43")
|
||||
[LAMBDA (RING RINGWIDTH MOVERIGHTFLG W) (* edited%: " 1-Oct-84 12:43")
|
||||
|
||||
(* sets up the ring bitmaps. There are 5 ring bitmaps: up while on peg, up above peg, horizontal, down above peg and
|
||||
down while on peg.)
|
||||
(* sets up the ring bitmaps. There are 5 ring bitmaps%: up while on peg, up above
|
||||
peg, horizontal, down above peg and down while on peg.)
|
||||
|
||||
|
||||
(PROG ((PEGOFFSET (IQUOTIENT (IDIFFERENCE RINGWIDTH PEGWIDTH)
|
||||
2))
|
||||
(RINGREGION (fetch RINGREGION of RING))
|
||||
(RINGN (fetch RINGNUMBER of RING)))
|
||||
(AND FONT (DSPFONT FONT RDEST))
|
||||
(DSPOPERATION (QUOTE ERASE)
|
||||
RDEST)
|
||||
[PROGN (\CLEARBM UPRINGBM)
|
||||
(BITBLT NIL NIL NIL UPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
(RINGSHADE RINGN)) (* put in peg)
|
||||
(BITBLT NIL NIL NIL UPRINGBM PEGOFFSET 0 PEGWIDTH VERTSPEED (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
PEGSHADE)
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION UPRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST]
|
||||
[PROGN (\CLEARBM TOPUPRINGBM)
|
||||
(BITBLT NIL NIL NIL TOPUPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION TOPUPRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST]
|
||||
(PROGN (\CLEARBM DOWNRINGBM)
|
||||
(BITBLT NIL NIL NIL DOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION DOWNRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 0 RINGWIDTH RINGHEIGHT RDEST)))
|
||||
(* put in peg)
|
||||
(BITBLT NIL NIL NIL DOWNRINGBM PEGOFFSET RINGHEIGHT PEGWIDTH VERTSPEED (QUOTE
|
||||
TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
PEGSHADE))
|
||||
[PROGN (\CLEARBM TOPDOWNRINGBM)
|
||||
(BITBLT NIL NIL NIL TOPDOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION TOPDOWNRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 0 RINGWIDTH RINGHEIGHT RDEST]
|
||||
[PROGN (\CLEARBM HORIZRINGBM)
|
||||
(BITBLT NIL NIL NIL HORIZRINGBM (COND
|
||||
(MOVERIGHTFLG HORIZSPEED)
|
||||
(T 0))
|
||||
0 RINGWIDTH RINGHEIGHT (QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION HORIZRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
(COND
|
||||
(MOVERIGHTFLG HORIZSPEED)
|
||||
(T 0))
|
||||
0 RINGWIDTH RINGHEIGHT RDEST]
|
||||
(RETURN])
|
||||
(PROG ((PEGOFFSET (IQUOTIENT (IDIFFERENCE RINGWIDTH PEGWIDTH)
|
||||
2))
|
||||
(RINGREGION (fetch RINGREGION of RING))
|
||||
(RINGN (fetch RINGNUMBER of RING)))
|
||||
(AND FONT (DSPFONT FONT RDEST))
|
||||
(DSPOPERATION 'ERASE RDEST)
|
||||
[PROGN (\CLEARBM UPRINGBM)
|
||||
(BITBLT NIL NIL NIL UPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE
|
||||
(RINGSHADE RINGN)) (* put in peg)
|
||||
(BITBLT NIL NIL NIL UPRINGBM PEGOFFSET 0 PEGWIDTH VERTSPEED 'TEXTURE 'REPLACE
|
||||
PEGSHADE)
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION UPRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST]
|
||||
[PROGN (\CLEARBM TOPUPRINGBM)
|
||||
(BITBLT NIL NIL NIL TOPUPRINGBM 0 VERTSPEED RINGWIDTH RINGHEIGHT 'TEXTURE
|
||||
'REPLACE
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION TOPUPRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 VERTSPEED RINGWIDTH RINGHEIGHT RDEST]
|
||||
(PROGN (\CLEARBM DOWNRINGBM)
|
||||
(BITBLT NIL NIL NIL DOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION DOWNRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 0 RINGWIDTH RINGHEIGHT RDEST)))(* put in peg)
|
||||
(BITBLT NIL NIL NIL DOWNRINGBM PEGOFFSET RINGHEIGHT PEGWIDTH VERTSPEED 'TEXTURE
|
||||
'REPLACE PEGSHADE))
|
||||
[PROGN (\CLEARBM TOPDOWNRINGBM)
|
||||
(BITBLT NIL NIL NIL TOPDOWNRINGBM 0 0 RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE
|
||||
(RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION TOPDOWNRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
0 0 RINGWIDTH RINGHEIGHT RDEST]
|
||||
[PROGN (\CLEARBM HORIZRINGBM)
|
||||
(BITBLT NIL NIL NIL HORIZRINGBM (COND
|
||||
(MOVERIGHTFLG HORIZSPEED)
|
||||
(T 0))
|
||||
0 RINGWIDTH RINGHEIGHT 'TEXTURE 'REPLACE (RINGSHADE RINGN))
|
||||
(COND
|
||||
((fetch RINGLABEL of RING) (* print in label if there is one.)
|
||||
(DSPDESTINATION HORIZRINGBM RDEST)
|
||||
(CENTERPRINTINAREA (fetch RINGLABEL of RING)
|
||||
(COND
|
||||
(MOVERIGHTFLG HORIZSPEED)
|
||||
(T 0))
|
||||
0 RINGWIDTH RINGHEIGHT RDEST]
|
||||
(RETURN])
|
||||
|
||||
(TRACK
|
||||
[LAMBDA (PN REGION) (* lmm " 8-MAR-82 12:10")
|
||||
(* returns the track offset for ring movement on a
|
||||
peg.)
|
||||
(IPLUS HANOIMARGIN (IPLUS (ITIMES RINGLARGEST (SUB1 PN))
|
||||
(IQUOTIENT (IDIFFERENCE RINGLARGEST (fetch WIDTH of REGION))
|
||||
2])
|
||||
[LAMBDA (PN REGION) (* lmm " 8-MAR-82 12:10")
|
||||
(* returns the track offset for ring
|
||||
movement on a peg.)
|
||||
(IPLUS HANOIMARGIN (IPLUS (ITIMES RINGLARGEST (SUB1 PN))
|
||||
(IQUOTIENT (IDIFFERENCE RINGLARGEST (fetch WIDTH of REGION))
|
||||
2])
|
||||
|
||||
(WHANOI
|
||||
[LAMBDA (RINGS W FONT ONCE) (* lmm " 3-Dec-85 12:51")
|
||||
(* runs hanoi in a region of a displaystream)
|
||||
(PROG ([REGION (DSPCLIPPINGREGION NIL (SETQ W (COND
|
||||
[(NULL W)
|
||||
(OR HANOIWINDOW (SETQ HANOIWINDOW (CREATEW]
|
||||
((WINDOWP W))
|
||||
(T (CREATEW W]
|
||||
[NRINGS (COND
|
||||
((NUMBERP RINGS)
|
||||
RINGS)
|
||||
(T (LENGTH RINGS]
|
||||
(HORIZSPEED 21)
|
||||
(VERTSPEED 17)
|
||||
PEGS RINGBM TOPUPRINGBM RINGLARGEST TOPDOWNRINGBM PEGWIDTH BASEWIDTH RINGHEIGHT
|
||||
MOVEMENTHEIGHT BASEHEIGHT PEGTOP RINGDISPLAYSTREAM HANOIWINDOW RINGDELTA UPRINGBM
|
||||
HORIZRINGBM DOWNRINGBM (RDEST (DSPCREATE)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
(PROG (IMAGEHEIGHT)
|
||||
(SETQ BASEWIDTH (IDIFFERENCE (fetch WIDTH of REGION)
|
||||
(ITIMES HANOIMARGIN 2)))
|
||||
(SETQ RINGLARGEST (IQUOTIENT BASEWIDTH 3))
|
||||
(* RINGDELTA is the difference in peg size on each
|
||||
side.)
|
||||
(COND
|
||||
([ZEROP (SETQ RINGDELTA (IQUOTIENT (IDIFFERENCE RINGLARGEST PEGMIN)
|
||||
(ADD1 (ITIMES NRINGS 2]
|
||||
(HELP "Not enough width for a display.")))
|
||||
[LAMBDA (RINGS W FONT ONCE) (* lmm " 3-Dec-85 12:51")
|
||||
(* runs hanoi in a region of a
|
||||
displaystream)
|
||||
(PROG ([REGION (DSPCLIPPINGREGION NIL (SETQ W (COND
|
||||
[(NULL W)
|
||||
(OR HANOIWINDOW (SETQ HANOIWINDOW (CREATEW]
|
||||
((WINDOWP W))
|
||||
(T (CREATEW W]
|
||||
[NRINGS (COND
|
||||
((NUMBERP RINGS)
|
||||
RINGS)
|
||||
(T (LENGTH RINGS]
|
||||
(HORIZSPEED 21)
|
||||
(VERTSPEED 17)
|
||||
PEGS RINGBM TOPUPRINGBM RINGLARGEST TOPDOWNRINGBM PEGWIDTH BASEWIDTH RINGHEIGHT
|
||||
MOVEMENTHEIGHT BASEHEIGHT PEGTOP RINGDISPLAYSTREAM HANOIWINDOW RINGDELTA UPRINGBM
|
||||
HORIZRINGBM DOWNRINGBM (RDEST (DSPCREATE)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
(PROG (IMAGEHEIGHT)
|
||||
(SETQ BASEWIDTH (IDIFFERENCE (fetch WIDTH of REGION)
|
||||
(ITIMES HANOIMARGIN 2)))
|
||||
(SETQ RINGLARGEST (IQUOTIENT BASEWIDTH 3)) (* RINGDELTA is the difference in peg
|
||||
size on each side.)
|
||||
(COND
|
||||
([ZEROP (SETQ RINGDELTA (IQUOTIENT (IDIFFERENCE RINGLARGEST PEGMIN)
|
||||
(ADD1 (ITIMES NRINGS 2]
|
||||
(HELP "Not enough width for a display.")))
|
||||
|
||||
(* leave one ring width for base, one for top of peg and two above peg for movement. Doesn't really use two heights
|
||||
at top, only one plus VERTSPEED)
|
||||
(* leave one ring width for base, one for top of peg and two above peg for
|
||||
movement. Doesn't really use two heights at top, only one plus VERTSPEED)
|
||||
|
||||
|
||||
(SETQ RINGHEIGHT (IQUOTIENT (SETQ IMAGEHEIGHT (IDIFFERENCE (fetch
|
||||
HEIGHT
|
||||
of REGION)
|
||||
(ITIMES
|
||||
HANOIMARGIN
|
||||
2)))
|
||||
(IPLUS NRINGS 4)))
|
||||
(COND
|
||||
((ZEROP RINGHEIGHT)
|
||||
(HELP "Not enough height for display.")))
|
||||
(SETQ PEGWIDTH (IQUOTIENT (IDIFFERENCE RINGLARGEST (ITIMES RINGDELTA
|
||||
(SUB1 NRINGS)
|
||||
2))
|
||||
3)) (* put extra in base if it comes out closer to
|
||||
pegwidth.)
|
||||
(COND
|
||||
[(IGREATERP PEGWIDTH RINGHEIGHT)
|
||||
(SETQ BASEHEIGHT (IMIN PEGWIDTH (IPLUS RINGHEIGHT
|
||||
(IDIFFERENCE
|
||||
IMAGEHEIGHT
|
||||
(ITIMES (IPLUS NRINGS 4)
|
||||
RINGHEIGHT]
|
||||
(T (SETQ BASEHEIGHT RINGHEIGHT)))
|
||||
(SETQ MOVEMENTHEIGHT (IPLUS [SETQ PEGTOP (IPLUS HANOIMARGIN BASEHEIGHT
|
||||
(ITIMES RINGHEIGHT
|
||||
(ADD1 NRINGS]
|
||||
VERTSPEED))
|
||||
(DSPFONT FONT RDEST)
|
||||
(DSPFONT FONT W)
|
||||
(DSPOPERATION (QUOTE ERASE)
|
||||
RDEST)
|
||||
(DSPOPERATION (QUOTE ERASE)
|
||||
W))
|
||||
[PROG ((BASE (create REGION
|
||||
LEFT _ HANOIMARGIN
|
||||
BOTTOM _ HANOIMARGIN
|
||||
WIDTH _ BASEWIDTH
|
||||
HEIGHT _ BASEHEIGHT)))
|
||||
(SETQ PEGS (for PLEFT from (IPLUS HANOIMARGIN (IQUOTIENT (IDIFFERENCE
|
||||
RINGLARGEST
|
||||
PEGWIDTH)
|
||||
2))
|
||||
by RINGLARGEST as I from 1 to 3
|
||||
collect (create PEG
|
||||
PEGREGION _(create REGION
|
||||
LEFT _ PLEFT
|
||||
BOTTOM _(IPLUS
|
||||
BASEHEIGHT
|
||||
HANOIMARGIN)
|
||||
WIDTH _ PEGWIDTH
|
||||
HEIGHT _(ITIMES
|
||||
RINGHEIGHT
|
||||
(ADD1 NRINGS)))
|
||||
RINGS _(LIST (create RING
|
||||
RINGREGION _ BASE
|
||||
RINGNUMBER _(QUOTE
|
||||
BASE]
|
||||
[PROG [(SOURCEPEG (PEGN 1))
|
||||
(RINGLABELS (COND
|
||||
((LISTP RINGS)
|
||||
(REVERSE RINGS))
|
||||
(T (* collect n NILs as lables.)
|
||||
(for I from 1 to RINGS collect NIL]
|
||||
(for RINGBOTTOM from (IPLUS HANOIMARGIN BASEHEIGHT) by RINGHEIGHT
|
||||
as RINGLEFT from (IPLUS HANOIMARGIN (ITIMES RINGLARGEST (SUB1 1)))
|
||||
by RINGDELTA as I from 0 to (SUB1 NRINGS) as LABEL in RINGLABELS
|
||||
do (push (fetch RINGS of SOURCEPEG)
|
||||
(create RING
|
||||
RINGREGION _(create REGION
|
||||
LEFT _ RINGLEFT
|
||||
BOTTOM _ RINGBOTTOM
|
||||
WIDTH _(IDIFFERENCE
|
||||
RINGLARGEST
|
||||
(ITIMES I 2 RINGDELTA))
|
||||
HEIGHT _ RINGHEIGHT)
|
||||
RINGNUMBER _(ADD1 (IDIFFERENCE NRINGS I))
|
||||
RINGLABEL _ LABEL)))
|
||||
(* allocate bitmaps for ring movement)
|
||||
(SETQ HORIZRINGBM (BITMAPCREATE (IPLUS RINGLARGEST MAXHORIZSPEED)
|
||||
RINGHEIGHT))
|
||||
(SETQ UPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
|
||||
(SETQ DOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
|
||||
(SETQ TOPUPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED))
|
||||
)
|
||||
(SETQ TOPDOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT
|
||||
MAXVERTSPEED]
|
||||
(\CLEARBM W)
|
||||
(DISPLAYPEGSANDRINGS PEGS W)
|
||||
(bind (HERE _ 1)
|
||||
(THERE _ 3)
|
||||
do (DOHANOI NRINGS HERE THERE W)
|
||||
(COND
|
||||
(ONCE (RETURN)))
|
||||
(DISMISS 2000)
|
||||
(SETQ HERE (PROG1 THERE (SETQ THERE (FINDOTHER HERE THERE])
|
||||
(SETQ RINGHEIGHT (IQUOTIENT (SETQ IMAGEHEIGHT (IDIFFERENCE (fetch HEIGHT of REGION)
|
||||
(ITIMES HANOIMARGIN 2)))
|
||||
(IPLUS NRINGS 4)))
|
||||
(COND
|
||||
((ZEROP RINGHEIGHT)
|
||||
(HELP "Not enough height for display.")))
|
||||
(SETQ PEGWIDTH (IQUOTIENT (IDIFFERENCE RINGLARGEST (ITIMES RINGDELTA (SUB1 NRINGS)
|
||||
2))
|
||||
3)) (* put extra in base if it comes out
|
||||
closer to pegwidth.)
|
||||
(COND
|
||||
[(IGREATERP PEGWIDTH RINGHEIGHT)
|
||||
(SETQ BASEHEIGHT (IMIN PEGWIDTH (IPLUS RINGHEIGHT (IDIFFERENCE
|
||||
IMAGEHEIGHT
|
||||
(ITIMES (IPLUS NRINGS 4)
|
||||
RINGHEIGHT]
|
||||
(T (SETQ BASEHEIGHT RINGHEIGHT)))
|
||||
(SETQ MOVEMENTHEIGHT (IPLUS [SETQ PEGTOP (IPLUS HANOIMARGIN BASEHEIGHT
|
||||
(ITIMES RINGHEIGHT (ADD1 NRINGS]
|
||||
VERTSPEED))
|
||||
(DSPFONT FONT RDEST)
|
||||
(DSPFONT FONT W)
|
||||
(DSPOPERATION 'ERASE RDEST)
|
||||
(DSPOPERATION 'ERASE W))
|
||||
[PROG ((BASE (create REGION
|
||||
LEFT _ HANOIMARGIN
|
||||
BOTTOM _ HANOIMARGIN
|
||||
WIDTH _ BASEWIDTH
|
||||
HEIGHT _ BASEHEIGHT)))
|
||||
(SETQ PEGS (for PLEFT from (IPLUS HANOIMARGIN (IQUOTIENT (IDIFFERENCE RINGLARGEST
|
||||
PEGWIDTH)
|
||||
2)) by RINGLARGEST as I
|
||||
from 1 to 3
|
||||
collect (create PEG
|
||||
PEGREGION _ (create REGION
|
||||
LEFT _ PLEFT
|
||||
BOTTOM _ (IPLUS BASEHEIGHT
|
||||
HANOIMARGIN)
|
||||
WIDTH _ PEGWIDTH
|
||||
HEIGHT _ (ITIMES RINGHEIGHT
|
||||
(ADD1 NRINGS)))
|
||||
RINGS _ (LIST (create RING
|
||||
RINGREGION _ BASE
|
||||
RINGNUMBER _ 'BASE]
|
||||
[PROG [(SOURCEPEG (PEGN 1))
|
||||
(RINGLABELS (COND
|
||||
((LISTP RINGS)
|
||||
(REVERSE RINGS))
|
||||
(T (* collect n NILs as lables.)
|
||||
(for I from 1 to RINGS collect NIL]
|
||||
(for RINGBOTTOM from (IPLUS HANOIMARGIN BASEHEIGHT) by RINGHEIGHT as RINGLEFT
|
||||
from (IPLUS HANOIMARGIN (ITIMES RINGLARGEST (SUB1 1))) by RINGDELTA as I
|
||||
from 0 to (SUB1 NRINGS) as LABEL in RINGLABELS
|
||||
do (push (fetch RINGS of SOURCEPEG)
|
||||
(create RING
|
||||
RINGREGION _ (create REGION
|
||||
LEFT _ RINGLEFT
|
||||
BOTTOM _ RINGBOTTOM
|
||||
WIDTH _ (IDIFFERENCE RINGLARGEST
|
||||
(ITIMES I 2 RINGDELTA))
|
||||
HEIGHT _ RINGHEIGHT)
|
||||
RINGNUMBER _ (ADD1 (IDIFFERENCE NRINGS I))
|
||||
RINGLABEL _ LABEL))) (* allocate bitmaps for ring movement)
|
||||
(SETQ HORIZRINGBM (BITMAPCREATE (IPLUS RINGLARGEST MAXHORIZSPEED)
|
||||
RINGHEIGHT))
|
||||
(SETQ UPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
|
||||
(SETQ DOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
|
||||
(SETQ TOPUPRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED)))
|
||||
(SETQ TOPDOWNRINGBM (BITMAPCREATE RINGLARGEST (IPLUS RINGHEIGHT MAXVERTSPEED]
|
||||
(\CLEARBM W)
|
||||
(DISPLAYPEGSANDRINGS PEGS W)
|
||||
(bind (HERE _ 1)
|
||||
(THERE _ 3) do (DOHANOI NRINGS HERE THERE W)
|
||||
(COND
|
||||
(ONCE (RETURN)))
|
||||
(DISMISS 2000)
|
||||
(SETQ HERE (PROG1 THERE
|
||||
(SETQ THERE (FINDOTHER HERE THERE)))])
|
||||
|
||||
(XHANOI
|
||||
[LAMBDA NIL (* lmm " 8-MAR-82 15:59")
|
||||
(PROG ((EVENRINGSHADE XRINGSHADE)
|
||||
(ODDRINGSHADE ORINGSHADE)
|
||||
(PEGSHADE XPEGSHADE))
|
||||
(WHANOI (QUOTE (X E R O X))
|
||||
(QUOTE (0 0 400 280))
|
||||
(FONTCREATE (QUOTE LOGO)
|
||||
24])
|
||||
[LAMBDA NIL (* lmm " 8-MAR-82 15:59")
|
||||
(PROG ((EVENRINGSHADE XRINGSHADE)
|
||||
(ODDRINGSHADE ORINGSHADE)
|
||||
(PEGSHADE XPEGSHADE))
|
||||
(WHANOI '(X E R O X)
|
||||
'(0 0 400 280)
|
||||
(FONTCREATE 'LOGO 24])
|
||||
)
|
||||
|
||||
(RPAQQ HANOIWINDOW NIL)
|
||||
(DECLARE: DONTCOPY
|
||||
[DECLARE: EVAL@COMPILE
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD PEG (PEGREGION RINGS))
|
||||
|
||||
(RECORD RING (RINGREGION RINGNUMBER RINGLABEL))
|
||||
]
|
||||
)
|
||||
|
||||
(DECLARE: EVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ XRINGSHADE 42405)
|
||||
|
||||
@@ -429,10 +396,11 @@
|
||||
|
||||
(RPAQQ XPEGSHADE 65535)
|
||||
|
||||
|
||||
(CONSTANTS XRINGSHADE ORINGSHADE XPEGSHADE)
|
||||
)
|
||||
|
||||
(DECLARE: EVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ PEGMIN 2)
|
||||
|
||||
@@ -442,15 +410,18 @@
|
||||
|
||||
(RPAQQ MAXHORIZSPEED 44)
|
||||
|
||||
|
||||
(CONSTANTS PEGMIN HANOIMARGIN (MAXVERTSPEED 30)
|
||||
(MAXHORIZSPEED 44))
|
||||
(MAXHORIZSPEED 44))
|
||||
)
|
||||
|
||||
(DECLARE: EVAL@COMPILE
|
||||
[PUTPROPS PEGN MACRO ((N)
|
||||
(CAR (SELECTQ N (1 PEGS)
|
||||
(2 (CDR PEGS))
|
||||
(CDDR PEGS]
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PEGN MACRO [(N)
|
||||
(CAR (SELECTQ N
|
||||
(1 PEGS)
|
||||
(2 (CDR PEGS))
|
||||
(CDDR PEGS])
|
||||
)
|
||||
)
|
||||
|
||||
@@ -461,17 +432,13 @@
|
||||
(RPAQQ PEGSHADE 65535)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS [Hanoi (FUNCTION (LAMBDA (W)
|
||||
(HANOI (UNPACK (QUOTE "Xerox AI Systems"))
|
||||
W
|
||||
(QUOTE (TIMESROMAND 36]
|
||||
[HanoiUsername (FUNCTION (LAMBDA (W)
|
||||
(HANOI (UNPACK (USERNAME NIL T T))
|
||||
W
|
||||
(QUOTE (TIMESROMAND 36])
|
||||
(HANOI (UNPACK "Interlisp.org")
|
||||
W
|
||||
'(TIMESROMAND 36])
|
||||
(PUTPROPS HANOI COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (797 18810 (DISPLAYPEGSANDRINGS 807 . 1479) (DOHANOI 1481 . 1818) (FINDOTHER 1820 . 2022
|
||||
) (HANOI 2024 . 2167) (HANOIDEMO 2169 . 2861) (MOVEDIS 2863 . 8440) (MOVERING 8442 . 8994) (RINGSHADE
|
||||
8996 . 9245) (SETUPRINGBITMAPS 9247 . 12568) (TRACK 12570 . 12983) (WHANOI 12985 . 18479) (XHANOI
|
||||
18481 . 18808)))))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (920 20991 (DISPLAYPEGSANDRINGS 930 . 1875) (DOHANOI 1877 . 2288) (FINDOTHER 2290 . 2512
|
||||
) (HANOI 2514 . 2657) (HANOIDEMO 2659 . 3254) (MOVEDIS 3256 . 8151) (MOVERING 8153 . 8808) (RINGSHADE
|
||||
8810 . 9049) (SETUPRINGBITMAPS 9051 . 12799) (TRACK 12801 . 13291) (WHANOI 13293 . 20670) (XHANOI
|
||||
20672 . 20989)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
1609
lispusers/HELPSYS
1609
lispusers/HELPSYS
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
@@ -1,453 +1,191 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "10-Nov-2020 15:57:14" |{DSK}<export>home>denber>lisp>HISTMENU.;40| 28526
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
|changes| |to:| (FNS |HistoryMenu| |UpdateHistoryWindow| |UpdateWistoryWindow|
|
||||
|HistRightButtonFn| |HistMenuOp| |HistMenuMiddle| REMOVENTH)
|
||||
(VARS HISTMENUCOMS HISTCOMS)
|
||||
(FILECREATED "19-Sep-2022 19:20:51" {DSK}<home>matt>medley>LISPUSERS>HISTMENU.;4 16184
|
||||
|
||||
|previous| |date:| "20-Oct-2020 12:02:51" |{DSK}<export>home>denber>lisp>HISTMENU.;1|)
|
||||
:CHANGES-TO (VARS HISTMENUCOMS)
|
||||
(FNS HistMenuOp)
|
||||
|
||||
:PREVIOUS-DATE "15-Sep-2022 21:50:50" {DSK}<home>matt>medley>LISPUSERS>HISTMENU.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1987, 2022 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT HISTMENUCOMS)
|
||||
|
||||
(RPAQQ HISTMENUCOMS ((FNS |HistMenuMiddle| |HistMenuOp| |HistRightButtonFn| |HistoryMenu|
|
||||
REMOVENTH |UpdateHistoryWindow| |UpdateWistoryWindow|)
|
||||
(VARS HISTCOMS)))
|
||||
(RPAQQ HISTMENUCOMS ((VARS * HISTMENUVARS)
|
||||
(INITVARS HistMenuExecOnly)
|
||||
(FNS * HISTMENUFNS)
|
||||
(BITMAPS HistoryBitMap HistoryMask)
|
||||
(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
|
||||
HISTMENU)))
|
||||
|
||||
(RPAQQ HISTMENUVARS (BadHistoryItems HistDefaultSlice HistItemsShown HistMenuItemHeight HistMenuWidth
|
||||
HistOpMenuItems HistWindowWidth HistEventWidth UpdateOnDeleteFlg (
|
||||
HistRightMenu
|
||||
)
|
||||
(HistOpMenu)
|
||||
(HistoryWindow)
|
||||
(HistoryMenu)))
|
||||
|
||||
(RPAQQ BadHistoryItems (EDIT ?= OK T NIL ^))
|
||||
|
||||
(RPAQQ HistDefaultSlice 30)
|
||||
|
||||
(RPAQQ HistItemsShown 51)
|
||||
|
||||
(RPAQQ HistMenuItemHeight 15)
|
||||
|
||||
(RPAQQ HistMenuWidth 164)
|
||||
|
||||
(RPAQQ HistOpMenuItems
|
||||
((REDO 'REDO "REDO event selected")
|
||||
(FIX 'FIX "Edit event selected")
|
||||
(UNDO 'UNDO "UNDO event selected")
|
||||
(?? '?? "Show event selected")
|
||||
(Delete 'Delete "Delete event from history menu")))
|
||||
|
||||
(RPAQQ HistWindowWidth 164)
|
||||
|
||||
(RPAQQ HistEventWidth 60)
|
||||
|
||||
(RPAQQ UpdateOnDeleteFlg T)
|
||||
|
||||
(RPAQQ HistRightMenu NIL)
|
||||
|
||||
(RPAQQ HistOpMenu NIL)
|
||||
|
||||
(RPAQQ HistoryWindow NIL)
|
||||
|
||||
(RPAQQ HistoryMenu NIL)
|
||||
|
||||
(RPAQ? HistMenuExecOnly NIL)
|
||||
|
||||
(RPAQQ HISTMENUFNS (HistEventString HistHeldFn HistMenuOp HistRightButtonFn HistoryIcon HistoryMenu
|
||||
LastNEvents UpdateHistory UpdateHistoryWindow))
|
||||
(DEFINEQ
|
||||
|
||||
(|HistMenuMiddle|
|
||||
(LAMBDA (ITEM MENU KEY)
|
||||
(HistEventString
|
||||
[LAMBDA (entry) (* dgb%: "10-FEB-83 10:32")
|
||||
(* |;;| "Actions to take when the middle button is pressed on a History Window menu item.")
|
||||
(* \; "Edited 30-Oct-2020 14:36 by root")
|
||||
(PROG (N) (* PRINT "HistMenuMiddle")
|
||||
(* PRINT ITEM)
|
||||
(RETURN (CADR ITEM)))))
|
||||
|
||||
(* Put together a string which looks like input for menu.
|
||||
(|HistMenuOp|
|
||||
(LAMBDA (ITEM MENU KEY) (* \; "Edited 4-Nov-2020 19:59 by root")
|
||||
Put spaces between atoms, remove <c.r.>, and make top level NIL be "()" %.
|
||||
entry is a history list entry of form (event value . proplist)%.
|
||||
Computed entries are cached in the propList under the property HistoryString)
|
||||
|
||||
(COND
|
||||
(* |;;| "Process History Window menu items when the user clicks on one.")
|
||||
((NULL entry)
|
||||
'(" "))
|
||||
(PROG (NITEMS)
|
||||
((LISTGET (CDDDR entry)
|
||||
'HistoryString))
|
||||
(* |;;| "Need to know the number of the item (ie. ITEMNO) the user clicked on in the menu so we can compute the Exec line that corresponds to.")
|
||||
(T (PROG (newLst key (event (CAR entry))
|
||||
str)
|
||||
(SETQ ITEMNO (|\\ItemNumber| ITEM (|fetch| (MENU ITEMS) |of| MENU)))
|
||||
(* PRINT ITEMNO)
|
||||
(* SETQ ITEMNO (-
|
||||
ITEMNO 2))
|
||||
(SETQ ITEMEXEC (- LASTEXEC ITEMNO))
|
||||
[COND
|
||||
[(AND (EQ (SETQ key (CAR event))
|
||||
'UNDO)
|
||||
(CDR event))
|
||||
|
||||
(* Special form for UNDO. Show form of event that was undone.)
|
||||
(* |;;|
|
||||
"This method is needed to stay in sync in case the user deletes an entry form the menu.")
|
||||
|
||||
(SETQ event (APPEND event '(" -- ") (CAR (LISPXFIND LISPXHISTORY (CDR event)
|
||||
(SETQ ITEMEXEC (CAADAR (NTH |HistoryString| ITEMNO)))
|
||||
(* \;
|
||||
"The exec line of the selected item.")
|
||||
'ENTRY]
|
||||
((FMEMB key BadHistoryItems) (* Not an item to be shown in history)
|
||||
(NCONC entry (LIST 'HistoryString 'Deleted))
|
||||
(* |;;| " Stuff the appropriate text into the Exec window. Since it actually goes into the window that has the caret first check to see if the window with focus is an Exec window. Note the original HISTMENU did not do this.")
|
||||
(* PRINT "HistMenuOp KEY=")
|
||||
(* PRINT KEY)
|
||||
(|if| (NEQ (STRPOS "EXEC" (PROCESSPROP (TTY.PROCESS)
|
||||
'NAME))
|
||||
NIL)
|
||||
|then| (SELECTQ KEY
|
||||
(LEFT (BKSYSBUF (CONCAT "REDO " ITEMEXEC))
|
||||
(BKSYSCHARCODE (CHARCODE CR)))
|
||||
(MIDDLE (SETQ MRET (MENU MMENU))(* \;
|
||||
"Show the middle button menu and return which item was selected.")
|
||||
(* PRINT MRET)
|
||||
(SETQ MRET (CADR MRET))
|
||||
(SELECTQ MRET
|
||||
(REDO (BKSYSBUF (CONCAT "REDO " ITEMEXEC))
|
||||
(BKSYSCHARCODE (CHARCODE CR)))
|
||||
(FIX (BKSYSBUF (CONCAT "FIX " ITEMEXEC))
|
||||
(BKSYSCHARCODE (CHARCODE CR)))
|
||||
(UNDO (BKSYSBUF (CONCAT "UNDO " ITEMEXEC))
|
||||
(BKSYSCHARCODE (CHARCODE CR)))
|
||||
(?? (BKSYSBUF (CONCAT "?? " ITEMEXEC))
|
||||
(BKSYSCHARCODE (CHARCODE CR)))
|
||||
(|Deleted| (* PRINT "DELETE")
|
||||
(* PRINT ITEMNO)
|
||||
(SETQ NITEMS (LENGTH |HistoryString|))
|
||||
(RETURN 'Deleted]
|
||||
(SETQ newLst (TCONC NIL key))
|
||||
(for tail item on (CDR event) do
|
||||
|
||||
(* Add item to the event description to made into a string)
|
||||
|
||||
[COND
|
||||
((EQ HISTSTR0 (SETQ item (CAR tail)))
|
||||
(* leave out <c.r.>)
|
||||
(GO SKIP))
|
||||
((NULL item)
|
||||
(SETQ item "()"))
|
||||
((ATOM item)
|
||||
(* Put in space between atoms)
|
||||
(TCONC newLst '% ]
|
||||
(TCONC newLst item)
|
||||
SKIP finally (SETQ str (APPLY 'CONCAT (CAR newLst)))
|
||||
|
||||
(* make a string using CONCAT, and put as property HistoryString)
|
||||
|
||||
[COND
|
||||
((IGREATERP (NCHARS str)
|
||||
HistEventWidth)
|
||||
(* Avoid going on too long)
|
||||
(SETQ str
|
||||
(CONCAT (SUBSTRING str 1
|
||||
HistEventWidth)
|
||||
(* |;;|
|
||||
"Remove the selected item from HistoryString:")
|
||||
" ..."]
|
||||
(NCONC entry (LIST 'HistoryString str)))
|
||||
(SETQ |HistoryString| (REMOVENTH (- ITEMNO 1)
|
||||
|HistoryString|))
|
||||
(RETURN str])
|
||||
|
||||
(* |;;|
|
||||
"Remove the selected item from HMITEMS too so they stay in sync.")
|
||||
(HistHeldFn
|
||||
[LAMBDA (item menu key) (* dgb%: " 9-FEB-83 16:36")
|
||||
(CLRPROMPT)
|
||||
(SETQ HMITEMS (REMOVENTH (- ITEMNO 1)
|
||||
HMITEMS))
|
||||
(printout PROMPTWINDOW "Will " (SELECTQ key
|
||||
(MIDDLE "do one of UNDO, FIX, ??, or Delete on ")
|
||||
(* |;;| "Now add in the earlier Exec item to the end so that both lists remain histMenuLength long. Ie. if the last item on the last was 734, go find 733 and tack it on the end.")
|
||||
"REDO ")
|
||||
(CDR item)
|
||||
T %# (PRIN3 (CAR item))
|
||||
(SETQ NBACK (LIST (MINUS (SUB1 NITEMS))))
|
||||
(SETQ |HistoryString| (APPEND |HistoryString|
|
||||
(LISPXFIND
|
||||
LISPXHISTORY NBACK
|
||||
'ENTRIES)))
|
||||
(SETQ HMITEMS
|
||||
(APPEND HMITEMS
|
||||
(LIST (LIST (CAAAR (NTH |HistoryString|
|
||||
NITEMS))))))
|
||||
T])
|
||||
|
||||
(* |;;| "And finally update the menu image.")
|
||||
(HistMenuOp
|
||||
[LAMBDA (exp menu key) (* ; "Edited 19-Sep-2022 19:20 by Matt Heffron")
|
||||
(* ; "Edited 15-Sep-2022 21:49 by Matt Heffron")
|
||||
(PROG (op)
|
||||
|
||||
(* ;; "Stuff the appropriate text into the Exec window.")
|
||||
|
||||
(* ;; "Per Michele Denber: Since it actually goes into the window that has the caret, first check to see if the window with focus is an Exec window.")
|
||||
|
||||
(* ;; "Note the original HISTMENU did not do this.")
|
||||
|
||||
(COND
|
||||
((NULL (CDR exp))
|
||||
(RETURN))
|
||||
([AND HistMenuExecOnly (NOT (FIXP (STRPOS "EXEC" (PROCESSPROP (TTY.PROCESS)
|
||||
'NAME]
|
||||
|
||||
(* ;; "It turns out that this check can be too restrictive. ")
|
||||
|
||||
(* ;;
|
||||
"E.g., It wouldn't allow for using the HistMenu in a Break window unless %"under%" an Exec process")
|
||||
|
||||
(PROMPTPRINT "Please select an Exec window for this action.")
|
||||
(RETURN)))
|
||||
(SELECTQ key
|
||||
(LEFT (SETQ op 'REDO)
|
||||
(GO DOIT))
|
||||
(MIDDLE [SETQ op (MENU (OR (AND (type? MENU HistOpMenu)
|
||||
HistOpMenu)
|
||||
(SETQ HistOpMenu (create MENU
|
||||
ITEMS _ HistOpMenuItems]
|
||||
(SELECTQ op
|
||||
(Delete (LISTPUT (CDDDR (LISPXFIND LISPXHISTORY (LIST (CDR exp))
|
||||
'ENTRY))
|
||||
(|replace| ITEMS |of| |HistMenu|
|
||||
|with| HMITEMS)
|
||||
(UPDATE/MENU/IMAGE |HistMenu|)
|
||||
(REDISPLAYW |HistWin|))
|
||||
NIL))
|
||||
(* |;;| "The RIGHTBUTTONFN of the underlying window takes precedence over the WHENSELECTEDFN of the menu filling the window so we do not put a RIGHT button entry here.")
|
||||
(RIGHT (PRINT "HistMenuOp RIGHT")
|
||||
(* SETQ MRET (CAR (MENU
|
||||
|HistRightMenu|)))
|
||||
(SETQ MRET NIL)
|
||||
(PRINT MRET)
|
||||
(SELECTQ MRET
|
||||
(|Bury| (BURYW |HistWin|))
|
||||
(|Move| (MOVEW |HistWin|))
|
||||
(|Shrink| (SHRINKW |HistWin|))
|
||||
(|Update| (|UpdateHistoryWindow|))
|
||||
NIL))
|
||||
NIL)
|
||||
|else| (PROMPTPRINT "Please select the Exec window for this action.")))))
|
||||
'HistoryString
|
||||
'Deleted)
|
||||
(|HistRightButtonFn|
|
||||
(LAMBDA (WIN) (* \; "Edited 8-Nov-2020 17:01 by root")
|
||||
(PROG (X)
|
||||
(MENU |HistRightMenu|) (* SELECTQ MRET (|Bury|
|
||||
(BURYW |HistWin|))
|
||||
(|Move| (MOVEW |HistWin|))
|
||||
(|Shrink| (SHRINKW |HistWin|))
|
||||
(|Update| (|UpdateHistoryWindow|))
|
||||
NIL)
|
||||
(RETURN WIN))))
|
||||
(RETURN (AND UpdateOnDeleteFlg (UpdateHistory menu))))
|
||||
(NIL (* ; "nothing selected")
|
||||
(|HistoryMenu|
|
||||
(LAMBDA (|histMenuLength| |histMenuPosition|) (* \; "Edited 10-Nov-2020 15:56 by root")
|
||||
(PROG (NEGLEN) (* PRINT "Start HistoryMenu")
|
||||
(OR |histMenuLength| (SETQ |histMenuLength| 30))
|
||||
|
||||
(* |;;| "The MIN here is needed in case the user starts HistoryMenu before the history has grown to the requested size.")
|
||||
|
||||
(SETQ ACTUALNITEMS (MIN (CADR LISPXHISTORY)
|
||||
|histMenuLength|))
|
||||
(SETQ NEGLEN (MINUS (MIN |histMenuLength| ACTUALNITEMS)))
|
||||
(SETQ NBACK (LIST -1 `THRU NEGLEN)) (* \; " N.B. backquote!")
|
||||
(* OR |histMenuPosition|
|
||||
(SETQ |histMenuPosition|
|
||||
(QUOTE (LASTMOUSEX LASTMOUSEY 176
|
||||
464))))
|
||||
(SETQ |HistEventWidth| (- (OR (CADDR |histMenuPosition|)
|
||||
178)
|
||||
4))
|
||||
(SETQ |HistoryString| (LISPXFIND LISPXHISTORY NBACK 'ENTRIES))
|
||||
(SETQ HMITEMS (LIST (CAAR |HistoryString|)))
|
||||
(|for| I |from| 2 |to| (MIN |histMenuLength| ACTUALNITEMS)
|
||||
|do| (* PRINT (CAAAR (NTH |HistoryString|
|
||||
I)))
|
||||
(SETQ HMITEMS (APPEND HMITEMS (LIST (LIST (CAAAR (NTH |HistoryString| I)))))))
|
||||
|
||||
(* |;;| "try (CAADAR (NTH HistoryString n)) to get item no.")
|
||||
|
||||
(SETQ MMENU (|create| MENU
|
||||
ITEMS _ '((REDO 'REDO "REDO item selected")
|
||||
(FIX 'FIX "Edit item selected")
|
||||
(UNDO 'UNDO "UNDO event selected")
|
||||
(?? '?? "Show event selected")
|
||||
(|Delete| '|Deleted| "Delete event from history menu"))
|
||||
WHENSELECTEDFN _ '|HistMenuMiddle|))
|
||||
(SETQ |HistRightMenu| (|create| MENU
|
||||
ITEMS _ '((|Bury| (BURYW |HistWin|)
|
||||
"Puts this window on the bottom.")
|
||||
(|Move| (MOVEW |HistWin|)
|
||||
"Moves window by a corner.")
|
||||
(|Shrink| (SHRINKW |HistWin|)
|
||||
|
||||
"Replaces this window with its icon (or title if it doesn't have an icon."
|
||||
)
|
||||
(|Update| (|UpdateHistoryWindow|)
|
||||
|
||||
"Update the window to show all current items."
|
||||
)))) (* SETQ |HistWin| (CREATEW
|
||||
(QUOTE (50 100 172 382))
|
||||
"History Window"))
|
||||
(SETQ |HistMenu| (|create| MENU
|
||||
ITEMS _ HMITEMS
|
||||
MENUROWS _ |histMenuLength|
|
||||
ITEMWIDTH _ |HistEventWidth|
|
||||
WHENSELECTEDFN _ '|HistMenuOp|
|
||||
MENUOUTLINESIZE _ 0))
|
||||
|
||||
(* |;;| " Remember the last Exec line no. so we know which one to FIX, etc.")
|
||||
|
||||
(SETQ LASTEXEC (CAR (HISTORY-NTH LISPXHISTORY 2)))
|
||||
(SETQ LASTEXEC (- LASTEXEC 2)) (* SETQ |HistRightButtonFn| NIL)
|
||||
(SETQ |HistWin| (ADDMENU |HistMenu| NIL |histMenuPosition|))
|
||||
(OR |histMenuPosition| (MOVEW |HistWin|))
|
||||
(WINDOWPROP |HistWin| 'RIGHTBUTTONFN '|HistRightButtonFn|)
|
||||
(WINDOWPROP |HistWin| 'TITLE "History Window")
|
||||
(WINDOWPROP |HistWin| 'BORDER 4) (* CREATEMENUEDWINDOW PUTMENUPROP
|
||||
UPDATE/MENU/IMAG WINDOWPROP HWIN
|
||||
(QUOTE RIGHTBUTTONFN)
|
||||
|HistRightButtonFn|)
|
||||
(RETURN HWIN))))
|
||||
|
||||
(REMOVENTH
|
||||
(LAMBDA (N LIST) (* \; "Edited 27-Oct-2020 16:15 by root")
|
||||
|
||||
(* |;;| "Return LIST with the Nth element removed.")
|
||||
|
||||
(|if| (OR (ZEROP N)
|
||||
(NULL LIST))
|
||||
|then| (CDR LIST)
|
||||
|else| (CONS (CAR LIST)
|
||||
(REMOVENTH (CL:1- N)
|
||||
(CDR LIST))))))
|
||||
|
||||
(|UpdateHistoryWindow|
|
||||
(LAMBDA (NEGLEN) (* \; "Edited 10-Nov-2020 15:53 by root")
|
||||
(PROG (NITEMS)
|
||||
(SETQ NITEMS (LENGTH (|fetch| ITEMS |of| |HistMenu|)))
|
||||
|
||||
(* |;;| "Need this in case HistoryMenu was started before the requested size was reached,")
|
||||
|
||||
(SETQ ACTUALNITEMS (ADD1 (MIN (CADR LISPXHISTORY)
|
||||
NITEMS)))
|
||||
(SETQ NEGLEN (MINUS ACTUALNITEMS))
|
||||
(SETQ NBACK (LIST -2 `THRU NEGLEN))
|
||||
(SETQ |HistoryString| (LISPXFIND LISPXHISTORY NBACK 'ENTRIES))
|
||||
(SETQ HMITEMS (LIST (CAAR |HistoryString|)))
|
||||
|
||||
(* |;;| "Make sure LASTEXEC again points to the most recent event since that has now changed.")
|
||||
|
||||
(SETQ LASTEXEC (CAR (HISTORY-NTH LISPXHISTORY 2)))
|
||||
(SETQ LASTEXEC (- LASTEXEC 2))
|
||||
(|for| I |from| 2 |to| ACTUALNITEMS
|
||||
|do| (SETQ HMITEMS (APPEND HMITEMS (LIST (LIST (CAAAR (NTH |HistoryString| I)))))))
|
||||
(|replace| ITEMS |of| |HistMenu| |with| HMITEMS)
|
||||
(UPDATE/MENU/IMAGE |HistMenu|)
|
||||
(WINDOWPROP |HistWin| 'BORDER 4)
|
||||
(REDISPLAYW |HistWin|))))
|
||||
|
||||
(|UpdateWistoryWindow|
|
||||
(LAMBDA NIL
|
||||
(PROG (N)
|
||||
NIL)))
|
||||
(RETURN NIL))
|
||||
(GO DOIT)))
|
||||
(RETURN))
|
||||
(RPAQQ HISTCOMS
|
||||
((FNS PRINTHISTORY ENTRY# PRINTHISTORY1 PRINTHISTORY2)
|
||||
(FNS EVALQT ENTEREVALQT USEREXEC LISPXREAD LISPXREADBUF LISPXREADP LISPXUNREAD LISPX LISPX/
|
||||
LISPX/1 LISPXEVAL LISPXSTOREVALUE HISTORYSAVE LISPXFIND LISPXGETINPUT REMEMBER
|
||||
GETEXPRESSIONFROMEVENTSPEC LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1 HISTORYMATCH
|
||||
VALUEOF VALUOF VALUOF-EVENT LISPXUSE LISPXUSE0 LISPXUSE1 LISPXSUBST LISPXUSEC LISPXFIX
|
||||
CHANGESLICE LISPXSTATE LISPXTYPEAHEAD)
|
||||
(ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST))
|
||||
(DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (\#REDOCNT 3)
|
||||
(ARCHIVEFLG T)
|
||||
(ARCHIVEFN)
|
||||
(ARCHIVELST '(NIL 0 50 100))
|
||||
(DISPLAYTERMFLG)
|
||||
(EDITHISTORY '(NIL 0 30 100))
|
||||
(HERALDSTRING)
|
||||
(LASTEXEC)
|
||||
(LASTHISTORY)
|
||||
(LISPXBUFS)
|
||||
(LISPXHIST)
|
||||
(LISPXHISTORY '(NIL 0 30 100))
|
||||
(LISPXPRINTFLG T)
|
||||
(LISPXUSERFN)
|
||||
(MAKESYSDATE)
|
||||
(PROMPT#FLG T)
|
||||
(REDOCNT)
|
||||
(SYSOUT.EXT 'SYSOUT)
|
||||
(SYSOUTFILE 'WORK)
|
||||
(SYSOUTGAG)
|
||||
(TOPLISPXBUFS)))
|
||||
(LISPXMACROS SHH RETRIEVE BEFORE AFTER OK REMEMBER\: REMEMBER TYPE-AHEAD ??T)
|
||||
(ADDVARS (LISPXFINDSPLST FROM TO THRU SUCHTHAT ALL AND)
|
||||
(BEFORESYSOUTFORMS (SETQ SYSOUTDATE (DATE))
|
||||
(PROGN (COND ((NULL FILE)
|
||||
(SETQ FILE SYSOUTFILE))
|
||||
(T (SETQ SYSOUTFILE (PACKFILENAME 'VERSION NIL 'BODY FILE))))
|
||||
(COND ((AND (NULL (FILENAMEFIELD FILE 'EXTENSION))
|
||||
(NULL (FILENAMEFIELD FILE 'VERSION)))
|
||||
(SETQ FILE (PACKFILENAME 'BODY FILE 'EXTENSION SYSOUT.EXT))))))
|
||||
(RESETFORMS (SETQ READBUF NIL)
|
||||
(SETQ READBUFSOURCE NIL)
|
||||
(SETQ TOPLISPXBUFS (OR (CLBUFS T)
|
||||
TOPLISPXBUFS))
|
||||
(COND ((EQ CLEARSTKLST T)
|
||||
(COND ((EQ NOCLEARSTKLST NIL)
|
||||
(CLEARSTK))
|
||||
(T (* |clear| |all| |stack| |pointers| EXCEPT |those| |on|
|
||||
NOCLEARSTKLST.)
|
||||
(MAPC (CLEARSTK T)
|
||||
(FUNCTION (LAMBDA (X)
|
||||
(AND (NOT (FMEMB X NOCLEARSTKLST))
|
||||
(RELSTK X))))))))
|
||||
(T (MAPC CLEARSTKLST (FUNCTION RELSTK))
|
||||
(SETQ CLEARSTKLST NIL))))
|
||||
(HISTORYSAVEFORMS)
|
||||
(LISPXCOMS |...| ?? FIX FORGET NAME ORIGINAL REDO REPEAT RETRY UNDO USE |fix|
|
||||
|forget| |name| |redo| |repeat| |retry| |undo| |use|)
|
||||
(SYSTATS (LISPXSTATS LISPX INPUTS)
|
||||
(UNDOSAVES UNDO SAVES)
|
||||
(UNDOSTATS CHANGES UNDONE)
|
||||
NIL
|
||||
(EDITCALLS CALLS TO EDITOR)
|
||||
(EDITSTATS EDIT COMMANDS)
|
||||
(EDITEVALSTATS COMMANDS INVOLVING EVALUATING A LISP EXPRESSION)
|
||||
(EDITESTATS USES OF AN E COMMAND TYPED IN DIRECTLY)
|
||||
(EDITISTATS USES OF AN I COMMAND TYPED IN DIRECTLY)
|
||||
(EDITUNDOSAVES EDIT UNDO SAVES)
|
||||
(EDITUNDOSTATS EDIT CHANGES UNDONE)
|
||||
NIL
|
||||
(P.A.STATS P.A. COMMANDS)
|
||||
NIL
|
||||
(CLISPIFYSTATS CALLS TO CLISPIFY)
|
||||
NIL
|
||||
(FIXCALLS CALLS TO DWIM)
|
||||
(FIXTIME)
|
||||
(ERRORCALLS WERE DUE TO ERRORS)
|
||||
(DWIMIFYFIXES WERE FROM DWIMIFYING)
|
||||
NIL "OF THOSE DUE TO ERRORS:" (TYPEINFIXES WERE DUE TO ERRORS IN TYPE-IN)
|
||||
(PROGFIXES WERE DUE TO ERRORS IN USER PROGRAMS)
|
||||
(SUCCFIXES1 OF THESE CALLS WERE SUCCESSFUL)
|
||||
NIL "OF THE CALLS DUE TO DWIMIFYING:" (SUCCFIXES2 WERE SUCCESSFUL)
|
||||
NIL
|
||||
(SPELLSTATS OF ALL DWIM CORRECTIONS WERE SPELLING CORRECTIONS)
|
||||
(CLISPSTATS WERE CLISP TRANSFORMATIONS)
|
||||
(INFIXSTATS OF THESE WERE INFIX TRANSFORMATIONS)
|
||||
(IFSTATS WERE IF/THEN/ELSE STATEMENTS)
|
||||
(I.S.STATS WERE ITERATIVE STATEMENTS)
|
||||
(MATCHSTATS WERE PATTERN MATCHES)
|
||||
(RECORDSTATS WERE RECORD OPERATIONS)
|
||||
NIL
|
||||
(SPELLSTATS1 OTHER SPELLING CORRECTIONS\, E.G. EDIT COMMANDS)
|
||||
NIL
|
||||
(RUNONSTATS OF ALL SPELLING CORRECTIONS WERE RUN-ON CORRECTIONS)
|
||||
NIL
|
||||
(VETOSTATS CORRECTIONS WERE VETOED)
|
||||
NIL)
|
||||
(NOCLEARSTKLST))
|
||||
(APPENDVARS (AFTERSYSOUTFORMS (COND ((LISTP SYSOUTGAG)
|
||||
(EVAL SYSOUTGAG))
|
||||
(SYSOUTGAG)
|
||||
((OR (NULL USERNAME)
|
||||
(EQ USERNAME (USERNAME NIL T)))
|
||||
(TERPRI T)
|
||||
(PRIN1 HERALDSTRING T)
|
||||
(TERPRI T)
|
||||
(TERPRI T)
|
||||
(GREET0)
|
||||
(TERPRI T))
|
||||
(T (LISPXPRIN1 '"****ATTENTION USER " T)
|
||||
(LISPXPRIN1 (USERNAME)
|
||||
T)
|
||||
(LISPXPRIN1 '":
|
||||
this sysout is initialized for user " T)
|
||||
(LISPXPRIN1 USERNAME T)
|
||||
(LISPXPRIN1 '".
|
||||
" T)
|
||||
(LISPXPRIN1 '"To reinitialize, type GREET()
|
||||
" T)))
|
||||
(SETINITIALS)))
|
||||
(P (MAPC SYSTATS (FUNCTION (LAMBDA (X)
|
||||
(AND (LISTP X)
|
||||
(EQ (GETTOPVAL (CAR X))
|
||||
'NOBIND)
|
||||
(SETTOPVAL (CAR X)
|
||||
NIL)))))
|
||||
(PUTD 'E))
|
||||
(COMS (FNS GREET GREET0)
|
||||
(ADDVARS (PREGREETFORMS (DREMOVE GREETFORM RESETFORMS)
|
||||
(SETQ CONSOLETIME (SETQ CPUTIME (SETQ EDITIME 0)))
|
||||
(SETQ CONSOLETIME0 (CLOCK 0))
|
||||
(SETQ CPUTIME0 (CLOCK 2)))
|
||||
(POSTGREETFORMS (SETINITIALS)
|
||||
(AND EDITCHARACTERS (APPLY 'SETTERMCHARS EDITCHARACTERS))))
|
||||
(DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (GREETHIST)
|
||||
(SYSTEMTYPE)
|
||||
(GREETFORM '(LISPXEVAL '(GREET)
|
||||
'_))
|
||||
(CUTEFLG)
|
||||
(GREETDATES '((" 1-JAN" . "Happy new year")
|
||||
("12-FEB"
|
||||
. "Happy Lincoln's birthday")
|
||||
("14-FEB"
|
||||
. "Happy Valentine's day")
|
||||
("22-FEB"
|
||||
. "Happy Washington's birthday")
|
||||
("15-MAR"
|
||||
. "Beware the Ides of March")
|
||||
("17-MAR"
|
||||
. "Happy St. Patrick's day")
|
||||
("18-MAY" . "It's Victoria Day")
|
||||
(" 1-JUL" . "It's Canada Day")
|
||||
("31-OCT" . "Trick or Treat")
|
||||
(" 5-NOV"
|
||||
. "<boom> it's Guy Fawkes day")
|
||||
("25-DEC" . "Merry Christmas")))
|
||||
(USERNAME)
|
||||
(HOSTNAME)
|
||||
(CONSOLETIME 0)
|
||||
(CONSOLETIME0 0)
|
||||
(CPUTIME 0)
|
||||
(CPUTIME0 0)
|
||||
(EDITIME 0)
|
||||
(FIRSTNAME))
|
||||
(ADDVARS (BEFOREMAKESYSFORMS (SETQ RESETFORMS (CONS GREETFORM RESETFORMS))
|
||||
(SETQ MAKESYSDATE (DATE))))
|
||||
(ADDVARS (AFTERMAKESYSFORMS (LISPXEVAL '(GREET)
|
||||
'_)))))
|
||||
(FNS LISPXPRINT LISPXPRIN1 LISPXPRIN2 LISPXPRINTDEF LISPXPRINTDEF0 LISPXSPACES LISPXTERPRI
|
||||
LISPXTAB USERLISPXPRINT LISPXPUT)
|
||||
(GLOBALVARS \#REDOCNT ARCHIVEFLG ARCHIVEFN ARCHIVELST BOUNDPDUMMY BREAKRESETVALSLST
|
||||
CAR/CDRNIL CHCONLST1 CLEARSTKLST CLISPARRAY CLISPCHARS CLISPFLG CLISPTRANFLG
|
||||
CONSOLETIME CONSOLETIME0 CPUTIME CPUTIME0 CTRLUFLG CUTEFLG DISPLAYTERMFLG DWIMFLG
|
||||
EDITHISTORY EDITIME EDITQUIETFLG EDITSTATS EVALQTFORMS FILERDTBL FIRSTNAME GREETDATES
|
||||
GREETHIST HISTORYCOMS HISTORYSAVEFN HISTORYSAVEFORMS HISTSTR0 HISTSTR2 HISTSTR3 IT
|
||||
LASTHISTORY LISP-RELEASE-VERSION LISPXBUFS LISPXCOMS LISPXFINDSPLST LISPXFNS
|
||||
LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS LISPXPRINTFLG LISPXREADFN LISPXSTATS
|
||||
LISPXUSERFN MACSCRATCHSTRING NEWUSERFLG P.A.STATS POSTGREETFORMS PREGREETFORMS
|
||||
PRETTYHEADER RANDSTATE READBUFSOURCE REDOCNT REREADFLG RESETFORMS SYSFILES
|
||||
TOPLISPXBUFS USERHANDLE USERNAME)
|
||||
(VARS (LISP-RELEASE-VERSION 2.0))
|
||||
(BLOCKS (LISPXFINDBLOCK LISPXFIND LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1
|
||||
(ENTRIES LISPXFIND HISTORYFIND)
|
||||
(LOCALFREEVARS _FLG L LST Z =FLG HISTORYFLG PREDFLG LINE HISTORY TYPE BACKUP
|
||||
QUIETFLG)
|
||||
(NOLINKFNS HISTORYMATCH LISPXGETINPUT))
|
||||
(NIL ENTRY# EVALQT GETEXPRESSIONFROMEVENTSPEC GREET GREET0 HISTORYMATCH HISTORYSAVE
|
||||
LISPX LISPX/ LISPX/1 LISPXEVAL LISPXFIND1 LISPXGETINPUT LISPXPRIN1 LISPXPRIN2
|
||||
LISPXPRINT LISPXPRINTDEF LISPXPRINTDEF0 LISPXPUT LISPXREAD LISPXREADBUF
|
||||
LISPXREADP LISPXSPACES LISPXSTOREVALUE LISPXSUBST LISPXTAB LISPXTERPRI
|
||||
LISPXTYPEAHEAD LISPXUNREAD LISPXUSE LISPXUSE0 LISPXUSE1 LISPXUSEC PRINTHISTORY
|
||||
PRINTHISTORY1 PRINTHISTORY2 USEREXEC USERLISPXPRINT VALUEOF VALUOF (LOCALVARS
|
||||
. T)
|
||||
(SPECVARS LISPXLINE LISPXID LISPXVALUE LISPXLISTFLG HISTORY ID EVENT
|
||||
BREAKRESETVALS VARS GENLST INITLST NAME MESSAGE)
|
||||
(LINKFNS . T)
|
||||
(NOLINKFNS LISPXTYPEAHEAD UNDOLISPX ARCHIVEFN LISPXFIX LISPXUSE LISPXUSE0
|
||||
LISPXSUBST LISPXFIND HISTORYMATCH PRINTHISTORY DISPLAYTERMP
|
||||
LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT PRINTHISTORY1 PRINTHISTORY2
|
||||
LISPXFIND HISTORYMATCH LISPXGETINPUT LISPXSUBST ARCHIVEFN LISPXFIX
|
||||
LISPXUSE LISPXUSE0 LISPXSUBST HISTORYMATCH PRINTHISTORY DISPLAYTERMP
|
||||
LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT LISPXTYEAHEAD UNDOLISPX
|
||||
GREETFILENAME)))
|
||||
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA VALUEOF)
|
||||
(NLAML)
|
||||
(LAMA)))))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (731 14594 (|HistMenuMiddle| 741 . 1200) (|HistMenuOp| 1202 . 7581) (|HistRightButtonFn|
|
||||
7583 . 8274) (|HistoryMenu| 8276 . 12906) (REMOVENTH 12908 . 13307) (|UpdateHistoryWindow| 13309 .
|
||||
14523) (|UpdateWistoryWindow| 14525 . 14592)))))
|
||||
DOIT
|
||||
(BKSYSBUF op) (* ;
|
||||
"Insert op space event identifier in system buffer")
|
||||
(BKSYSBUF " ")
|
||||
(BKSYSBUF (CDR exp))
|
||||
(BKSYSCHARCODE (CHARCODE CR))
|
||||
NIL])
|
||||
|
||||
(HistRightButtonFn
|
||||
[LAMBDA (WINDOW) (* dgb%: "31-MAR-83 18:12")
|
||||
|
||||
(* Sets up Menu, and then does usual right window stuff, augmented by
|
||||
UpdateHistoryWindow)
|
||||
|
||||
[OR (type? MENU (EVALV 'HistRightMenu))
|
||||
|
||||
Binary file not shown.
Binary file not shown.
19
lispusers/IDLEDEMO
Normal file
19
lispusers/IDLEDEMO
Normal file
@@ -0,0 +1,19 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Aug-2022 23:35:58" {DSK}<home>larry>medley>lispusers>IDLEDEMO.;1 565
|
||||
|
||||
:CHANGES-TO (VARS IDLE.FILES))
|
||||
|
||||
|
||||
(PRETTYCOMPRINT IDLEDEMOCOMS)
|
||||
|
||||
(RPAQQ IDLEDEMOCOMS ((FILES * IDLE.FILES)))
|
||||
|
||||
(RPAQQ IDLE.FILES (SOLITAIRE SCREENPAPER READBRUSH PAC-MAN-IDLE LIFE IDLEHAX BICLOCK KINETIC STARBG
|
||||
HANOI QIX))
|
||||
|
||||
(FILESLOAD SOLITAIRE SCREENPAPER READBRUSH PAC-MAN-IDLE LIFE IDLEHAX BICLOCK KINETIC STARBG HANOI QIX
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
@@ -1,12 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Jun-2022 18:21:17"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>IDLEHAX.;4 26796
|
||||
(FILECREATED "28-Sep-2022 19:53:38" {DSK}<home>larry>medley>lispusers>IDLEHAX.;2 31965
|
||||
|
||||
:CHANGES-TO (FNS KAL.ADVANCE)
|
||||
:CHANGES-TO (FNS IDLE-SWAP)
|
||||
|
||||
:PREVIOUS-DATE " 9-Feb-2022 13:53:05"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>IDLEHAX.;3)
|
||||
:PREVIOUS-DATE "23-Aug-2022 08:50:16" {DSK}<home>larry>medley>lispusers>IDLEHAX.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -98,7 +96,7 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
|
||||
(CONNECTPOLYS
|
||||
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* ; "Edited 12-Jan-2022 15:22 by larry")
|
||||
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* ; "Edited 23-Aug-2022 08:10 by larry")
|
||||
(* lmm "30-Jul-85 17:19")
|
||||
(PROG (DIFFS)
|
||||
(CLEARW W)
|
||||
@@ -120,8 +118,8 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(fetch YC of FPT)
|
||||
(fetch XC of TPT)
|
||||
(fetch YC of TPT)
|
||||
1 OPERATION W))
|
||||
(DISMISS POLYGONWAIT2)
|
||||
1 OPERATION W)
|
||||
(DISMISS POLYGONWAIT2))
|
||||
(CLEARW W)
|
||||
(for I from 1 to POLYGONSTEPS do (DISMISS POLYGONWAIT3)
|
||||
(LINES2 FROMS 1 W OPERATION)
|
||||
@@ -148,7 +146,7 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
|
||||
(RPAQ? POLYGONSWINDOW )
|
||||
|
||||
(RPAQQ POLYGONWAIT2 250)
|
||||
(RPAQQ POLYGONWAIT2 25)
|
||||
|
||||
(RPAQQ POLYGONMINPTS 3)
|
||||
|
||||
@@ -191,8 +189,67 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(KALDEMO
|
||||
(LAMBDA (W PERIOD PERSISTENCE) (* lmm " 5-Aug-85 22:16") (OR PERIOD (SETQ PERIOD (RAND 8 128))) (OR PERSISTENCE (SETQ PERSISTENCE (LSH 1 (RAND 4 13)))) (SETQ W (DEMOWINDOW W)) (LET ((XSTATEB (create KALSTATE A _ 1 B _ -1849 C _ (RAND 2 4) PERIOD _ PERIOD PERIODCOUNT _ 1)) (XSTATEE (create KALSTATE)) (YSTATEB (create KALSTATE A _ 1 B _ -1809 C _ (RAND 0 20) PERIOD _ PERIOD PERIODCOUNT _ 1)) (YSTATEE (create KALSTATE)) (WINDOWSIDE (MIN (WINDOWPROP W (QUOTE HEIGHT)) (WINDOWPROP W (QUOTE WIDTH)))) (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS))) (BLACK (NOT (VIDEOCOLOR))) XOFFSET) (SETQ XOFFSET (QUOTIENT (MAX (DIFFERENCE (WINDOWPROP W (QUOTE WIDTH)) WINDOWSIDE) 0) 2)) (SETQ XSTATEE (COPY XSTATEB)) (SETQ YSTATEE (COPY YSTATEB)) (from 1 to PERSISTENCE do (KAL.ADVANCE XSTATEB) (KAL.ADVANCE YSTATEB) (KAL.SPOTS (ffetch A of XSTATEB) (ffetch A of YSTATEB) WINDOWSIDE W BLACK XOFFSET) (PERIODIC.BLOCK TIMER)) (do (KAL.ADVANCE XSTATEE) (KAL.ADVANCE YSTATEE) (PROG ((X0 (LOGAND (LRSH (ffetch A of XSTATEE) 7) KAL.MASK)) (Y0 (LOGAND (LRSH (ffetch A of YSTATEE) 7) KAL.MASK)) X1 Y1) (COND ((ILESSP X0 Y0) (SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE) X0)) (SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE) Y0)) (KAL.BMS W X0 Y0 X1 Y1 (if BLACK then 1 else 0) XOFFSET)))) (KAL.ADVANCE XSTATEB) (KAL.ADVANCE YSTATEB) (KAL.SPOTS (ffetch A of XSTATEB) (ffetch A of YSTATEB) WINDOWSIDE W BLACK XOFFSET) (PERIODIC.BLOCK TIMER))))
|
||||
)
|
||||
[LAMBDA (W PERIOD PERSISTENCE) (* ; "Edited 23-Aug-2022 08:49 by lmm")
|
||||
(* lmm " 5-Aug-85 22:16")
|
||||
(OR PERIOD (SETQ PERIOD (RAND 16 128)))
|
||||
[OR PERSISTENCE (SETQ PERSISTENCE (LSH 1 (RAND 14 23]
|
||||
(SETQ W (DEMOWINDOW W))
|
||||
(LET ((XSTATEB (create KALSTATE
|
||||
A _ 1
|
||||
B _ -1849
|
||||
C _ (RAND 2 4)
|
||||
PERIOD _ PERIOD
|
||||
PERIODCOUNT _ 1))
|
||||
(XSTATEE (create KALSTATE))
|
||||
(YSTATEB (create KALSTATE
|
||||
A _ 1
|
||||
B _ -1809
|
||||
C _ (RAND 0 20)
|
||||
PERIOD _ PERIOD
|
||||
PERIODCOUNT _ 1))
|
||||
(YSTATEE (create KALSTATE))
|
||||
[WINDOWSIDE (MIN (WINDOWPROP W 'HEIGHT)
|
||||
(WINDOWPROP W 'WIDTH]
|
||||
(TIMER (SETUPTIMER 0 NIL 'TICKS))
|
||||
(BLACK (NOT (VIDEOCOLOR)))
|
||||
XOFFSET)
|
||||
(SETQ XOFFSET (QUOTIENT (MAX (DIFFERENCE (WINDOWPROP W 'WIDTH)
|
||||
WINDOWSIDE)
|
||||
0)
|
||||
2))
|
||||
(SETQ XSTATEE (COPY XSTATEB))
|
||||
(SETQ YSTATEE (COPY YSTATEB))
|
||||
(from 1 to PERSISTENCE do (KAL.ADVANCE XSTATEB)
|
||||
(KAL.ADVANCE YSTATEB)
|
||||
(KAL.SPOTS (ffetch A of XSTATEB)
|
||||
(ffetch A of YSTATEB)
|
||||
WINDOWSIDE W BLACK XOFFSET)
|
||||
(BLOCK 100 TIMER))
|
||||
(do (KAL.ADVANCE XSTATEE)
|
||||
(KAL.ADVANCE YSTATEE)
|
||||
[PROG ((X0 (LOGAND (LRSH (ffetch A of XSTATEE)
|
||||
7)
|
||||
KAL.MASK))
|
||||
(Y0 (LOGAND (LRSH (ffetch A of YSTATEE)
|
||||
7)
|
||||
KAL.MASK))
|
||||
X1 Y1)
|
||||
(COND
|
||||
((ILESSP X0 Y0)
|
||||
(SETQ X1 (IDIFFERENCE (SUB1 WINDOWSIDE)
|
||||
X0))
|
||||
(SETQ Y1 (IDIFFERENCE (SUB1 WINDOWSIDE)
|
||||
Y0))
|
||||
(KAL.BMS W X0 Y0 X1 Y1 (if BLACK
|
||||
then 1
|
||||
else 0)
|
||||
XOFFSET]
|
||||
(KAL.ADVANCE XSTATEB)
|
||||
(KAL.ADVANCE YSTATEB)
|
||||
(KAL.SPOTS (ffetch A of XSTATEB)
|
||||
(ffetch A of YSTATEB)
|
||||
WINDOWSIDE W BLACK XOFFSET)
|
||||
(PERIODIC.BLOCK TIMER])
|
||||
|
||||
(KAL.ADVANCE
|
||||
[LAMBDA (STATE) (* ; "Edited 26-Jun-2022 18:20 by rmk")
|
||||
@@ -231,8 +288,59 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(BUBBLES
|
||||
(LAMBDA (W) (* lmm "30-Jul-85 20:35") (WINDOWPROP (SETQ W (DEMOWINDOW W)) (QUOTE RESHAPEFN) (FUNCTION (LAMBDA (W) (DSPFILL NIL (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) (QUOTE REPLACE) W)))) (DSPFILL NIL (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) (QUOTE REPLACE) W) (bind (ARRAY _ (ARRAY BUBBLECNT (QUOTE POINTER))) (I _ 1) CIRCLE eachtime (SETQ I (if (EQ I BUBBLECNT) then 1 else (ADD1 I))) do (* * first erase the circle at I in array) (SETQ CIRCLE (ELT ARRAY I)) (DSPOPERATION (if (VIDEOCOLOR) then (QUOTE ERASE) else (QUOTE PAINT)) W) (* there will be no circle at I the first time through) (AND CIRCLE (DRAWCIRCLE (CAR CIRCLE) (CADR CIRCLE) (CADDR CIRCLE) NIL NIL W)) (* * now put a new circle in array at I and draw it) (SETQ CIRCLE (SETA ARRAY I (BUBBLE.CREATE W))) (DSPOPERATION (QUOTE REPLACE) W) (* fill center w/ black so it ocludes ones under) (FILLCIRCLE (CAR CIRCLE) (CADR CIRCLE) (SUB1 (CADDR CIRCLE)) (if (VIDEOCOLOR) then WHITESHADE else BLACKSHADE) W) (DSPOPERATION (QUOTE INVERT) W) (DRAWCIRCLE (CAR CIRCLE) (CADR CIRCLE) (CADDR CIRCLE) NIL NIL W) (BLOCK)))
|
||||
)
|
||||
[LAMBDA (W) (* ; "Edited 23-Aug-2022 08:14 by larry")
|
||||
(* lmm "30-Jul-85 20:35")
|
||||
[WINDOWPROP (SETQ W (DEMOWINDOW W))
|
||||
'RESHAPEFN
|
||||
(FUNCTION (LAMBDA (W)
|
||||
(DSPFILL NIL (if (VIDEOCOLOR)
|
||||
then WHITESHADE
|
||||
else BLACKSHADE)
|
||||
'REPLACE W]
|
||||
(DSPFILL NIL (if (VIDEOCOLOR)
|
||||
then WHITESHADE
|
||||
else BLACKSHADE)
|
||||
'REPLACE W)
|
||||
(bind (ARRAY _ (ARRAY BUBBLECNT 'POINTER))
|
||||
(I _ 1)
|
||||
CIRCLE eachtime (SETQ I (if (EQ I BUBBLECNT)
|
||||
then 1
|
||||
else (ADD1 I))) do
|
||||
|
||||
(* * first erase the circle at I in array)
|
||||
|
||||
(SETQ CIRCLE (ELT ARRAY I))
|
||||
(DSPOPERATION (if (VIDEOCOLOR)
|
||||
then 'ERASE
|
||||
else 'PAINT)
|
||||
W)
|
||||
(* there will be no circle at I the
|
||||
first time through)
|
||||
(AND CIRCLE (DRAWCIRCLE (CAR CIRCLE)
|
||||
(CADR CIRCLE)
|
||||
(CADDR CIRCLE)
|
||||
NIL NIL W))
|
||||
|
||||
(* * now put a new circle in array at I and draw it)
|
||||
|
||||
(SETQ CIRCLE (SETA ARRAY I (BUBBLE.CREATE
|
||||
W)))
|
||||
(DSPOPERATION 'REPLACE W)
|
||||
(* fill center w/ black so it ocludes
|
||||
ones under)
|
||||
(FILLCIRCLE (CAR CIRCLE)
|
||||
(CADR CIRCLE)
|
||||
(SUB1 (CADDR CIRCLE))
|
||||
(if (VIDEOCOLOR)
|
||||
then WHITESHADE
|
||||
else BLACKSHADE)
|
||||
W)
|
||||
(DSPOPERATION 'INVERT W)
|
||||
(DRAWCIRCLE (CAR CIRCLE)
|
||||
(CADR CIRCLE)
|
||||
(CADDR CIRCLE)
|
||||
NIL NIL W)
|
||||
(BLOCK 100])
|
||||
|
||||
(BUBBLE.CREATE
|
||||
(LAMBDA (W) (* drc%: "29-Jul-85 13:51") (LET* ((REGION (WINDOWPROP W (QUOTE REGION))) (WIDTH (SUB1 (fetch WIDTH of REGION))) (HEIGHT (SUB1 (fetch HEIGHT of REGION))) (CENTERX (RAND 1 (SUB1 WIDTH))) (CENTERY (RAND 1 (SUB1 HEIGHT)))) (LIST CENTERX CENTERY (RAND 1 (IMIN (IDIFFERENCE WIDTH CENTERX) CENTERX (IDIFFERENCE HEIGHT CENTERY) CENTERY)))))
|
||||
@@ -243,8 +351,32 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-WINDOWS
|
||||
(LAMBDA (W DELAY) (* lmm " 7-Jun-86 22:21") (SETQ W (DEMOWINDOW W)) (PROG ((D (WINDOWPROP W (QUOTE WIDTH))) (H (WINDOWPROP W (QUOTE HEIGHT))) (TIMER (SETUPTIMER 0 NIL (QUOTE TICKS)))) (LET ((TITLE (WINDOWPROP (CREATEW (LIST 0 0 D (HEIGHTIFWINDOW 0 T)) "Yet another window" NIL T) (QUOTE IMAGECOVERED)))) (while T do (PROG ((X (RAND 0 (- D (+ 2 2 100)))) (Y (RAND 0 (- H 8 100)))) (PROG ((D0 (MAX 100 (RAND 100 (- D X)))) (H0 (MAX 100 (RAND 100 (- H Y))))) (BITBLT NIL NIL NIL W X Y D0 2 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL W X Y 2 H0 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT NIL NIL NIL W (+ X (- D0 2)) Y 2 H0 (QUOTE TEXTURE) (QUOTE REPLACE) BLACKSHADE) (BITBLT TITLE NIL (+ WBorder (QUOTIENT WBorder 2)) W X (+ Y H0) D0 NIL NIL (QUOTE REPLACE)) (BITBLT NIL NIL NIL W (+ X 2) (+ Y 2) (- D0 (+ 2 2)) (- H0 2) (QUOTE TEXTURE) (QUOTE ERASE) BLACKSHADE))) (if DELAY then (BLOCK DELAY) else (PERIODIC.BLOCK TIMER))))))
|
||||
)
|
||||
[LAMBDA (W DELAY) (* ; "Edited 23-Aug-2022 08:35 by lmm")
|
||||
(* lmm " 7-Jun-86 22:21")
|
||||
(SETQ W (DEMOWINDOW W))
|
||||
(PROG [(D (WINDOWPROP W 'WIDTH))
|
||||
(H (WINDOWPROP W 'HEIGHT]
|
||||
(LET [(TITLE (WINDOWPROP (CREATEW (LIST 0 0 D (HEIGHTIFWINDOW 0 T))
|
||||
"Yet another window" NIL T)
|
||||
'IMAGECOVERED]
|
||||
(while T do (PROG [[X (RAND 0 (- D (+ 2 2 100]
|
||||
(Y (RAND 0 (- H 8 100]
|
||||
(PROG [[D0 (MAX 100 (RAND 100 (- D X]
|
||||
(H0 (MAX 100 (RAND 100 (- H Y]
|
||||
(BITBLT NIL NIL NIL W X Y D0 2 'TEXTURE 'REPLACE BLACKSHADE)
|
||||
(BITBLT NIL NIL NIL W X Y 2 H0 'TEXTURE 'REPLACE BLACKSHADE)
|
||||
(BITBLT NIL NIL NIL W (+ X (- D0 2))
|
||||
Y 2 H0 'TEXTURE 'REPLACE BLACKSHADE)
|
||||
(BITBLT TITLE NIL (+ WBorder (QUOTIENT WBorder 2))
|
||||
W X (+ Y H0)
|
||||
D0 NIL NIL 'REPLACE)
|
||||
(BITBLT NIL NIL NIL W (+ X 2)
|
||||
(+ Y 2)
|
||||
(- D0 (+ 2 2))
|
||||
(- H0 2)
|
||||
'TEXTURE
|
||||
'ERASE BLACKSHADE)))
|
||||
(BLOCK (OR DELAY 500])
|
||||
)
|
||||
|
||||
|
||||
@@ -258,8 +390,18 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
|
||||
(LINES1
|
||||
(LAMBDA (ENDPOINTS LINES DSP) (* lmm "30-Jul-85 17:33") (PROG (PTS) (COND ((SETQ PTS (CAR LINES)) (* ERASE OLD) (LINES3 (CAR LINES) 1 DSP (QUOTE INVERT) ENDPOINTS)) (T (RPLACA LINES (SETQ PTS (in ENDPOINTS collect (create NPOINT)))) (LINES2 ENDPOINTS 1 DSP (QUOTE INVERT)))) (for PT in PTS as EP in ENDPOINTS do (replace XC of PT with (fetch XC of EP)) (replace YC of PT with (fetch YC of EP)))))
|
||||
)
|
||||
[LAMBDA (ENDPOINTS LINES DSP) (* ; "Edited 23-Aug-2022 07:59 by larry")
|
||||
(* lmm "30-Jul-85 17:33")
|
||||
(PROG (PTS)
|
||||
[COND
|
||||
((SETQ PTS (CAR LINES)) (* ERASE OLD)
|
||||
(LINES3 (CAR LINES)
|
||||
1 DSP 'INVERT ENDPOINTS))
|
||||
(T [RPLACA LINES (SETQ PTS (in ENDPOINTS collect (create NPOINT]
|
||||
(LINES2 ENDPOINTS 1 DSP 'INVERT]
|
||||
(BLOCK 75)
|
||||
(for PT in PTS as EP in ENDPOINTS do (replace XC of PT with (fetch XC of EP))
|
||||
(replace YC of PT with (fetch YC of EP])
|
||||
|
||||
(LINES2
|
||||
(LAMBDA (ENDPOINTS WIDTH WINDOW OPERATION) (* lmm "30-Jul-85 17:14") (for (X _ ENDPOINTS) while (OR (CDR X) (if (CDDR ENDPOINTS) then X)) do (DRAWLINE (fetch XC (CAR X)) (fetch YC (CAR X)) (fetch XC (CAR (OR (SETQ X (CDR X)) ENDPOINTS))) (fetch YC (CAR (OR X ENDPOINTS))) WIDTH OPERATION WINDOW)))
|
||||
@@ -283,8 +425,20 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
|
||||
(WARP
|
||||
(LAMBDA (W) (* hdj " 1-Apr-86 14:22") (do (CLEARW W) (LET ((OLDOP (DSPOPERATION (QUOTE INVERT) W))) (LET ((WIDTH (WINDOWPROP W (QUOTE WIDTH))) (HEIGHT (WINDOWPROP W (QUOTE HEIGHT)))) (LET ((CENTERX (RAND 0 WIDTH)) (CENTERY (RAND 0 HEIGHT))) (for RADIUS from (RAND 5 250) to 5 by -2 do (FILLCIRCLE (PLUS CENTERX (RAND 0 2)) (PLUS CENTERY (RAND 0 2)) RADIUS BLACKSHADE W) (BLOCK)))) (DSPOPERATION OLDOP W))))
|
||||
)
|
||||
[LAMBDA (W) (* ; "Edited 23-Aug-2022 08:01 by larry")
|
||||
(* hdj " 1-Apr-86 14:22")
|
||||
(do (CLEARW W)
|
||||
(LET ((OLDOP (DSPOPERATION 'INVERT W)))
|
||||
[LET [(WIDTH (WINDOWPROP W 'WIDTH))
|
||||
(HEIGHT (WINDOWPROP W 'HEIGHT]
|
||||
(LET ((CENTERX (RAND 0 WIDTH))
|
||||
(CENTERY (RAND 0 HEIGHT)))
|
||||
(for RADIUS from (RAND 5 250) to 5 by -2
|
||||
do (FILLCIRCLE (PLUS CENTERX (RAND 0 2))
|
||||
(PLUS CENTERY (RAND 0 2))
|
||||
RADIUS BLACKSHADE W)
|
||||
(BLOCK 75]
|
||||
(DSPOPERATION OLDOP W])
|
||||
)
|
||||
|
||||
|
||||
@@ -294,7 +448,8 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-MELT
|
||||
[LAMBDA (WINDOW SIZE INITIAL PATH) (* ; "Edited 10-Jun-88 17:15 by MASINTER")
|
||||
[LAMBDA (WINDOW SIZE INITIAL PATH) (* ; "Edited 23-Aug-2022 08:20 by larry")
|
||||
(* ; "Edited 10-Jun-88 17:15 by MASINTER")
|
||||
(OR SIZE (SETQ SIZE MELT-BLOCK-SIZE))
|
||||
(SETQ WINDOW (DEMOWINDOW WINDOW))
|
||||
(PROG ((W (WINDOWPROP WINDOW 'WIDTH))
|
||||
@@ -307,37 +462,34 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
[SETQ BM (OR (CAR TAIL)
|
||||
(WINDOWPROP WINDOW 'IMAGECOVERED]
|
||||
(for BITMAP inside BM do (BITBLT (SETQ BITMAP (if (BITMAPP BITMAP)
|
||||
then BITMAP
|
||||
elseif (CL:SYMBOLP BITMAP)
|
||||
then (CAR (READBRUSHFILE
|
||||
BITMAP))
|
||||
else (IDLE.BITMAP NIL
|
||||
BITMAP)))
|
||||
NIL NIL WINDOW (RAND 0 (- W (BITMAPWIDTH BITMAP
|
||||
)))
|
||||
(RAND 0 (- H (BITMAPHEIGHT BITMAP)))
|
||||
NIL NIL (if (VIDEOCOLOR)
|
||||
then NIL
|
||||
else 'INVERT)
|
||||
'REPLACE))
|
||||
then BITMAP
|
||||
elseif (CL:SYMBOLP BITMAP)
|
||||
then (CAR (READBRUSHFILE BITMAP))
|
||||
else (IDLE.BITMAP NIL BITMAP)))
|
||||
NIL NIL WINDOW (RAND 0 (- W (BITMAPWIDTH BITMAP)))
|
||||
(RAND 0 (- H (BITMAPHEIGHT BITMAP)))
|
||||
NIL NIL (if (VIDEOCOLOR)
|
||||
then NIL
|
||||
else 'INVERT)
|
||||
'REPLACE))
|
||||
(if INITIAL
|
||||
then [SETQ TIMER (AND (CADR TAIL)
|
||||
(SETUPTIMER (CADR TAIL)
|
||||
TIMER
|
||||
'SECONDS
|
||||
'SECONDS]
|
||||
(SETQ TAIL (OR (CDDR TAIL)
|
||||
INITIAL)))
|
||||
(SETUPTIMER (CADR TAIL)
|
||||
TIMER
|
||||
'SECONDS
|
||||
'SECONDS]
|
||||
(SETQ TAIL (OR (CDDR TAIL)
|
||||
INITIAL)))
|
||||
[do (LET [(X (RAND 0 (- W SIZE)))
|
||||
(Y (RAND 0 (- H SIZE]
|
||||
(BITBLT WINDOW X Y WINDOW (+ X (RAND -1 1))
|
||||
(+ Y (RAND -1 1))
|
||||
SIZE SIZE NIL 'REPLACE))
|
||||
(BLOCK) repeatuntil (AND TIMER (TIMEREXPIRED? TIMER 'SECONDS]
|
||||
(Y (RAND 0 (- H SIZE]
|
||||
(BITBLT WINDOW X Y WINDOW (+ X (RAND -1 1))
|
||||
(+ Y (RAND -1 1))
|
||||
SIZE SIZE NIL 'REPLACE))
|
||||
(BLOCK 100) repeatuntil (AND TIMER (TIMEREXPIRED? TIMER 'SECONDS]
|
||||
(GO REPAINT])
|
||||
|
||||
(IDLE-SLIDE
|
||||
[LAMBDA (W SIZE SPEED COUNT SOURCE) (* ; "Edited 10-Jun-88 17:12 by MASINTER")
|
||||
[LAMBDA (W SIZE SPEED COUNT SOURCE) (* ; "Edited 10-Jun-88 17:12 by MASINTER")
|
||||
(OR SIZE (SETQ SIZE 128))
|
||||
(OR COUNT (SETQ COUNT 120))
|
||||
(OR SPEED (SETQ SPEED 2))
|
||||
@@ -354,28 +506,28 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
X Y DX DY (CNT 1)
|
||||
DDX DDY (TIMER (SETUPTIMER 0 NIL 'TICKS]
|
||||
(do (COND
|
||||
((OR (EQ (add CNT -1)
|
||||
0)
|
||||
(< X 0)
|
||||
(> X XMAX)
|
||||
(< Y 0)
|
||||
(> Y YMAX))
|
||||
(SETQ X (RAND 0 XMAX))
|
||||
(SETQ Y (RAND 0 YMAX))
|
||||
(SETQ DX (RAND (- SPEED)
|
||||
SPEED))
|
||||
(SETQ DY (RAND (- SPEED)
|
||||
SPEED))
|
||||
(BITBLT SOURCE X Y W X Y SIZE SIZE NIL 'REPLACE)
|
||||
(SETQ DDX DY)
|
||||
(SETQ DDY DX)
|
||||
(SETQ CNT COUNT)))
|
||||
(BITBLT W X Y W (+ X DDX)
|
||||
(+ Y DDY)
|
||||
SIZE SIZE NIL 'REPLACE)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(PERIODIC.BLOCK TIMER])
|
||||
((OR (EQ (add CNT -1)
|
||||
0)
|
||||
(< X 0)
|
||||
(> X XMAX)
|
||||
(< Y 0)
|
||||
(> Y YMAX))
|
||||
(SETQ X (RAND 0 XMAX))
|
||||
(SETQ Y (RAND 0 YMAX))
|
||||
(SETQ DX (RAND (- SPEED)
|
||||
SPEED))
|
||||
(SETQ DY (RAND (- SPEED)
|
||||
SPEED))
|
||||
(BITBLT SOURCE X Y W X Y SIZE SIZE NIL 'REPLACE)
|
||||
(SETQ DDX DY)
|
||||
(SETQ DDY DX)
|
||||
(SETQ CNT COUNT)))
|
||||
(BITBLT W X Y W (+ X DDX)
|
||||
(+ Y DDY)
|
||||
SIZE SIZE NIL 'REPLACE)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(PERIODIC.BLOCK TIMER])
|
||||
)
|
||||
|
||||
(RPAQQ MELT-BLOCK-SIZE 32)
|
||||
@@ -399,17 +551,16 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PERIODIC.BLOCK MACRO [(TIMER)
|
||||
(if (TIMEREXPIRED? TIMER 'TICKS)
|
||||
then (BLOCK)
|
||||
(SETQ TIMER (SETUPTIMER 100 TIMER 'TICKS 'MILLISECONDS])
|
||||
(PUTPROPS PERIODIC.BLOCK MACRO ((TIMER)
|
||||
(BLOCK 100 TIMER)))
|
||||
)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Drain" 'IDLE-DRAIN))
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-DRAIN
|
||||
[LAMBDA (WINDOW) (* hdj "28-May-86 11:52")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 23-Aug-2022 07:52 by larry")
|
||||
(* hdj "28-May-86 11:52")
|
||||
(do (BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
|
||||
NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
(LET* ((WIDTH (WINDOWPROP WINDOW 'WIDTH))
|
||||
@@ -417,7 +568,7 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(HALF-WIDTH (IQUOTIENT WIDTH 2))
|
||||
(HALF-HEIGHT (IQUOTIENT HEIGHT 2)))
|
||||
(for EDGE from 0 to (MIN HALF-WIDTH HALF-HEIGHT)
|
||||
do (BLOCK)
|
||||
do (BLOCK 100)
|
||||
(BITBLT WINDOW EDGE 0 WINDOW (PLUS 1 EDGE)
|
||||
0
|
||||
(- HALF-WIDTH EDGE)
|
||||
@@ -452,13 +603,14 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(IDLE-SWAP
|
||||
[LAMBDA (WINDOW) (* hdj "29-May-86 23:41")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 28-Sep-2022 19:48 by lmm")
|
||||
(* hdj "29-May-86 23:41")
|
||||
(DECLARE (GLOBALVARS IDLE-SWAP-SIZE))
|
||||
(BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
|
||||
NIL NIL WINDOW NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
(LET [(WIDTH (WINDOWPROP WINDOW 'WIDTH))
|
||||
(HEIGHT (WINDOWPROP WINDOW 'HEIGHT]
|
||||
(do (BLOCK (RAND 0 5000))
|
||||
(do (BLOCK 250)
|
||||
(LET [[RAND-X-1 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT WIDTH IDLE-SWAP-SIZE]
|
||||
[RAND-Y-1 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT HEIGHT IDLE-SWAP-SIZE]
|
||||
[RAND-X-2 (TIMES IDLE-SWAP-SIZE (RAND 0 (IQUOTIENT WIDTH IDLE-SWAP-SIZE]
|
||||
@@ -480,12 +632,12 @@ Copyright (c) 1985-1988, 1991, 2022 by Xerox Corporation.
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Swap" 'IDLE-SWAP))
|
||||
(PUTPROPS IDLEHAX COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1991 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3812 7852 (POLYGONSDEMO 3822 . 3992) (POLYGONS 3994 . 4358) (CONNECTPOLYS 4360 . 6758)
|
||||
(DRAWPOLY1 6760 . 7397) (RANDOMPT 7399 . 7850)) (8489 12004 (KALDEMO 8499 . 9910) (KAL.ADVANCE 9912 .
|
||||
10846) (KAL.SPOTS 10848 . 11189) (KAL.BMS 11191 . 11678) (KAL.ORAND 11680 . 12002)) (12041 13527 (
|
||||
BUBBLES 12051 . 13157) (BUBBLE.CREATE 13159 . 13525)) (13554 14539 (IDLE-WINDOWS 13564 . 14537)) (
|
||||
14574 16845 (LINES 14584 . 15643) (LINES1 15645 . 16055) (LINES2 16057 . 16368) (LINES3 16370 . 16843)
|
||||
) (16905 18118 (WALKINGSPOKE 16915 . 17696) (WARP 17698 . 18116)) (18143 22426 (IDLE-MELT 18153 .
|
||||
20669) (IDLE-SLIDE 20671 . 22424)) (22597 22843 (DEMOWINDOW 22607 . 22841)) (23255 25128 (IDLE-DRAIN
|
||||
23265 . 25126)) (25160 26641 (IDLE-SWAP 25170 . 26639)))))
|
||||
(FILEMAP (NIL (3756 7833 (POLYGONSDEMO 3766 . 3936) (POLYGONS 3938 . 4302) (CONNECTPOLYS 4304 . 6739)
|
||||
(DRAWPOLY1 6741 . 7378) (RANDOMPT 7380 . 7831)) (8469 13548 (KALDEMO 8479 . 11454) (KAL.ADVANCE 11456
|
||||
. 12390) (KAL.SPOTS 12392 . 12733) (KAL.BMS 12735 . 13222) (KAL.ORAND 13224 . 13546)) (13585 17431 (
|
||||
BUBBLES 13595 . 17061) (BUBBLE.CREATE 17063 . 17429)) (17458 19241 (IDLE-WINDOWS 17468 . 19239)) (
|
||||
19276 21944 (LINES 19286 . 20345) (LINES1 20347 . 21154) (LINES2 21156 . 21467) (LINES3 21469 . 21942)
|
||||
) (22004 23625 (WALKINGSPOKE 22014 . 22795) (WARP 22797 . 23623)) (23650 27551 (IDLE-MELT 23660 .
|
||||
25872) (IDLE-SLIDE 25874 . 27549)) (27722 27968 (DEMOWINDOW 27732 . 27966)) (28212 30198 (IDLE-DRAIN
|
||||
28222 . 30196)) (30230 31810 (IDLE-SWAP 30240 . 31808)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,49 +1,53 @@
|
||||
(FILECREATED " 2-Apr-86 00:14:01" {ERIS}<LISPUSERS>KOTO>KINETIC.;2 1626
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to: (VARS KINETICCOMS)
|
||||
(FILECREATED "23-Sep-2022 08:19:41" {DSK}<home>larry>medley>lispusers>KINETIC.;2 1928
|
||||
|
||||
previous date: " 3-Dec-85 14:17:48" {ERIS}<LISPUSERS>KOTO>KINETIC.;1)
|
||||
:CHANGES-TO (FNS KINETIC)
|
||||
|
||||
:PREVIOUS-DATE " 2-Apr-86 00:14:01" {DSK}<home>larry>medley>lispusers>KINETIC.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1982, 1985, 1986 by Xerox Corporation. All rights reserved.)
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1985-1986, 2022 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT KINETICCOMS)
|
||||
|
||||
(RPAQQ KINETICCOMS ((FNS KINETIC)
|
||||
(VARS (CHECKSHADE 63903)
|
||||
(KINETICWINDOW))
|
||||
(ALISTS (IDLE.FUNCTIONS Kinetic))))
|
||||
(VARS (CHECKSHADE 63903)
|
||||
(KINETICWINDOW))
|
||||
(ALISTS (IDLE.FUNCTIONS Kinetic))))
|
||||
(DEFINEQ
|
||||
|
||||
(KINETIC
|
||||
[LAMBDA (WINDOW) (* lmm " 3-Dec-85 14:16")
|
||||
(* test example (KINETICDEMO)
|
||||
(SETQ CHECKSHADE (EDITSHADE CHECKSHADE)))
|
||||
[OR (WINDOWP WINDOW)
|
||||
(SETQ WINDOW (OR KINETICWINDOW (SETQ KINETICWINDOW (CREATEW NIL "Kinetic Window"]
|
||||
(PROG ((WD (WINDOWPROP WINDOW (QUOTE WIDTH)))
|
||||
(HT (WINDOWPROP WINDOW (QUOTE HEIGHT)))
|
||||
X Y)
|
||||
(do (SETQ X (RAND 0 WD))
|
||||
(SETQ Y (RAND 0 HT))
|
||||
(BITBLT NIL NIL NIL WINDOW (RAND 0 (IDIFFERENCE WD X))
|
||||
(RAND 0 (IDIFFERENCE HT Y))
|
||||
X Y (QUOTE TEXTURE)
|
||||
(SELECTQ (RAND 0 5)
|
||||
(0 (QUOTE PAINT))
|
||||
(QUOTE INVERT))
|
||||
(SELECTQ (AND CHECKSHADE (RAND 0 12))
|
||||
(0 CHECKSHADE)
|
||||
BLACKSHADE))
|
||||
(BLOCK])
|
||||
[LAMBDA (WINDOW) (* ; "Edited 22-Sep-2022 22:07 by lmm")
|
||||
(* lmm " 3-Dec-85 14:16")
|
||||
(* test example (KINETICDEMO)
|
||||
(SETQ CHECKSHADE (EDITSHADE CHECKSHADE)))
|
||||
[OR (WINDOWP WINDOW)
|
||||
(SETQ WINDOW (OR KINETICWINDOW (SETQ KINETICWINDOW (CREATEW NIL "Kinetic Window"]
|
||||
(PROG ((WD (WINDOWPROP WINDOW 'WIDTH))
|
||||
(HT (WINDOWPROP WINDOW 'HEIGHT))
|
||||
X Y)
|
||||
(do (SETQ X (RAND 0 WD))
|
||||
(SETQ Y (RAND 0 HT))
|
||||
(BITBLT NIL NIL NIL WINDOW (RAND 0 (IDIFFERENCE WD X))
|
||||
(RAND 0 (IDIFFERENCE HT Y))
|
||||
X Y 'TEXTURE (SELECTQ (RAND 0 5)
|
||||
(0 'PAINT)
|
||||
'INVERT)
|
||||
(SELECTQ (AND CHECKSHADE (RAND 0 12))
|
||||
(0 CHECKSHADE)
|
||||
BLACKSHADE))
|
||||
(BLOCK 100])
|
||||
)
|
||||
|
||||
(RPAQQ CHECKSHADE 63903)
|
||||
|
||||
(RPAQQ KINETICWINDOW NIL)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS (Kinetic (QUOTE KINETIC)))
|
||||
(PUTPROPS KINETIC COPYRIGHT ("Xerox Corporation" 1982 1985 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (447 1420 (KINETIC 457 . 1418)))))
|
||||
(ADDTOVAR IDLE.FUNCTIONS (Kinetic 'KINETIC))
|
||||
(PUTPROPS KINETIC COPYRIGHT ("Xerox Corporation" 1982 1985 1986 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (573 1723 (KINETIC 583 . 1721)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,23 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "10-Feb-2022 22:17:51" {DSK}<home>larry>medley>lispusers>MANAGER.;4 111722
|
||||
(FILECREATED "15-Sep-2022 23:39:36" {DSK}<home>matt>medley>LISPUSERS>MANAGER.;2 111145
|
||||
|
||||
:CHANGES-TO (ADVICE (MARKASCHANGED :IN DEFAULT.EDITDEFA0001)
|
||||
LOADFNS LOAD \ADDTOFILEBLOCK/ADDNEWCOM DELFROMCOMS ADDTOCOMS UPDATEFILES
|
||||
UNMARKASCHANGED MARKASCHANGED MAKEFILE ADDTOFILES? ADDFILE)
|
||||
(VARS MANAGERCOMS)
|
||||
(FNS Manager.DO.COMMAND Manager.HIGHLIGHT Manager.PROMPT Manager.WINDOW
|
||||
Manager.insurefilehighlights Manager.CHANGED? Manager.CHECKFILE
|
||||
Manager.COLLECTCOMS Manager.COMS.WSF Manager.COMSOPEN Manager.COMSUPDATE
|
||||
Manager.HIGHLIGHTED Manager.INSUREHIGHLIGHTS Manager.FILECHANGES
|
||||
Manager.FILELSTCHANGED? Manager.FILESUBTYPES Manager.GET.ENVIRONMENT
|
||||
Manager.GETFILE Manager.INTITLE? Manager.MAIN.WSF Manager.MAINCLOSE
|
||||
Manager.MAINMENUITEMS Manager.MAINOPEN Manager.MAINUPDATE Manager.MAKEFILE.ADV
|
||||
Manager.MENUCOLUMNS Manager.MENUHASITEM Manager.MENUITEMS
|
||||
Manager.REMOVE.DUPLICATE.ADVICE Manager.RESETSUBITEMS Manager.SORT.COMS
|
||||
Manager.SORTBYCOLUMN)
|
||||
:CHANGES-TO (FNS Manager.DO.COMMAND)
|
||||
|
||||
:PREVIOUS-DATE "18-Nov-87 15:18:24" |{POGO:AISNORTH:XEROX}<FISCHER>WORK>MANAGER.;2|)
|
||||
:PREVIOUS-DATE "10-Feb-2022 22:17:51" {DSK}<home>matt>medley>LISPUSERS>MANAGER.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -536,7 +523,10 @@ Will load DataBaseFNS if necessary" (SUBITEMS ("All" 'DB
|
||||
UPDATEFILES])
|
||||
|
||||
(Manager.DO.COMMAND
|
||||
[LAMBDA (COMMAND ITEM COMSTYPE FILE MENU) (* ; "Edited 18-Nov-87 14:30 by raf")
|
||||
[LAMBDA (COMMAND ITEM COMSTYPE FILE MENU) (* ; "Edited 15-Sep-2022 23:35 by Matt Heffron")
|
||||
(* ; "Edited 15-Sep-2022 23:32 by Matt Heffron")
|
||||
(* ; "Edited 15-Sep-2022 23:19 by Matt Heffron")
|
||||
(* ; "Edited 18-Nov-87 14:30 by raf")
|
||||
(if (EQ COMSTYPE 'FILEVARS)
|
||||
then (SETQ COMSTYPE 'VARS) (* ; "The Manager currently does unnatural things with the FILEVARS type, this is a hack to compensate for it. E.g., editing a FILEVARS = editing the VARS, etc.")
|
||||
)
|
||||
@@ -730,12 +720,14 @@ Will load DataBaseFNS if necessary" (SUBITEMS ("All" 'DB
|
||||
else (* ; "single item")
|
||||
(UNMARKASCHANGED ITEM COMSTYPE)))
|
||||
(SEE (FB.FASTSEE.ONEFILE
|
||||
FILE
|
||||
(LET [(W (CREATEW NIL (CONCAT "Seeing " FILE "..."]
|
||||
(DSPSCROLL 'ON W)
|
||||
(WINDOWPROP W 'PAGEFULLFN 'FB.SEEFULLFN)
|
||||
(TTYDISPLAYSTREAM W)
|
||||
W)))
|
||||
NIL FILE (LET [(W (CREATEW NIL (CONCAT "Seeing " FILE
|
||||
"..."]
|
||||
(DSPSCROLL 'ON W)
|
||||
(WINDOWPROP W 'PAGEFULLFN
|
||||
'FB.SEEFULLFN)
|
||||
(TTYDISPLAYSTREAM W)
|
||||
W)))
|
||||
(TEDIT-SEE (TEDIT-SEE FILE))
|
||||
(LOAD
|
||||
(printout T .FONT LAMBDAFONT "Loading file " FILE "."
|
||||
.FONT DEFAULTFONT T)
|
||||
@@ -1756,18 +1748,18 @@ Will load DataBaseFNS if necessary" (SUBITEMS ("All" 'DB
|
||||
)
|
||||
(PUTPROPS MANAGER COPYRIGHT ("Xerox Corporation" 1986 1987 1900 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (25538 101851 (MANAGER 25548 . 26347) (MANAGER.RESET 26349 . 27863) (Manager.ADDADV
|
||||
27865 . 29218) (Manager.ADDTOFILES? 29220 . 29498) (Manager.ALTERMARKING 29500 . 31110) (
|
||||
Manager.DO.COMMAND 31112 . 62332) (Manager.HIGHLIGHT 62334 . 62631) (Manager.PROMPT 62633 . 62946) (
|
||||
Manager.WINDOW 62948 . 63581) (Manager.insurefilehighlights 63583 . 64654) (Manager.CHANGED? 64656 .
|
||||
65205) (Manager.CHECKFILE 65207 . 66306) (Manager.COLLECTCOMS 66308 . 67746) (Manager.COMS.WSF 67748
|
||||
. 70418) (Manager.COMSOPEN 70420 . 75158) (Manager.COMSUPDATE 75160 . 76252) (Manager.HIGHLIGHTED
|
||||
76254 . 76560) (Manager.INSUREHIGHLIGHTS 76562 . 77120) (Manager.FILECHANGES 77122 . 77421) (
|
||||
Manager.FILELSTCHANGED? 77423 . 77751) (Manager.FILESUBTYPES 77753 . 78391) (Manager.GET.ENVIRONMENT
|
||||
78393 . 80931) (Manager.GETFILE 80933 . 83247) (Manager.INTITLE? 83249 . 83927) (Manager.MAIN.WSF
|
||||
83929 . 86573) (Manager.MAINCLOSE 86575 . 87685) (Manager.MAINMENUITEMS 87687 . 88764) (
|
||||
Manager.MAINOPEN 88766 . 94142) (Manager.MAINUPDATE 94144 . 94780) (Manager.MAKEFILE.ADV 94782 . 95818
|
||||
) (Manager.MENUCOLUMNS 95820 . 96624) (Manager.MENUHASITEM 96626 . 96983) (Manager.MENUITEMS 96985 .
|
||||
97230) (Manager.REMOVE.DUPLICATE.ADVICE 97232 . 98838) (Manager.RESETSUBITEMS 98840 . 100077) (
|
||||
Manager.SORT.COMS 100079 . 100611) (Manager.SORTBYCOLUMN 100613 . 101849)))))
|
||||
(FILEMAP (NIL (24415 101274 (MANAGER 24425 . 25224) (MANAGER.RESET 25226 . 26740) (Manager.ADDADV
|
||||
26742 . 28095) (Manager.ADDTOFILES? 28097 . 28375) (Manager.ALTERMARKING 28377 . 29987) (
|
||||
Manager.DO.COMMAND 29989 . 61755) (Manager.HIGHLIGHT 61757 . 62054) (Manager.PROMPT 62056 . 62369) (
|
||||
Manager.WINDOW 62371 . 63004) (Manager.insurefilehighlights 63006 . 64077) (Manager.CHANGED? 64079 .
|
||||
64628) (Manager.CHECKFILE 64630 . 65729) (Manager.COLLECTCOMS 65731 . 67169) (Manager.COMS.WSF 67171
|
||||
. 69841) (Manager.COMSOPEN 69843 . 74581) (Manager.COMSUPDATE 74583 . 75675) (Manager.HIGHLIGHTED
|
||||
75677 . 75983) (Manager.INSUREHIGHLIGHTS 75985 . 76543) (Manager.FILECHANGES 76545 . 76844) (
|
||||
Manager.FILELSTCHANGED? 76846 . 77174) (Manager.FILESUBTYPES 77176 . 77814) (Manager.GET.ENVIRONMENT
|
||||
77816 . 80354) (Manager.GETFILE 80356 . 82670) (Manager.INTITLE? 82672 . 83350) (Manager.MAIN.WSF
|
||||
83352 . 85996) (Manager.MAINCLOSE 85998 . 87108) (Manager.MAINMENUITEMS 87110 . 88187) (
|
||||
Manager.MAINOPEN 88189 . 93565) (Manager.MAINUPDATE 93567 . 94203) (Manager.MAKEFILE.ADV 94205 . 95241
|
||||
) (Manager.MENUCOLUMNS 95243 . 96047) (Manager.MENUHASITEM 96049 . 96406) (Manager.MENUITEMS 96408 .
|
||||
96653) (Manager.REMOVE.DUPLICATE.ADVICE 96655 . 98261) (Manager.RESETSUBITEMS 98263 . 99500) (
|
||||
Manager.SORT.COMS 99502 . 100034) (Manager.SORTBYCOLUMN 100036 . 101272)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Mar-2022 23:20:21"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MODERNIZE.;40 30674
|
||||
(FILECREATED " 7-Oct-2022 21:45:29"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>MODERNIZE.;43 30755
|
||||
|
||||
:CHANGES-TO (FNS MODERNWINDOW.BUTTONEVENTFN)
|
||||
:CHANGES-TO (FNS MODERNWINDOW)
|
||||
|
||||
:PREVIOUS-DATE "25-Dec-2021 22:27:41"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MODERNIZE.;39)
|
||||
:PREVIOUS-DATE " 5-Mar-2022 23:20:21"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>MODERNIZE.;40)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MODERNIZECOMS)
|
||||
@@ -104,11 +104,12 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MODERNWINDOW
|
||||
[LAMBDA (WINDOW ANYWHERE TITLEPROPORTION) (* ; "Edited 8-Jul-2021 23:33 by rmk:")
|
||||
(* ; "Edited 3-Jul-2021 10:31 by rmk:")
|
||||
(* ; "Edited 24-Jun-2021 14:52 by rmk:")
|
||||
[LAMBDA (WINDOW ANYWHERE TITLEPROPORTION) (* ; "Edited 7-Oct-2022 21:45 by rmk")
|
||||
(* ; "Edited 8-Jul-2021 23:33 by rmk:")
|
||||
(* ; "Edited 3-Jul-2021 10:31 by rmk:")
|
||||
(* ; "Edited 24-Jun-2021 14:52 by rmk:")
|
||||
|
||||
(* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn. If the window was previously modernized, we restore its original state first, in case it is called here with different parameters")
|
||||
(* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn. If the window was previously modernized, we restore its original state first, in case it is called here with different parameters")
|
||||
|
||||
(CL:WHEN (AND TITLEPROPORTION (GREATERP TITLEPROPORTION 0.5))
|
||||
(ERROR "TITLEPROPORTION cannot be greater than .5"))
|
||||
@@ -117,9 +118,9 @@
|
||||
(WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL))
|
||||
(WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
|
||||
(WINDOWPROP WINDOW 'BUTTONEVENTFN (IF (OR ANYWHERE TITLEPROPORTION)
|
||||
THEN [FUNCTION (LAMBDA (WINDOW)
|
||||
(MODERNWINDOW.BUTTONEVENTFN
|
||||
WINDOW NIL T ,TITLEPROPORTION]
|
||||
THEN `[LAMBDA (WINDOW)
|
||||
(MODERNWINDOW.BUTTONEVENTFN WINDOW NIL T
|
||||
',TITLEPROPORTION]
|
||||
ELSE (FUNCTION MODERNWINDOW.BUTTONEVENTFN)))
|
||||
WINDOW])
|
||||
|
||||
@@ -613,12 +614,12 @@
|
||||
(ADDTOVAR LAMA MODERN-ADD-EXEC)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5129 11406 (MODERNWINDOW 5139 . 6594) (MODERNWINDOW.SETUP 6596 . 9545) (UNMODERNWINDOW
|
||||
9547 . 9941) (MODERNWINDOW.UNSETUP 9943 . 10755) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10757 . 11404)) (
|
||||
11471 21633 (MODERNWINDOW.BUTTONEVENTFN 11481 . 18508) (NEARTOP 18510 . 19438) (NEARESTCORNER 19440 .
|
||||
20319) (INCORNER.REGION 20321 . 21631)) (21691 24163 (MODERN-ADD-EXEC 21701 . 22132) (MODERN-SNAPW
|
||||
22134 . 22677) (TOTOPW.MODERNIZE 22679 . 23107) (MODERN-MENUBUTTONFN 23109 . 24161)) (24164 26593 (
|
||||
\MODERNIZED.FREEMENU.BUTTONEVENTFN 24174 . 24821) (MODERNIZED.TB.BUTTONEVENTFN 24823 . 26591)) (26634
|
||||
28913 (TEDIT.MODERNIZE 26644 . 27458) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27460 . 28582) (TEDIT.SELECTALL
|
||||
28584 . 28911)))))
|
||||
(FILEMAP (NIL (5125 11487 (MODERNWINDOW 5135 . 6675) (MODERNWINDOW.SETUP 6677 . 9626) (UNMODERNWINDOW
|
||||
9628 . 10022) (MODERNWINDOW.UNSETUP 10024 . 10836) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10838 . 11485))
|
||||
(11552 21714 (MODERNWINDOW.BUTTONEVENTFN 11562 . 18589) (NEARTOP 18591 . 19519) (NEARESTCORNER 19521
|
||||
. 20400) (INCORNER.REGION 20402 . 21712)) (21772 24244 (MODERN-ADD-EXEC 21782 . 22213) (MODERN-SNAPW
|
||||
22215 . 22758) (TOTOPW.MODERNIZE 22760 . 23188) (MODERN-MENUBUTTONFN 23190 . 24242)) (24245 26674 (
|
||||
\MODERNIZED.FREEMENU.BUTTONEVENTFN 24255 . 24902) (MODERNIZED.TB.BUTTONEVENTFN 24904 . 26672)) (26715
|
||||
28994 (TEDIT.MODERNIZE 26725 . 27539) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27541 . 28663) (TEDIT.SELECTALL
|
||||
28665 . 28992)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,284 +1,187 @@
|
||||
(FILECREATED "30-Jun-86 18:01:00" {PHYLUM}<LANNING>LISP>USERS>PAC-MAN-IDLE.;11 14703
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to: (VARS PAC-MAN-IDLECOMS)
|
||||
(FNS Pac-Man-Eat-Window Slow-Fade Pac-Man-Idle)
|
||||
(FILECREATED "24-Aug-2022 08:54:17" {DSK}<home>larry>medley>lispusers>PAC-MAN-IDLE.;2 17389
|
||||
|
||||
previous date: " 2-May-86 18:42:49" {PHYLUM}<LANNING>LISP>USERS>PAC-MAN-IDLE.;10)
|
||||
:CHANGES-TO (FNS Pac-Man-Eat-Window Pac-Man-Scout-Food)
|
||||
|
||||
:PREVIOUS-DATE "30-Jun-86 18:01:00" {DSK}<home>larry>medley>lispusers>PAC-MAN-IDLE.;1)
|
||||
|
||||
|
||||
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
|
||||
(* ; "
|
||||
Copyright (c) 1986 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT PAC-MAN-IDLECOMS)
|
||||
|
||||
(RPAQQ PAC-MAN-IDLECOMS [(* * The Pac-Man idle function)
|
||||
(FNS Pac-Man-Eat-Window Pac-Man-Idle)
|
||||
(VARS DefaultPacManEatMask DefaultPacManIcon DefaultPacManMask)
|
||||
(INITVARS (Pac-Man-Delay 100)
|
||||
(pacManHorizonFactor .75)
|
||||
(pacManStarvationTime 75)
|
||||
(pacManEatMask DefaultPacManEatMask)
|
||||
(pacManIcon DefaultPacManIcon)
|
||||
(pacManMask DefaultPacManMask))
|
||||
(GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime
|
||||
pacManEatMask pacManIcon pacManMask)
|
||||
(FNS Pac-Man-Scout-Food)
|
||||
(* * Stuff for counting the bits on in a bitmap)
|
||||
(FNS Pac-Man-Amount-Of-Food)
|
||||
(MACROS Pac-Man-Convert-Word)
|
||||
(VARS (Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T)))
|
||||
(GLOBALVARS Pac-Man-Convert-Byte-Array)
|
||||
[P (for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i
|
||||
(bind (j _ i)
|
||||
while
|
||||
(NOT (ZEROP j))
|
||||
count
|
||||
(SETQ j (LOGAND j (SUB1 j]
|
||||
(* * Another idle function)
|
||||
(FNS Slow-Fade)
|
||||
[INITVARS (Slow-Fade-Delay 1000)
|
||||
(Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE
|
||||
(QUOTE DISPLAYFN]
|
||||
(GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function)
|
||||
(* * Add them as idle functions)
|
||||
(ADDVARS (IDLE.FUNCTIONS ("Pac-man" (QUOTE Pac-Man-Idle))
|
||||
("Slow fade" (QUOTE Slow-Fade])
|
||||
(RPAQQ PAC-MAN-IDLECOMS
|
||||
[(* * The Pac-Man idle function)
|
||||
(FNS Pac-Man-Eat-Window Pac-Man-Idle)
|
||||
(VARS DefaultPacManEatMask DefaultPacManIcon DefaultPacManMask)
|
||||
(INITVARS (Pac-Man-Delay 100)
|
||||
(pacManHorizonFactor 0.75)
|
||||
(pacManStarvationTime 75)
|
||||
(pacManEatMask DefaultPacManEatMask)
|
||||
(pacManIcon DefaultPacManIcon)
|
||||
(pacManMask DefaultPacManMask))
|
||||
(GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime pacManEatMask pacManIcon
|
||||
pacManMask)
|
||||
(FNS Pac-Man-Scout-Food)
|
||||
(* * Stuff for counting the bits on in a bitmap)
|
||||
(FNS Pac-Man-Amount-Of-Food)
|
||||
(MACROS Pac-Man-Convert-Word)
|
||||
(VARS (Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T)))
|
||||
(GLOBALVARS Pac-Man-Convert-Byte-Array)
|
||||
[P (for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i
|
||||
(bind (j _ i)
|
||||
while
|
||||
(NOT (ZEROP j))
|
||||
count
|
||||
(SETQ j (LOGAND j (SUB1 j]
|
||||
(* * Another idle function)
|
||||
(FNS Slow-Fade)
|
||||
[INITVARS (Slow-Fade-Delay 1000)
|
||||
(Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE 'DISPLAYFN]
|
||||
(GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function)
|
||||
(* * Add them as idle functions)
|
||||
(ADDVARS (IDLE.FUNCTIONS ("Pac-man" 'Pac-Man-Idle)
|
||||
("Slow fade" 'Slow-Fade])
|
||||
(* * The Pac-Man idle function)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(Pac-Man-Eat-Window
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:38")
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:38")
|
||||
|
||||
(* * Comment)
|
||||
(* * Comment)
|
||||
|
||||
(RESETLST
|
||||
(bind (minX _ (MINUS (QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(minY _ (MINUS (QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(maxX _ (DIFFERENCE (WINDOWPROP window 'WIDTH)
|
||||
(QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(maxY _ (DIFFERENCE (WINDOWPROP window 'HEIGHT)
|
||||
(QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(minimumSpeed _ 0.2)
|
||||
(maximumSpeed _ 1.0)
|
||||
(icon _ (DEFERREDCONSTANT (BITMAPCOPY pacManIcon)))
|
||||
(delayTimer _ (DEFERREDCONSTANT (SETUPTIMER 250)))
|
||||
[horizon _ (FIX (MAX 2 (TIMES (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon))
|
||||
pacManHorizonFactor]
|
||||
(delta _ '(0 . 0))
|
||||
possibleDeltas x y (xSpeed _ 0)
|
||||
(ySpeed _ 0)
|
||||
[maxSpeed _ (TIMES 10 (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon]
|
||||
(maxAcceleration _ (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon)))
|
||||
(stepsWithoutFood _ 0) first [SETQ possibleDeltas
|
||||
(for pair in '((0 . -1)
|
||||
(-1 . 0)
|
||||
(1 . 0)
|
||||
(0 . 1)
|
||||
(0.707 . 0.707)
|
||||
(-0.707 . 0.707)
|
||||
(0.707 . -0.707)
|
||||
(-0.707 . -0.707))
|
||||
collect (CONS (FIX (TIMES horizon (CAR pair)))
|
||||
(FIX (TIMES horizon (CDR pair]
|
||||
(* Pick a random starting place)
|
||||
(SELECTQ (RAND 0 1)
|
||||
(0 (SETQ x (TIMES (WINDOWPROP window 'WIDTH)
|
||||
(RAND 0 1)))
|
||||
[SETQ y (RAND 0 (WINDOWPROP window 'HEIGHT])
|
||||
(1 [SETQ x (RAND 0 (WINDOWPROP window 'WIDTH]
|
||||
(SETQ y (TIMES (WINDOWPROP window 'WIDTH)
|
||||
(RAND 0 1))))
|
||||
NIL) while T
|
||||
do
|
||||
|
||||
(RESETLST (bind (minX _(MINUS (QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(minY _(MINUS (QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(maxX _(DIFFERENCE (WINDOWPROP window (QUOTE WIDTH))
|
||||
(QUOTIENT (BITMAPWIDTH pacManIcon)
|
||||
2)))
|
||||
(maxY _(DIFFERENCE (WINDOWPROP window (QUOTE HEIGHT))
|
||||
(QUOTIENT (BITMAPHEIGHT pacManIcon)
|
||||
2)))
|
||||
(minimumSpeed _ .2)
|
||||
(maximumSpeed _ 1.0)
|
||||
(icon _(DEFERREDCONSTANT (BITMAPCOPY pacManIcon)))
|
||||
(delayTimer _(DEFERREDCONSTANT (SETUPTIMER 250)))
|
||||
[horizon _(FIX (MAX 2 (TIMES (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon))
|
||||
pacManHorizonFactor]
|
||||
(delta _(QUOTE (0 . 0)))
|
||||
possibleDeltas x y (xSpeed _ 0)
|
||||
(ySpeed _ 0)
|
||||
[maxSpeed _(TIMES 10 (MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon]
|
||||
(maxAcceleration _(MIN (BITMAPWIDTH pacManIcon)
|
||||
(BITMAPHEIGHT pacManIcon)))
|
||||
(stepsWithoutFood _ 0)
|
||||
first [SETQ possibleDeltas (for pair in (QUOTE ((0 . -1)
|
||||
(-1 . 0)
|
||||
(1 . 0)
|
||||
(0 . 1)
|
||||
(.707 . .707)
|
||||
(-.707 . .707)
|
||||
(.707 . -.707)
|
||||
(-.707 . -.707)))
|
||||
collect (CONS (FIX (TIMES horizon
|
||||
(CAR pair)))
|
||||
(FIX (TIMES horizon
|
||||
(CDR pair]
|
||||
(* Pick a random starting place)
|
||||
(SELECTQ (RAND 0 1)
|
||||
[0 (SETQ x (TIMES (WINDOWPROP window (QUOTE WIDTH))
|
||||
(RAND 0 1)))
|
||||
(SETQ y (RAND 0 (WINDOWPROP window (QUOTE HEIGHT]
|
||||
[1 [SETQ x (RAND 0 (WINDOWPROP window (QUOTE WIDTH]
|
||||
(SETQ y (TIMES (WINDOWPROP window (QUOTE WIDTH))
|
||||
(RAND 0 1]
|
||||
NIL)
|
||||
while T
|
||||
do
|
||||
(* * Try to figure out which direction to go.
|
||||
Pick the one that would get us the most food.
|
||||
Make sure to block, and don't move to quickly
|
||||
(hah!))
|
||||
|
||||
(* * Try to figure out which direction to go. Pick the one that would get us the most food.
|
||||
Make sure to block, and don't move to quickly (hah!))
|
||||
(SETQ delayTimer (SETUPTIMER Pac-Man-Delay delayTimer))
|
||||
[SETQ delta (Pac-Man-Scout-Food
|
||||
window x y pacManEatMask possibleDeltas delta
|
||||
(DEFERREDCONSTANT (BITMAPCREATE
|
||||
(PLUS (TIMES 16 (QUOTIENT (BITMAPWIDTH pacManMask)
|
||||
16))
|
||||
(if (ZEROP (REMAINDER (BITMAPWIDTH pacManMask)
|
||||
16))
|
||||
then 0
|
||||
else 16))
|
||||
(BITMAPHEIGHT pacManMask]
|
||||
(COND
|
||||
((NOT (NULL delta)) (* Found some food)
|
||||
NIL)
|
||||
((GREATERP stepsWithoutFood pacManStarvationTime)
|
||||
(* Starving, so make a random jump)
|
||||
(change xSpeed (RAND (DIFFERENCE minX x)
|
||||
(DIFFERENCE maxX x)))
|
||||
(change ySpeed (RAND (DIFFERENCE minY y)
|
||||
(DIFFERENCE maxY y)))
|
||||
(SETQ stepsWithoutFood 0)
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (add stepsWithoutFood 1)
|
||||
(change xSpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change xSpeed (MAX (DIFFERENCE minX x)
|
||||
(MIN (DIFFERENCE maxX x)
|
||||
DATUM)))
|
||||
(change ySpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change ySpeed (MAX (DIFFERENCE minY y)
|
||||
(MIN (DIFFERENCE maxY y)
|
||||
DATUM)))
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (SETQ stepsWithoutFood 0)
|
||||
(SETQ xSpeed 0)
|
||||
(SETQ ySpeed 0)))
|
||||
(do (BLOCK) repeatuntil (TIMEREXPIRED? delayTimer))
|
||||
|
||||
(* * Eat the food at the current location)
|
||||
|
||||
(SETQ delayTimer (SETUPTIMER Pac-Man-Delay delayTimer))
|
||||
[SETQ delta (Pac-Man-Scout-Food
|
||||
window x y pacManEatMask possibleDeltas delta
|
||||
(DEFERREDCONSTANT (BITMAPCREATE
|
||||
(PLUS (TIMES 16 (QUOTIENT (BITMAPWIDTH
|
||||
pacManMask)
|
||||
16))
|
||||
(if (ZEROP (REMAINDER (BITMAPWIDTH
|
||||
pacManMask)
|
||||
16))
|
||||
then 0
|
||||
else 16))
|
||||
(BITMAPHEIGHT pacManMask]
|
||||
(COND
|
||||
((NOT (NULL delta)) (* Found some food)
|
||||
NIL)
|
||||
((GREATERP stepsWithoutFood pacManStarvationTime)
|
||||
(* Starving, so make a random jump)
|
||||
(change xSpeed (RAND (DIFFERENCE minX x)
|
||||
(DIFFERENCE maxX x)))
|
||||
(change ySpeed (RAND (DIFFERENCE minY y)
|
||||
(DIFFERENCE maxY y)))
|
||||
(SETQ stepsWithoutFood 0)
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (add stepsWithoutFood 1)
|
||||
(change xSpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change xSpeed (MAX (DIFFERENCE minX x)
|
||||
(MIN (DIFFERENCE maxX x)
|
||||
DATUM)))
|
||||
(change ySpeed (RAND (MINUS maxAcceleration)
|
||||
maxAcceleration))
|
||||
(change ySpeed (MAX (DIFFERENCE minY y)
|
||||
(MIN (DIFFERENCE maxY y)
|
||||
DATUM)))
|
||||
(SETQ delta (CONS xSpeed ySpeed)))
|
||||
(T (SETQ stepsWithoutFood 0)
|
||||
(SETQ xSpeed 0)
|
||||
(SETQ ySpeed 0)))
|
||||
(do (BLOCK) repeatuntil (TIMEREXPIRED? delayTimer))
|
||||
(BITBLT pacManEatMask NIL NIL window x y NIL NIL 'INPUT 'ERASE)
|
||||
|
||||
(* * Eat the food at the current location)
|
||||
(* * Update my location)
|
||||
|
||||
|
||||
(BITBLT pacManEatMask NIL NIL window x y NIL NIL (QUOTE INPUT)
|
||||
(QUOTE ERASE))
|
||||
|
||||
(* * Update my location)
|
||||
|
||||
|
||||
[change x (FIX (MAX minX (MIN maxX (PLUS DATUM
|
||||
(TIMES (RAND
|
||||
minimumSpeed
|
||||
maximumSpeed)
|
||||
(CAR delta]
|
||||
[change y (FIX (MAX minY (MIN maxY (PLUS DATUM
|
||||
(TIMES (RAND
|
||||
minimumSpeed
|
||||
maximumSpeed)
|
||||
(CDR delta]
|
||||
(BITBLT window x y icon NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
(BITBLT pacManMask NIL NIL icon NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE ERASE))
|
||||
(BITBLT pacManIcon NIL NIL icon NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE PAINT))
|
||||
(BITBLT icon NIL NIL window x y NIL NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE])
|
||||
[change x (FIX (MAX minX (MIN maxX (PLUS DATUM (TIMES (RAND minimumSpeed maximumSpeed)
|
||||
(CAR delta]
|
||||
[change y (FIX (MAX minY (MIN maxY (PLUS DATUM (TIMES (RAND minimumSpeed maximumSpeed)
|
||||
(CDR delta]
|
||||
(BITBLT window x y icon NIL NIL NIL NIL 'INPUT 'REPLACE)
|
||||
(BITBLT pacManMask NIL NIL icon NIL NIL NIL NIL 'INPUT 'ERASE)
|
||||
(BITBLT pacManIcon NIL NIL icon NIL NIL NIL NIL 'INPUT 'PAINT)
|
||||
(BITBLT icon NIL NIL window x y NIL NIL 'INPUT 'REPLACE)))])
|
||||
|
||||
(Pac-Man-Idle
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:41")
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:41")
|
||||
|
||||
(* * A hungry idle function)
|
||||
(* * A hungry idle function)
|
||||
|
||||
|
||||
(BITBLT (WINDOWPROP window (QUOTE IMAGECOVERED))
|
||||
NIL NIL window NIL NIL NIL NIL (QUOTE INVERT)
|
||||
(QUOTE REPLACE))
|
||||
(BITBLT (WINDOWPROP window 'IMAGECOVERED)
|
||||
NIL NIL window NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
(Pac-Man-Eat-Window window])
|
||||
)
|
||||
|
||||
(RPAQ DefaultPacManEatMask (READBITMAP))
|
||||
(27 27
|
||||
"@@AO@@@@"
|
||||
"@@GOL@@@"
|
||||
"@AOOO@@@"
|
||||
"@GOOOL@@"
|
||||
"@OOOON@@"
|
||||
"AOOOOO@@"
|
||||
"AOOOOO@@"
|
||||
"COOOOOH@"
|
||||
"COOOOOH@"
|
||||
"GOOOOOL@"
|
||||
"GOOOOOL@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"GOOOOOL@"
|
||||
"GOOOOOL@"
|
||||
"COOOOOH@"
|
||||
"COOOOOH@"
|
||||
"AOOOOO@@"
|
||||
"AOOOOO@@"
|
||||
"@OOOON@@"
|
||||
"@GOOOL@@"
|
||||
"@AOOO@@@"
|
||||
"@@GOL@@@"
|
||||
"@@AO@@@@")
|
||||
(RPAQQ DefaultPacManEatMask #*(27 27)@@AO@@@@@@GOL@@@@AOOO@@@@GOOOL@@@OOOON@@AOOOOO@@AOOOOO@@COOOOOH@COOOOOH@GOOOOOL@GOOOOOL@OOOOOON@OOOOOON@OOOOOON@OOOOOON@OOOOOON@GOOOOOL@GOOOOOL@COOOOOH@COOOOOH@AOOOOO@@AOOOOO@@@OOOON@@@GOOOL@@@AOOO@@@@@GOL@@@@@AO@@@@
|
||||
)
|
||||
|
||||
(RPAQ DefaultPacManIcon (READBITMAP))
|
||||
(27 27
|
||||
"@@AE@@@@"
|
||||
"@@EED@@@"
|
||||
"@@JJJ@@@"
|
||||
"@BJJJH@@"
|
||||
"@EEEED@@"
|
||||
"AEEGME@@"
|
||||
"@JJONJ@@"
|
||||
"BJJONJH@"
|
||||
"AEEEEE@@"
|
||||
"EEEEEED@"
|
||||
"BJJJJJH@"
|
||||
"JJJJJJJ@"
|
||||
"EEEEEED@"
|
||||
"EEEEEED@"
|
||||
"JJJH@@@@"
|
||||
"JJJJ@@@@"
|
||||
"EEEE@@@@"
|
||||
"EEEE@@@@"
|
||||
"BJJJH@@@"
|
||||
"BJJJJ@@@"
|
||||
"AEEEE@@@"
|
||||
"AEEEE@@@"
|
||||
"@JJJJH@@"
|
||||
"@BJJJH@@"
|
||||
"@AEEE@@@"
|
||||
"@@EED@@@"
|
||||
"@@@J@@@@")
|
||||
(RPAQQ DefaultPacManIcon #*(27 27)@@AE@@@@@@EED@@@@@JJJ@@@@BJJJH@@@EEEED@@AEEGME@@@JJONJ@@BJJONJH@AEEEEE@@EEEEEED@BJJJJJH@JJJJJJJ@EEEEEED@EEEEEED@JJJH@@@@JJJJ@@@@EEEE@@@@EEEE@@@@BJJJH@@@BJJJJ@@@AEEEE@@@AEEEE@@@@JJJJH@@@BJJJH@@@AEEE@@@@@EED@@@@@@J@@@@
|
||||
)
|
||||
|
||||
(RPAQ DefaultPacManMask (READBITMAP))
|
||||
(27 27
|
||||
"@@AO@@@@"
|
||||
"@@GOL@@@"
|
||||
"@AOOO@@@"
|
||||
"@GOOOL@@"
|
||||
"@OOOON@@"
|
||||
"AOOOOO@@"
|
||||
"AOOOOO@@"
|
||||
"COOOOOH@"
|
||||
"COOOOOH@"
|
||||
"GOOOOOL@"
|
||||
"GOOOOOL@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOOOON@"
|
||||
"OOOL@@@@"
|
||||
"OOON@@@@"
|
||||
"GOOO@@@@"
|
||||
"GOOOH@@@"
|
||||
"COOOL@@@"
|
||||
"COOON@@@"
|
||||
"AOOOO@@@"
|
||||
"AOOOOH@@"
|
||||
"@OOOOL@@"
|
||||
"@GOOOL@@"
|
||||
"@AOOO@@@"
|
||||
"@@GOL@@@"
|
||||
"@@AO@@@@")
|
||||
(RPAQQ DefaultPacManMask #*(27 27)@@AO@@@@@@GOL@@@@AOOO@@@@GOOOL@@@OOOON@@AOOOOO@@AOOOOO@@COOOOOH@COOOOOH@GOOOOOL@GOOOOOL@OOOOOON@OOOOOON@OOOOOON@OOOL@@@@OOON@@@@GOOO@@@@GOOOH@@@COOOL@@@COOON@@@AOOOO@@@AOOOOH@@@OOOOL@@@GOOOL@@@AOOO@@@@@GOL@@@@@AO@@@@
|
||||
)
|
||||
|
||||
(RPAQ? Pac-Man-Delay 100)
|
||||
|
||||
(RPAQ? pacManHorizonFactor .75)
|
||||
(RPAQ? pacManHorizonFactor 0.75)
|
||||
|
||||
(RPAQ? pacManStarvationTime 75)
|
||||
|
||||
@@ -287,164 +190,150 @@
|
||||
(RPAQ? pacManIcon DefaultPacManIcon)
|
||||
|
||||
(RPAQ? pacManMask DefaultPacManMask)
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS Pac-Man-Delay pacManHorizonFactor pacManStarvationTime pacManEatMask pacManIcon
|
||||
pacManMask)
|
||||
pacManMask)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(Pac-Man-Scout-Food
|
||||
[LAMBDA (window x y mask possibleDeltas prevDelta tempBitMap)
|
||||
(* smL "29-Apr-86 12:55")
|
||||
|
||||
(* * Return the x-y pair of directions to go to get the most food)
|
||||
(* smL "29-Apr-86 12:55")
|
||||
|
||||
(* * Return the x-y pair of directions to go to get the most food)
|
||||
|
||||
(for i from 1 to 8 bind direction
|
||||
thereis [SETQ direction (for offsetPair in [for x in possibleDeltas
|
||||
collect (CONS (TIMES i
|
||||
(CAR x))
|
||||
(TIMES i
|
||||
(CDR x]
|
||||
bind xoffset yoffset amountOfFood (mostFood _ 0)
|
||||
(mostFoodDirections _ NIL)
|
||||
do (SETQ xoffset (CAR offsetPair))
|
||||
(SETQ yoffset (CDR offsetPair))
|
||||
thereis [SETQ direction (for offsetPair in [for x in possibleDeltas
|
||||
collect (CONS (TIMES i (CAR x))
|
||||
(TIMES i (CDR x]
|
||||
bind xoffset yoffset amountOfFood (mostFood _ 0)
|
||||
(mostFoodDirections _ NIL)
|
||||
do (SETQ xoffset (CAR offsetPair))
|
||||
(SETQ yoffset (CDR offsetPair))
|
||||
|
||||
(* * Build a bitmap of the food available at the location. -
|
||||
This requires computing the number of bits that are black both in the window and in the mask.
|
||||
-
|
||||
We want black bits in the window because things have been inverted by idle and we are trying to eat white bits, and
|
||||
we want black bits in the mask because that is what defines the mask.)
|
||||
|
||||
(* Copy the screen bits into the temp bitmap.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE TEXTURE)
|
||||
(QUOTE REPLACE)
|
||||
WHITESHADE)
|
||||
(BITBLT window (PLUS xoffset x)
|
||||
(PLUS yoffset y)
|
||||
tempBitMap NIL NIL NIL NIL (QUOTE INPUT)
|
||||
(QUOTE REPLACE))
|
||||
(* Or in the white bits of the mask at the appropriate
|
||||
location.)
|
||||
(BITBLT mask NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE INVERT)
|
||||
(QUOTE ERASE))
|
||||
(* Clear out the image of the current position of the
|
||||
mask.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE TEXTURE)
|
||||
(QUOTE INVERT)
|
||||
BLACKSHADE)
|
||||
(BITBLT mask (MAX 0 xoffset)
|
||||
(MAX 0 yoffset)
|
||||
tempBitMap
|
||||
(MAX 0 (MINUS xoffset))
|
||||
(MAX 0 (MINUS yoffset))
|
||||
NIL NIL (QUOTE INPUT)
|
||||
(QUOTE PAINT))
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL
|
||||
(QUOTE TEXTURE)
|
||||
(QUOTE INVERT)
|
||||
BLACKSHADE)
|
||||
(* Compute the amount of food)
|
||||
(SETQ amountOfFood (Pac-Man-Amount-Of-Food tempBitMap))
|
||||
(* Remember the directions with the most food)
|
||||
(if (LESSP amountOfFood mostFood)
|
||||
then (* This direction loses)
|
||||
NIL
|
||||
elseif (EQP amountOfFood mostFood)
|
||||
then (* This is a possible direction)
|
||||
(push mostFoodDirections offsetPair)
|
||||
else (* This direction dominates)
|
||||
(SETQ mostFood amountOfFood)
|
||||
(SETQ mostFoodDirections (LIST offsetPair)))
|
||||
finally (RETURN (if (ZEROP mostFood)
|
||||
then NIL
|
||||
else (CAR (NTH mostFoodDirections
|
||||
(RAND
|
||||
1
|
||||
(LENGTH
|
||||
mostFoodDirections]
|
||||
finally (RETURN direction])
|
||||
(* * Build a bitmap of the food available at the location.
|
||||
-
|
||||
This requires computing the number of bits that are black both in the window and
|
||||
in the mask. -
|
||||
We want black bits in the window because things have been inverted by idle and we
|
||||
are trying to eat white bits, and we want black bits in the mask because that is
|
||||
what defines the mask.)
|
||||
(* Copy the screen bits into the temp
|
||||
bitmap.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL 'TEXTURE
|
||||
'REPLACE WHITESHADE)
|
||||
(BITBLT window (PLUS xoffset x)
|
||||
(PLUS yoffset y)
|
||||
tempBitMap NIL NIL NIL NIL 'INPUT 'REPLACE)
|
||||
(* Or in the white bits of the mask at
|
||||
the appropriate location.)
|
||||
(BITBLT mask NIL NIL tempBitMap NIL NIL NIL NIL 'INVERT
|
||||
'ERASE) (* Clear out the image of the current
|
||||
position of the mask.)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL 'TEXTURE
|
||||
'INVERT BLACKSHADE)
|
||||
(BITBLT mask (MAX 0 xoffset)
|
||||
(MAX 0 yoffset)
|
||||
tempBitMap
|
||||
(MAX 0 (MINUS xoffset))
|
||||
(MAX 0 (MINUS yoffset))
|
||||
NIL NIL 'INPUT 'PAINT)
|
||||
(BITBLT NIL NIL NIL tempBitMap NIL NIL NIL NIL 'TEXTURE
|
||||
'INVERT BLACKSHADE)
|
||||
(* Compute the amount of food)
|
||||
(SETQ amountOfFood (Pac-Man-Amount-Of-Food tempBitMap))
|
||||
(* Remember the directions with the
|
||||
most food)
|
||||
(if (LESSP amountOfFood mostFood)
|
||||
then (* This direction loses)
|
||||
NIL
|
||||
elseif (EQP amountOfFood mostFood)
|
||||
then (* This is a possible direction)
|
||||
(push mostFoodDirections offsetPair)
|
||||
else (* This direction dominates)
|
||||
(SETQ mostFood amountOfFood)
|
||||
(SETQ mostFoodDirections (LIST offsetPair)))
|
||||
finally (RETURN (if (ZEROP mostFood)
|
||||
then NIL
|
||||
else (CAR (NTH mostFoodDirections
|
||||
(RAND 1 (LENGTH mostFoodDirections
|
||||
]
|
||||
finally (RETURN direction])
|
||||
)
|
||||
(* * Stuff for counting the bits on in a bitmap)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(Pac-Man-Amount-Of-Food
|
||||
[LAMBDA (bitMap) (* smL "29-Apr-86 13:23")
|
||||
[LAMBDA (bitMap) (* smL "29-Apr-86 13:23")
|
||||
|
||||
(* * How much food is there in the bitmap?)
|
||||
(* * How much food is there in the bitmap?)
|
||||
|
||||
|
||||
(for j from 0 to (QUOTIENT (TIMES (BITMAPHEIGHT bitMap)
|
||||
(BITMAPWIDTH bitMap))
|
||||
16)
|
||||
bind (bitmapBase _(fetch (BITMAP BITMAPBASE) of bitMap)) sum (Pac-Man-Convert-Word
|
||||
(\GETBASE bitmapBase
|
||||
j])
|
||||
(for j from 0 to (QUOTIENT (TIMES (BITMAPHEIGHT bitMap)
|
||||
(BITMAPWIDTH bitMap))
|
||||
16) bind (bitmapBase _ (fetch (BITMAP BITMAPBASE) of bitMap))
|
||||
sum (Pac-Man-Convert-Word (\GETBASE bitmapBase j])
|
||||
)
|
||||
(DECLARE: EVAL@COMPILE
|
||||
[DEFMACRO Pac-Man-Convert-Word (word)
|
||||
(* * Count up the number of bits on in the word)
|
||||
(BQUOTE (PLUS (\GETBASE Pac-Man-Convert-Byte-Array (LRSH , word 8))
|
||||
(\GETBASE Pac-Man-Convert-Byte-Array (LOGAND , word 255]
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PROGN (DEFMACRO Pac-Man-Convert-Word (word)
|
||||
|
||||
|
||||
(* * Count up the number of bits on in the word)
|
||||
|
||||
`(PLUS (\GETBASE Pac-Man-Convert-Byte-Array (LRSH %, word 8))
|
||||
(\GETBASE Pac-Man-Convert-Byte-Array (LOGAND %, word 255))))
|
||||
NIL)
|
||||
)
|
||||
|
||||
(RPAQ Pac-Man-Convert-Byte-Array (\ALLOCBLOCK 256 T))
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS Pac-Man-Convert-Byte-Array)
|
||||
)
|
||||
[for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i (bind (j _ i)
|
||||
while
|
||||
(NOT (ZEROP j))
|
||||
count
|
||||
(SETQ j (LOGAND j (SUB1 j]
|
||||
|
||||
[for i from 0 to 255 do (\PUTBASE Pac-Man-Convert-Byte-Array i (bind (j _ i)
|
||||
while (NOT (ZEROP j))
|
||||
count (SETQ j (LOGAND j
|
||||
(SUB1 j]
|
||||
(* * Another idle function)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(Slow-Fade
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:16")
|
||||
[LAMBDA (window) (* smL "30-Jun-86 17:16")
|
||||
|
||||
(* * Slowly fade the idle window to black)
|
||||
(* * Slowly fade the idle window to black)
|
||||
|
||||
|
||||
(BITBLT (WINDOWPROP window (QUOTE IMAGECOVERED))
|
||||
NIL NIL window NIL NIL NIL NIL (QUOTE INVERT)
|
||||
(QUOTE REPLACE))
|
||||
[LET [(fadeTextures (for i from 0 to 15 collect (LLSH 1 i]
|
||||
(BITBLT (WINDOWPROP window 'IMAGECOVERED)
|
||||
NIL NIL window NIL NIL NIL NIL 'INVERT 'REPLACE)
|
||||
[LET [(fadeTextures (for i from 0 to 15 collect (LLSH 1 i]
|
||||
(while fadeTextures bind selectedTexture
|
||||
do (BLOCK Slow-Fade-Delay)
|
||||
(SETQ selectedTexture (LLSH 1 (RAND 0 15)))
|
||||
(BITBLT NIL NIL NIL window NIL NIL NIL NIL (QUOTE TEXTURE)
|
||||
(QUOTE ERASE)
|
||||
selectedTexture)
|
||||
(SETQ fadeTextures (DREMOVE selectedTexture fadeTextures]
|
||||
(BLOCK Slow-Fade-Delay)
|
||||
(APPLY* (OR Default-Slow-Fade-Idle-Function (FUNCTION IDLE.BOUNCING.BOX))
|
||||
window])
|
||||
do (BLOCK Slow-Fade-Delay)
|
||||
(SETQ selectedTexture (LLSH 1 (RAND 0 15)))
|
||||
(BITBLT NIL NIL NIL window NIL NIL NIL NIL 'TEXTURE 'ERASE selectedTexture)
|
||||
(SETQ fadeTextures (DREMOVE selectedTexture fadeTextures]
|
||||
(BLOCK Slow-Fade-Delay)
|
||||
(APPLY* (OR Default-Slow-Fade-Idle-Function (FUNCTION IDLE.BOUNCING.BOX))
|
||||
window])
|
||||
)
|
||||
|
||||
(RPAQ? Slow-Fade-Delay 1000)
|
||||
|
||||
(RPAQ? Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE (QUOTE DISPLAYFN)))
|
||||
(DECLARE: DOEVAL@COMPILE DONTCOPY
|
||||
(RPAQ? Default-Slow-Fade-Idle-Function (LISTGET IDLE.PROFILE 'DISPLAYFN))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS Slow-Fade-Delay Default-Slow-Fade-Idle-Function)
|
||||
)
|
||||
(* * Add them as idle functions)
|
||||
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Pac-man" (QUOTE Pac-Man-Idle))
|
||||
("Slow fade" (QUOTE Slow-Fade)))
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Pac-man" 'Pac-Man-Idle)
|
||||
("Slow fade" 'Slow-Fade))
|
||||
(PUTPROPS PAC-MAN-IDLE COPYRIGHT ("Xerox Corporation" 1986))
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL (1826 7263 (Pac-Man-Eat-Window 1836 . 6918) (Pac-Man-Idle 6920 . 7261)) (8683 12226 (
|
||||
Pac-Man-Scout-Food 8693 . 12224)) (12282 12768 (Pac-Man-Amount-Of-Food 12292 . 12766)) (13370 14261 (
|
||||
Slow-Fade 13380 . 14259)))))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2093 8924 (Pac-Man-Eat-Window 2103 . 8625) (Pac-Man-Idle 8627 . 8922)) (10090 14734 (
|
||||
Pac-Man-Scout-Food 10100 . 14732)) (14790 15275 (Pac-Man-Amount-Of-Food 14800 . 15273)) (16137 16947 (
|
||||
Slow-Fade 16147 . 16945)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
87
lispusers/PICK
Normal file
87
lispusers/PICK
Normal file
@@ -0,0 +1,87 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "11-Aug-2022 17:53:58" {DSK}<home>larry>medley>lispusers>PICK.;3 4261
|
||||
|
||||
:CHANGES-TO (VARS PICKCOMS)
|
||||
(FNS PICK)
|
||||
|
||||
:PREVIOUS-DATE "10-Aug-2022 16:57:49" {DSK}<home>larry>medley>lispusers>PICK.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT PICKCOMS)
|
||||
|
||||
(RPAQQ PICKCOMS ((COMMANDS "pick")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOP)
|
||||
GITFNS))
|
||||
(FILES GITFNS)
|
||||
(FNS PICK)))
|
||||
|
||||
(DEFCOMMAND "pick" (FIRST . REST) (PICK FIRST REST))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOP)
|
||||
GITFNS)
|
||||
)
|
||||
|
||||
(FILESLOAD GITFNS)
|
||||
(DEFINEQ
|
||||
|
||||
(PICK
|
||||
[LAMBDA (TYPE CHOICES) (* ; "Edited 11-Aug-2022 17:15 by lmm")
|
||||
(* ; "Edited 10-Aug-2022 16:57 by lmm")
|
||||
(SELECTQ (MKATOM (U-CASE (MKSTRING TYPE)))
|
||||
(ONEOF (* ;
|
||||
"PICK ONEOF A1 A2 A3 ... - just choose from choices listed")
|
||||
[CAR (NTH CHOICES (RAND 1 (LENGTH CHOICES])
|
||||
(NIL (* ;
|
||||
"pick -- choose an issue, a file, a project")
|
||||
[PICK (PICK 'ONEOF '(FILE ISSUE PROJECT])
|
||||
(ISSUE (* ;
|
||||
"pick issue [number] -- display an issue; if none given, choose one at random")
|
||||
(LET ([ISSUE (PICK 'ONEOF (OR CHOICES (GIT-COMMAND
|
||||
"gh issue list -L 5000 -R interlisp/medley | sed 's/\([0-9]*\).*/\1/'"
|
||||
]
|
||||
(STR (OPENTEXTSTREAM))
|
||||
(COMMENTS T)
|
||||
(TITLE))
|
||||
(for S in (GIT-COMMAND (CL:FORMAT NIL "gh issue view -R interlisp/medley ~d"
|
||||
ISSUE)) do (CL:FORMAT STR "~a~&" S)
|
||||
finally
|
||||
|
||||
(* ;;
|
||||
"this TEDIT call is wrong -- it takes the keyboard and the promptwindow prompt is wrong")
|
||||
|
||||
[TEDIT STR NIL NIL `(READONLY T TITLE ,(SETQ TITLE (CL:FORMAT NIL
|
||||
"Issue #~d"
|
||||
ISSUE]
|
||||
|
||||
(* ;; "if there are comments (or always) show comments too -- the -w switch doesn't work online -- no browser")
|
||||
|
||||
(IF COMMENTS
|
||||
THEN (GIT-COMMAND (CL:FORMAT NIL
|
||||
"gh issue view -R interlisp/medley ~a -w"
|
||||
ISSUE)))
|
||||
(RETURN TITLE))))
|
||||
(DIR
|
||||
(* ;; "pick a directory to choose files from")
|
||||
|
||||
(PICK 'ONEOF '(LISPUSERS LIBRARY DOCTOOLS SOURCES INTERNAL)))
|
||||
(FILE
|
||||
(* ;; " pick a file from a (randomly chosen) directory")
|
||||
|
||||
[LIST 'FILE (PICK 'ONEOF (DIRECTORY (OR (MEDLEYDIR (OR (CAR CHOICES)
|
||||
(PICK 'DIR))
|
||||
NIL T)
|
||||
(FETCH (GIT-PROJECT CLONEPATH)
|
||||
OF (CDR (ASSOC (CAR CHOICES)
|
||||
GIT-PROJECTS])
|
||||
(PROJECT
|
||||
(* ;; "pick PROJECT will choose some repo to work on")
|
||||
|
||||
[PICK 'ONEOF (PICK 'ONEOF (LIST (MAPCAR GIT-PROJECTS #'CAR)
|
||||
'(CLOS ROOMS ONLINE WEBSITE COMMUNITY ENVOS])
|
||||
(HELP TYPE "Unknown type"])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (735 4238 (PICK 745 . 4236)))))
|
||||
STOP
|
||||
BIN
lispusers/PICK.LCOM
Normal file
BIN
lispusers/PICK.LCOM
Normal file
Binary file not shown.
BIN
lispusers/PICK.TEDIT
Normal file
BIN
lispusers/PICK.TEDIT
Normal file
Binary file not shown.
@@ -1,18 +1,20 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "12-Aug-87 03:05:50" {PHYLUM}<SHRAGER>LISP>QIX.\;3 11097
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
|changes| |to:| (VARS QIXCOMS)
|
||||
(FILECREATED "24-Aug-2022 07:58:48" |{DSK}<home>larry>medley>lispusers>QIX.;2| 11276
|
||||
|
||||
|previous| |date:| " 1-Aug-87 17:04:27" {PHYLUM}<SHRAGER>LISP>QIX.\;2)
|
||||
:CHANGES-TO (FNS QIX.IDLE)
|
||||
|
||||
:PREVIOUS-DATE "12-Aug-87 03:05:50" |{DSK}<home>larry>medley>lispusers>QIX.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987 by Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT QIXCOMS)
|
||||
|
||||
(RPAQQ QIXCOMS ((FNS QIX.GROW QIX.IDLE QIX.MOVE.POINT QIX.PLAY)
|
||||
(RECORDS QIX.POINT)
|
||||
(P (SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE) IDLE.FUNCTIONS)))))
|
||||
(P (SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE)
|
||||
IDLE.FUNCTIONS)))))
|
||||
(DEFINEQ
|
||||
|
||||
(QIX.GROW
|
||||
@@ -109,16 +111,18 @@
|
||||
(GO LOOP))))
|
||||
|
||||
(QIX.IDLE
|
||||
(LAMBDA (W) (* \; "Edited 1-Aug-87 16:58 by JEFF.SHRAGER")
|
||||
|
||||
(* * CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND
|
||||
(WASTING SPACE) FROM BEFORE.)
|
||||
(LAMBDA (W) (* \; "Edited 24-Aug-2022 07:53 by larry")
|
||||
(* \;
|
||||
"Edited 1-Aug-87 16:58 by JEFF.SHRAGER")
|
||||
|
||||
(* * CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND
|
||||
(WASTING SPACE) FROM BEFORE.)
|
||||
|
||||
(AND (BOUNDP '*OLD-QIXS*)
|
||||
(FOR Q IN *OLD-QIXS* DO (RPLACD Q NIL)))
|
||||
(PROG (P P2 L QIXS)
|
||||
|
||||
(* * P |and| P2 |define| \a QIX.)
|
||||
|
||||
(* * P |and| P2 |define| \a QIX.)
|
||||
|
||||
(SETQ QIXS (|for| I |from| 1 |to| 5
|
||||
|collect| (PROGN (SETQ P (|create| QIX.POINT
|
||||
@@ -131,10 +135,10 @@
|
||||
Y _ (RAND 1 100)
|
||||
VH _ (RAND 1 20)
|
||||
VV _ (RAND 1 20)))
|
||||
|
||||
(* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|
|
||||
|gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|
|
||||
|own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|)
|
||||
|
||||
(* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|
|
||||
|gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|
|
||||
|own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|)
|
||||
|
||||
(SETQ L
|
||||
(APPEND (|for| X |from| 1 |to| (RAND 5 25)
|
||||
@@ -148,12 +152,12 @@
|
||||
(LIST P P2 L))))
|
||||
(SETQ *OLD-QIXS* QIXS)
|
||||
LOOP
|
||||
(DISMISS)
|
||||
(BLOCK 25)
|
||||
(|for| Q |in| QIXS |do| (SETQ P (CAR Q))
|
||||
(SETQ P2 (CADR Q))
|
||||
(SETQ L (CADDR Q))
|
||||
|
||||
(* * |Draw| |the| |QIX's| |head| |line.|)
|
||||
|
||||
(* * |Draw| |the| |QIX's| |head| |line.|)
|
||||
|
||||
(MOVETO (|fetch| X P)
|
||||
(|fetch| Y P)
|
||||
@@ -162,13 +166,13 @@
|
||||
(|fetch| Y P2)
|
||||
1
|
||||
'REPLACE W)
|
||||
|
||||
(* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|)
|
||||
|
||||
(* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|)
|
||||
|
||||
(QIX.MOVE.POINT P W)
|
||||
(QIX.MOVE.POINT P2 W)
|
||||
|
||||
(* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|)
|
||||
|
||||
(* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|)
|
||||
|
||||
(COND
|
||||
((EQ (CAAR L)
|
||||
@@ -181,10 +185,10 @@
|
||||
(CADDDR OLD)
|
||||
1
|
||||
'ERASE W))))
|
||||
|
||||
(* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|
|
||||
|effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we| THEN
|
||||
|immediately| |move| |to| |the| |next| |elt| |in| |this| |circular| |list.|)
|
||||
|
||||
(* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|
|
||||
|effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we| THEN
|
||||
|immediately| |move| |to| |the| |next| |elt| |in| |this| |circular| |list.|)
|
||||
|
||||
(RPLACA (CAR L)
|
||||
(|fetch| X P))
|
||||
@@ -247,9 +251,11 @@
|
||||
|
||||
(RECORD QIX.POINT (X Y VH VV))
|
||||
)
|
||||
(SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE) IDLE.FUNCTIONS))
|
||||
|
||||
(SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE)
|
||||
IDLE.FUNCTIONS))
|
||||
(PUTPROPS QIX COPYRIGHT ("Xerox Corporation" 1987))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (539 10893 (QIX.GROW 549 . 4105) (QIX.IDLE 4107 . 8821) (QIX.MOVE.POINT 8823 . 10205) (
|
||||
QIX.PLAY 10207 . 10891)))))
|
||||
(FILEMAP (NIL (592 11044 (QIX.GROW 602 . 4158) (QIX.IDLE 4160 . 8972) (QIX.MOVE.POINT 8974 . 10356) (
|
||||
QIX.PLAY 10358 . 11042)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,14 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED " 6-Nov-92 09:25:48" {DSK}<project>medley2.0>lispusers>READBRUSH.;1 9607
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
previous date%: "23-Jun-88 02:13:42" {DSK}<import>lisp>medley>lispusers>readbrush.;1)
|
||||
(FILECREATED "24-Aug-2022 07:58:48" {DSK}<home>larry>medley>lispusers>READBRUSH.;2 9288
|
||||
|
||||
:CHANGES-TO (FNS IDLE.GLIDING.BOX)
|
||||
|
||||
:PREVIOUS-DATE " 6-Nov-92 09:25:48" {DSK}<home>larry>medley>lispusers>READBRUSH.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1984-1986, 1988, 1992 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT READBRUSHCOMS)
|
||||
@@ -93,17 +96,18 @@ Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights res
|
||||
'PRESS])
|
||||
|
||||
(IDLE.GLIDING.BOX
|
||||
[LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 23-Jun-88 01:53 by masinter")
|
||||
[LAMBDA (WIN BITMAPS WAIT WAITSEQ MAXD) (* ; "Edited 24-Aug-2022 07:57 by larry")
|
||||
(* ; "Edited 23-Jun-88 01:53 by masinter")
|
||||
(OR BITMAPS (SETQ BITMAPS IDLE.BOUNCING.BOX))
|
||||
[OR WIN (SETQ WIN (OR POLYGONSWINDOW (SETQ POLYGONSWINDOW (CREATEW]
|
||||
(OR MAXD (SETQ MAXD 4))
|
||||
(OR WAIT (SETQ WAIT 50))
|
||||
[SETQ BITMAPS (for X inside BITMAPS
|
||||
collect (if (LITATOM X)
|
||||
then [OR (GETPROP X 'BITMAP)
|
||||
(PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE
|
||||
X))
|
||||
(BITMAPCREATE 10 10]
|
||||
else (IDLE.BITMAP NIL X]
|
||||
then [OR (GETPROP X 'BITMAP)
|
||||
(PUTPROP X 'BITMAP (OR (CAR (READBRUSHFILE X))
|
||||
(BITMAPCREATE 10 10]
|
||||
else (IDLE.BITMAP NIL X]
|
||||
(LET ((W (for X in BITMAPS largest (BITMAPWIDTH X) finally (RETURN $$EXTREME)))
|
||||
(H (for X in BITMAPS largest (BITMAPHEIGHT X) finally (RETURN $$EXTREME)))
|
||||
(REG (DSPCLIPPINGREGION NIL WIN)))
|
||||
@@ -123,51 +127,49 @@ Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights res
|
||||
(BITBLT (SETQ THISBITMAP (CAR BITMAPS))
|
||||
NIL NIL WIN X Y NIL NIL NIL 'INVERT)
|
||||
(while T do [COND
|
||||
((ILEQ CNT 0)
|
||||
(SETQ ORIGX X)
|
||||
(SETQ ORIGY Y)
|
||||
(SETQ TOX (RAND 1 (SUB1 MAXX)))
|
||||
(SETQ TOY (RAND 1 (SUB1 MAXY)))
|
||||
(SETQ CNT (SETQ STEPS
|
||||
(QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X))
|
||||
(ABS (DIFFERENCE TOY Y)))
|
||||
MAXD -1)
|
||||
MAXD)))
|
||||
(QUOTIENT (PLUS (ABS (DIFFERENCE TOX X))
|
||||
STEPS -1)
|
||||
STEPS))
|
||||
(T (SETQ CNT (SUB1 CNT]
|
||||
(SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX))
|
||||
STEPS)
|
||||
TOX))
|
||||
(if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY))
|
||||
STEPS)
|
||||
TOY))
|
||||
(if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE)
|
||||
(BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT)
|
||||
(BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX)
|
||||
(PLUS MAXD DY)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD)
|
||||
(DIFFERENCE Y MAXD)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(DISMISS WAIT])
|
||||
((ILEQ CNT 0)
|
||||
(SETQ ORIGX X)
|
||||
(SETQ ORIGY Y)
|
||||
(SETQ TOX (RAND 1 (SUB1 MAXX)))
|
||||
(SETQ TOY (RAND 1 (SUB1 MAXY)))
|
||||
(SETQ CNT (SETQ STEPS (QUOTIENT (PLUS (MAX (ABS (DIFFERENCE TOX X))
|
||||
(ABS (DIFFERENCE TOY Y)))
|
||||
MAXD -1)
|
||||
MAXD)))
|
||||
(QUOTIENT (PLUS (ABS (DIFFERENCE TOX X))
|
||||
STEPS -1)
|
||||
STEPS))
|
||||
(T (SETQ CNT (SUB1 CNT]
|
||||
(SETQ NEWX (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGX TOX))
|
||||
STEPS)
|
||||
TOX))
|
||||
(if (GREATERP (ABS (SETQ DX (DIFFERENCE NEWX X)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(SETQ NEWY (PLUS (QUOTIENT (TIMES CNT (DIFFERENCE ORIGY TOY))
|
||||
STEPS)
|
||||
TOY))
|
||||
(if (GREATERP (ABS (SETQ DY (DIFFERENCE NEWY Y)))
|
||||
MAXD)
|
||||
then (SHOULDNT))
|
||||
(BITBLT NIL NIL NIL XBM NIL NIL NIL NIL 'TEXTURE 'ERASE BLACKSHADE)
|
||||
(BITBLT THISBITMAP NIL NIL XBM MAXD MAXD NIL NIL NIL 'INVERT)
|
||||
(BITBLT THISBITMAP NIL NIL XBM (PLUS MAXD DX)
|
||||
(PLUS MAXD DY)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(BITBLT XBM NIL NIL WIN (DIFFERENCE X MAXD)
|
||||
(DIFFERENCE Y MAXD)
|
||||
NIL NIL NIL 'INVERT)
|
||||
(add X DX)
|
||||
(add Y DY)
|
||||
(DISMISS WAIT])
|
||||
)
|
||||
|
||||
(FILESLOAD BITMAPFNS)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ["Gliding box" 'IDLE.GLIDING.BOX "moves images around on the screen"
|
||||
(SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP
|
||||
)
|
||||
'IDLE.GLIDING.BOX])
|
||||
(SUBITEMS ("Pick image from MesaHacks" (PROGN (CHOOSE.IDLE.BITMAP)
|
||||
'IDLE.GLIDING.BOX])
|
||||
|
||||
(RPAQ? IDLE.BITMAP )
|
||||
|
||||
@@ -178,6 +180,6 @@ Copyright (c) 1984, 1985, 1986, 1988, 1992 by Xerox Corporation. All rights res
|
||||
(RPAQ? BRUSHDIRECTORY "{goofy:osbu north:xerox}<hacks>data>brushes>")
|
||||
(PUTPROPS READBRUSH COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988 1992))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1444 8940 (CHOOSE.IDLE.BITMAP 1454 . 2452) (READBRUSHFILE 2454 . 3500) (READBRUSH 3502
|
||||
. 4314) (READROOTPICTURE 4316 . 4655) (IDLE.GLIDING.BOX 4657 . 8938)))))
|
||||
(FILEMAP (NIL (1467 8713 (CHOOSE.IDLE.BITMAP 1477 . 2475) (READBRUSHFILE 2477 . 3523) (READBRUSH 3525
|
||||
. 4337) (READROOTPICTURE 4339 . 4678) (IDLE.GLIDING.BOX 4680 . 8711)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,23 +1,96 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 5-Aug-88 15:17:16" |{POGO:AISNORTH:XEROX}<ROOMS>MEDLEY>USERS>SCREENPAPER.;1| 10019
|
||||
|
||||
changes to%: (FNS SCREENPAPER KALSHOW SCREENPAPERNEWREGIONFN) (VARS SCREENPAPERCOMS)
|
||||
(FILECREATED "24-Aug-2022 07:49:42" {DSK}<home>larry>medley>lispusers>SCREENPAPER.;2 12374
|
||||
|
||||
previous date%: " 4-Aug-88 13:46:25" {ERINYES}<LISPUSERS>MEDLEY>SCREENPAPER.;4)
|
||||
:CHANGES-TO (FNS SCREENPAPER)
|
||||
|
||||
:PREVIOUS-DATE " 5-Aug-88 15:17:16" {DSK}<home>larry>medley>lispusers>SCREENPAPER.;1)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved.
|
||||
(* ; "
|
||||
Copyright (c) 1901, 1986, 1988 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SCREENPAPERCOMS)
|
||||
|
||||
(RPAQQ SCREENPAPERCOMS ((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN) (ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" (QUOTE SCREENPAPER)))) (* ;;; "faster versions of editbitmap functions") (FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP) (VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT)))
|
||||
(RPAQQ SCREENPAPERCOMS
|
||||
((FNS SCREENPAPER SCREENPAPERNEWREGIONFN KALSHOW DOPOINT MAPN)
|
||||
[ADDVARS (IDLE.FUNCTIONS ("Screen wallpaper" 'SCREENPAPER]
|
||||
|
||||
|
||||
(* ;;; "faster versions of editbitmap functions")
|
||||
|
||||
(FNS INVERT.BITMAP.HORIZONTALLY INVERT.BITMAP.VERTICALLY ROTATE.BITMAP)
|
||||
(VARS SCREENPAPERSIZE SCREENPERIOD SCREENREPEAT)))
|
||||
(DEFINEQ
|
||||
|
||||
(SCREENPAPER
|
||||
(LAMBDA (WINDOW REGION.OR.SIZE OPTION) (* ; "Edited 5-Aug-88 15:07 by drc:") (OR WINDOW (SETQ WINDOW (CREATEW))) (OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if (EQ OPTION (QUOTE PICK)) then (GETREGION 0 0 NIL (FUNCTION SCREENPAPERNEWREGIONFN)) else SCREENPAPERSIZE))) (LET ((SIZE (if (REGIONP REGION.OR.SIZE) then (fetch (REGION WIDTH) REGION.OR.SIZE) else REGION.OR.SIZE)) TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD)) (DECLARE (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT)) (SETQ TRIANGLE (BITMAPCREATE SIZE SIZE)) (SETQ BUF1 (BITMAPCREATE SIZE SIZE)) (SETQ STREAM (DSPCREATE TRIANGLE)) (FILLPOLYGON (LIST (QUOTE (-1 . -1)) (CONS SIZE SIZE) (CONS -1 SIZE)) BLACKSHADE STREAM) (SETQ BUF2 (BITMAPCREATE SIZE SIZE)) (SETQ BUF3 (BITMAPCREATE SIZE SIZE)) (SETQ 2SIZE (PLUS SIZE SIZE)) (SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE)) (SETQ PBT (create PILOTBBT)) (DSPDESTINATION BUF1 STREAM) (if (EQ OPTION (QUOTE PICK)) then (bind POS do (RESETFORM (CURSOR CROSSHAIRS) (until (MOUSESTATE (OR LEFT MIDDLE RIGHT)))) (if (LASTMOUSESTATE (ONLY MIDDLE)) then (RETURN BIGBUF) elseif (LASTMOUSESTATE (ONLY RIGHT)) then (RETURN NIL) elseif (REGIONP REGION.OR.SIZE) then (SETQ POS (CONS (fetch (REGION LEFT) REGION.OR.SIZE) (fetch (REGION BOTTOM) REGION.OR.SIZE))) (SETQ REGION.OR.SIZE) else (SETQ POS (GETBOXPOSITION SIZE SIZE))) (BITBLT (SCREENBITMAP) (CAR POS) (CDR POS) BUF1 0 0 SIZE SIZE) (KALSHOW BUF1 WINDOW SIZE (if (SHIFTDOWNP (QUOTE SHIFT)) then (QUOTE INVERT) else NIL))) else (MAPN WINDOW (FUNCTION (LAMBDA (X Y) (BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)) X Y BUF1 0 0 SIZE SIZE) (DRAWLINE (SUB1 SIZE) 0 (RAND 0 (SUB1 SIZE)) (RAND 0 (SUB1 SIZE)) 1 (QUOTE INVERT) STREAM) (KALSHOW BUF1 WINDOW SIZE (if (VIDEOCOLOR) then NIL else (QUOTE INVERT))) (if (LEQ (add CNT -1) 0) then (SETQ CNT SCREENPERIOD) (to SCREENREPEAT do (BITBLT WINDOW 0 0 BUF1) (KALSHOW BUF1 WINDOW SIZE)))))))))
|
||||
)
|
||||
[LAMBDA (WINDOW REGION.OR.SIZE OPTION) (* ; "Edited 24-Aug-2022 07:46 by larry")
|
||||
(* ; "Edited 5-Aug-88 15:07 by drc:")
|
||||
(OR WINDOW (SETQ WINDOW (CREATEW)))
|
||||
(OR REGION.OR.SIZE (SETQ REGION.OR.SIZE (if (EQ OPTION 'PICK)
|
||||
then (GETREGION 0 0 NIL (FUNCTION
|
||||
SCREENPAPERNEWREGIONFN))
|
||||
else SCREENPAPERSIZE)))
|
||||
(LET ((SIZE (if (REGIONP REGION.OR.SIZE)
|
||||
then (fetch (REGION WIDTH)
|
||||
REGION.OR.SIZE)
|
||||
else REGION.OR.SIZE))
|
||||
TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY (CNT SCREENPERIOD))
|
||||
(DECLARE (SPECVARS TRIANGLE STREAM BUF1 2SIZE BIGBUF PBT BUF1A BUF2 BUF3 BUF4 CX CY CNT))
|
||||
(SETQ TRIANGLE (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ BUF1 (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ STREAM (DSPCREATE TRIANGLE))
|
||||
(FILLPOLYGON (LIST '(-1 . -1)
|
||||
(CONS SIZE SIZE)
|
||||
(CONS -1 SIZE))
|
||||
BLACKSHADE STREAM)
|
||||
(SETQ BUF2 (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ BUF3 (BITMAPCREATE SIZE SIZE))
|
||||
(SETQ 2SIZE (PLUS SIZE SIZE))
|
||||
(SETQ BIGBUF (BITMAPCREATE 2SIZE 2SIZE))
|
||||
(SETQ PBT (create PILOTBBT))
|
||||
(DSPDESTINATION BUF1 STREAM)
|
||||
(if (EQ OPTION 'PICK)
|
||||
then (bind POS do [RESETFORM (CURSOR CROSSHAIRS)
|
||||
(until (MOUSESTATE (OR LEFT MIDDLE RIGHT]
|
||||
(if (LASTMOUSESTATE (ONLY MIDDLE))
|
||||
then (RETURN BIGBUF)
|
||||
elseif (LASTMOUSESTATE (ONLY RIGHT))
|
||||
then (RETURN NIL)
|
||||
elseif (REGIONP REGION.OR.SIZE)
|
||||
then (SETQ POS (CONS (fetch (REGION LEFT)
|
||||
REGION.OR.SIZE)
|
||||
(fetch (REGION BOTTOM)
|
||||
REGION.OR.SIZE)))
|
||||
(SETQ REGION.OR.SIZE)
|
||||
else (SETQ POS (GETBOXPOSITION SIZE SIZE)))
|
||||
(BITBLT (SCREENBITMAP)
|
||||
(CAR POS)
|
||||
(CDR POS)
|
||||
BUF1 0 0 SIZE SIZE)
|
||||
(KALSHOW BUF1 WINDOW SIZE (if (SHIFTDOWNP 'SHIFT)
|
||||
then 'INVERT
|
||||
else NIL)))
|
||||
else (MAPN WINDOW (FUNCTION (LAMBDA (X Y)
|
||||
(BITBLT (WINDOWPROP WINDOW 'IMAGECOVERED)
|
||||
X Y BUF1 0 0 SIZE SIZE)
|
||||
(DRAWLINE (SUB1 SIZE)
|
||||
0
|
||||
(RAND 0 (SUB1 SIZE))
|
||||
(RAND 0 (SUB1 SIZE))
|
||||
1
|
||||
'INVERT STREAM)
|
||||
(KALSHOW BUF1 WINDOW SIZE (if (VIDEOCOLOR)
|
||||
then NIL
|
||||
else 'INVERT))
|
||||
(BLOCK 100)
|
||||
(if (LEQ (add CNT -1)
|
||||
0)
|
||||
then (SETQ CNT SCREENPERIOD)
|
||||
(to SCREENREPEAT
|
||||
do (BITBLT WINDOW 0 0 BUF1)
|
||||
(KALSHOW BUF1 WINDOW SIZE])
|
||||
|
||||
(SCREENPAPERNEWREGIONFN
|
||||
(LAMBDA (FP MP) (* BN "17-Sep-84 10:40") (COND (MP (with POSITION MP (PROG ((DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP))) (DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP)))) (COND ((IGREATERP (IABS DX) (IABS DY)) (SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP) (ITIMES DX (COND ((MINUSP (ITIMES DX DY)) -1) (T 1)))))) (T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP) (ITIMES DY (COND ((MINUSP (ITIMES DX DY)) -1) (T 1))))))) (RETURN MP)))) (T FP)))
|
||||
@@ -66,7 +139,7 @@ Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved.
|
||||
(SETQ Y NY])
|
||||
)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Screen wallpaper" (QUOTE SCREENPAPER)))
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Screen wallpaper" 'SCREENPAPER))
|
||||
|
||||
|
||||
|
||||
@@ -142,14 +215,14 @@ Copyright (c) 1901, 1986, 1988 by Xerox Corporation. All rights reserved.
|
||||
BM2])
|
||||
)
|
||||
|
||||
(RPAQQ SCREENPAPERSIZE 64)
|
||||
(RPAQQ SCREENPAPERSIZE 64)
|
||||
|
||||
(RPAQQ SCREENPERIOD 100)
|
||||
(RPAQQ SCREENPERIOD 100)
|
||||
|
||||
(RPAQQ SCREENREPEAT 0)
|
||||
(RPAQQ SCREENREPEAT 0)
|
||||
(PUTPROPS SCREENPAPER COPYRIGHT ("Xerox Corporation" 1901 1986 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (805 5979 (SCREENPAPER 815 . 2782) (SCREENPAPERNEWREGIONFN 2784 . 3291) (KALSHOW 3293 .
|
||||
4283) (DOPOINT 4285 . 4657) (MAPN 4659 . 5977)) (6106 9848 (INVERT.BITMAP.HORIZONTALLY 6116 . 7233) (
|
||||
INVERT.BITMAP.VERTICALLY 7235 . 8611) (ROTATE.BITMAP 8613 . 9846)))))
|
||||
(FILEMAP (NIL (770 8325 (SCREENPAPER 780 . 5128) (SCREENPAPERNEWREGIONFN 5130 . 5637) (KALSHOW 5639 .
|
||||
6629) (DOPOINT 6631 . 7003) (MAPN 7005 . 8323)) (8449 12191 (INVERT.BITMAP.HORIZONTALLY 8459 . 9576) (
|
||||
INVERT.BITMAP.VERTICALLY 9578 . 10954) (ROTATE.BITMAP 10956 . 12189)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
1038
lispusers/SOLITAIRE
1038
lispusers/SOLITAIRE
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,13 +1,14 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "17-Aug-88 03:26:58" {ERINYES}<LISPUSERS>MEDLEY>STARBG.;2 16928
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS Cosmos)
|
||||
(FILECREATED "24-Aug-2022 08:54:17" {DSK}<home>larry>medley>lispusers>STARBG.;2 16815
|
||||
|
||||
previous date%: "12-Oct-87 17:02:01" {ERINYES}<LISP>LYRIC>LISPUSERS>STARBG.;2)
|
||||
:CHANGES-TO (FNS Cosmos)
|
||||
|
||||
:PREVIOUS-DATE "17-Aug-88 03:26:58" {DSK}<home>larry>medley>lispusers>STARBG.;1)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||
(* ; "
|
||||
Copyright (c) 1984-1988 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT STARBGCOMS)
|
||||
@@ -109,10 +110,10 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
|
||||
|
||||
(RPAQQ supernova #*(13 13)OMOHOMOHOHOHN@CHN@CHL@AH@@@@L@AHN@CHN@CHOHOHOMOHOMOH)
|
||||
|
||||
(RPAQQ STARBGParameters (SBM BM1 BM2 BM3 BM4 BM5 nova supernova stars1 stars2 stars3 stars4
|
||||
stars5 changeStars eventPause clusters clusterRadius constellations
|
||||
starsInCluster superClusters superClusterRadius interiorClusters
|
||||
starsInterior))
|
||||
(RPAQQ STARBGParameters (SBM BM1 BM2 BM3 BM4 BM5 nova supernova stars1 stars2 stars3 stars4 stars5
|
||||
changeStars eventPause clusters clusterRadius constellations
|
||||
starsInCluster superClusters superClusterRadius interiorClusters
|
||||
starsInterior))
|
||||
|
||||
(RPAQQ trekNotes (<A+ D/ G+ F# E/ D/ D@/ C))
|
||||
(DEFINEQ
|
||||
@@ -140,39 +141,39 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
|
||||
)
|
||||
|
||||
(Cosmos
|
||||
[LAMBDA (starWindow) (* ; "Edited 17-Aug-88 03:25 by EWEAVER")
|
||||
[LAMBDA (starWindow) (* ; "Edited 24-Aug-2022 08:05 by larry")
|
||||
(* ; "Edited 17-Aug-88 03:25 by EWEAVER")
|
||||
(OR starWindow (SETQ starWindow (CREATEW WHOLESCREEN NIL 0)))
|
||||
(if (VIDEOCOLOR)
|
||||
then (RESETLST
|
||||
(RESETSAVE voidShade WHITESHADE)
|
||||
(RESETSAVE starShade BLACKSHADE)
|
||||
(DSPFILL NIL voidShade 'REPLACE starWindow)
|
||||
(RESETSAVE BM1 (InvertBM BM1))
|
||||
(RESETSAVE BM2 (InvertBM BM2))
|
||||
(RESETSAVE BM3 (InvertBM BM3))
|
||||
(RESETSAVE BM4 (InvertBM BM4))
|
||||
(RESETSAVE BM5 (InvertBM BM5))
|
||||
(RESETSAVE cursorFollower (ICONW darkSaucer saucerMask (CREATEPOSITION 0 0)
|
||||
T))
|
||||
(RESETSAVE nova (InvertBM nova))
|
||||
(RESETSAVE supernova (InvertBM supernova))
|
||||
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (starWindow)
|
||||
(if changeStars
|
||||
then (BITBLT (InvertBM starWindow
|
||||
'inPlace)
|
||||
0 0 SBM)
|
||||
(CLOSEW starWindow)
|
||||
(CHANGEBACKGROUND SBM)
|
||||
(CLOSEW cursorFollower]
|
||||
starWindow))
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK eventPause)))
|
||||
(RESETSAVE voidShade WHITESHADE)
|
||||
(RESETSAVE starShade BLACKSHADE)
|
||||
(DSPFILL NIL voidShade 'REPLACE starWindow)
|
||||
(RESETSAVE BM1 (InvertBM BM1))
|
||||
(RESETSAVE BM2 (InvertBM BM2))
|
||||
(RESETSAVE BM3 (InvertBM BM3))
|
||||
(RESETSAVE BM4 (InvertBM BM4))
|
||||
(RESETSAVE BM5 (InvertBM BM5))
|
||||
(RESETSAVE cursorFollower (ICONW darkSaucer saucerMask (CREATEPOSITION 0 0)
|
||||
T))
|
||||
(RESETSAVE nova (InvertBM nova))
|
||||
(RESETSAVE supernova (InvertBM supernova))
|
||||
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (starWindow)
|
||||
(if changeStars
|
||||
then (BITBLT (InvertBM starWindow 'inPlace)
|
||||
0 0 SBM)
|
||||
(CLOSEW starWindow)
|
||||
(CHANGEBACKGROUND SBM)
|
||||
(CLOSEW cursorFollower]
|
||||
starWindow))
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK eventPause)))
|
||||
else (DSPFILL NIL voidShade 'REPLACE starWindow)
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK))
|
||||
(CLOSEW starWindow])
|
||||
(DSPOPERATION 'REPLACE starWindow)
|
||||
(while T do (SomethingCosmic starWindow)
|
||||
(BLOCK 100))
|
||||
(CLOSEW starWindow])
|
||||
|
||||
(InvertBM
|
||||
(LAMBDA (bm inPlace?) (* gsf " 2-Jan-86 14:32") (LET ((bitmap (if inPlace? then bm else (BITMAPCOPY bm)))) (BITBLT bm NIL NIL bitmap NIL NIL NIL NIL (QUOTE INVERT) (QUOTE REPLACE)) bitmap))
|
||||
@@ -267,12 +268,12 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res
|
||||
then (PUSH IDLE.FUNCTIONS '("Cosmos" 'Cosmos "Go where no one has gone before... "]
|
||||
(PUTPROPS STARBG COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4118 16416 (Between 4128 . 4281) (BlackHole 4283 . 4570) (Catastrophe 4572 . 4838) (
|
||||
ChanceIn 4840 . 4926) (CloseFollower 4928 . 5008) (Constellation 5010 . 5560) (Cosmos 5562 . 7701) (
|
||||
InvertBM 7703 . 7904) (FillWithStars 7906 . 9356) (Marble 9358 . 9953) (OneChanceIn 9955 . 10022) (
|
||||
LowerBound 10024 . 10108) (OpenFollower 10110 . 10207) (PlusOrMinus 10209 . 10311) (RandGrey 10313 .
|
||||
10792) (SaucerOn 10794 . 11029) (SaucerOff 11031 . 11211) (STARBG 11213 . 11497) (StarCluster 11499 .
|
||||
12245) (SuperCluster 12247 . 12588) (SomethingCosmic 12590 . 14445) (StarFollowCursor 14447 . 14744) (
|
||||
StarryWindow 14746 . 15217) (Stomp 15219 . 15666) (TimePasses 15668 . 15775) (UFO 15777 . 16328) (
|
||||
UpperBound 16330 . 16414)))))
|
||||
(FILEMAP (NIL (4087 16303 (Between 4097 . 4250) (BlackHole 4252 . 4539) (Catastrophe 4541 . 4807) (
|
||||
ChanceIn 4809 . 4895) (CloseFollower 4897 . 4977) (Constellation 4979 . 5529) (Cosmos 5531 . 7588) (
|
||||
InvertBM 7590 . 7791) (FillWithStars 7793 . 9243) (Marble 9245 . 9840) (OneChanceIn 9842 . 9909) (
|
||||
LowerBound 9911 . 9995) (OpenFollower 9997 . 10094) (PlusOrMinus 10096 . 10198) (RandGrey 10200 .
|
||||
10679) (SaucerOn 10681 . 10916) (SaucerOff 10918 . 11098) (STARBG 11100 . 11384) (StarCluster 11386 .
|
||||
12132) (SuperCluster 12134 . 12475) (SomethingCosmic 12477 . 14332) (StarFollowCursor 14334 . 14631) (
|
||||
StarryWindow 14633 . 15104) (Stomp 15106 . 15553) (TimePasses 15555 . 15662) (UFO 15664 . 16215) (
|
||||
UpperBound 16217 . 16301)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-May-2022 23:48:59"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;112 7835
|
||||
(FILECREATED "25-Sep-2022 11:00:07"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>TEDIT-PF-SEE.;113 7734
|
||||
|
||||
:CHANGES-TO (COMMANDS ts tf)
|
||||
(FNS PF-TEDIT)
|
||||
(VARS TEDIT-PF-SEECOMS)
|
||||
|
||||
:PREVIOUS-DATE " 5-May-2022 23:26:29"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;111)
|
||||
:PREVIOUS-DATE " 5-May-2022 23:48:59"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>TEDIT-PF-SEE.;112)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-PF-SEECOMS)
|
||||
@@ -18,7 +14,7 @@
|
||||
(COMMANDS ts tf)
|
||||
(FILES (SYSLOAD)
|
||||
REGIONMANAGER)
|
||||
(P (MOVD? 'PFCOPYBYTES 'PFI.mAYBE.PP.DEFINITION))
|
||||
(P (MOVD? 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
@@ -138,7 +134,7 @@
|
||||
(FILESLOAD (SYSLOAD)
|
||||
REGIONMANAGER)
|
||||
|
||||
(MOVD? 'PFCOPYBYTES 'PFI.mAYBE.PP.DEFINITION)
|
||||
(MOVD? 'PFCOPYBYTES 'PFI.MAYBE.PP.DEFINITION)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
@@ -148,5 +144,5 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (911 7309 (PF-TEDIT 921 . 7307)))))
|
||||
(FILEMAP (NIL (810 7208 (PF-TEDIT 820 . 7206)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
24
lispusers/UNIXYCD
Normal file
24
lispusers/UNIXYCD
Normal file
@@ -0,0 +1,24 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "12-Aug-2022 12:29:18" {DSK}<home>larry>medley>lispusers>UNIXYCD.;1 568
|
||||
|
||||
:CHANGES-TO (VARS UNIXYCDCOMS)
|
||||
|
||||
:PREVIOUS-DATE "12-Aug-2022 11:14:47" {DSK}<home>larry>medley>lispusers>UNIXYCD.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNIXYCDCOMS)
|
||||
|
||||
(RPAQQ UNIXYCDCOMS ((COMMANDS "cd" "ls" "pwd")))
|
||||
|
||||
(DEFCOMMAND "cd" (DIR)
|
||||
(/CNDIR DIR))
|
||||
|
||||
(DEFCOMMAND "ls" (FIRST . REST)
|
||||
(DODIR (CONS FIRST REST)))
|
||||
|
||||
(DEFCOMMAND "pwd" ()
|
||||
(DIRECTORYNAME T))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
13
lispusers/UNIXYCD.LCOM
Normal file
13
lispusers/UNIXYCD.LCOM
Normal file
@@ -0,0 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "12-Aug-2022 12:29:30" ("compiled on " {DSK}<home>larry>medley>lispusers>UNIXYCD.;1)
|
||||
"12-Aug-2022 10:18:11" bcompl'd in "Welcome to Fuller sysout 12-Aug-2022 ..." dated
|
||||
"12-Aug-2022 10:22:21")
|
||||
(FILECREATED "12-Aug-2022 12:29:18" {DSK}<home>larry>medley>lispusers>UNIXYCD.;1 568 :CHANGES-TO (VARS
|
||||
UNIXYCDCOMS) :PREVIOUS-DATE "12-Aug-2022 11:14:47" {DSK}<home>larry>medley>lispusers>UNIXYCD.;1)
|
||||
(PRETTYCOMPRINT UNIXYCDCOMS)
|
||||
(RPAQQ UNIXYCDCOMS ((COMMANDS "cd" "ls" "pwd")))
|
||||
(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))
|
||||
(DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST)))
|
||||
(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))
|
||||
NIL
|
||||
13
lispusers/UNIXYCD.TXT
Normal file
13
lispusers/UNIXYCD.TXT
Normal file
@@ -0,0 +1,13 @@
|
||||
UNIXYCD & .LCOM .TXT
|
||||
|
||||
|
||||
This file implements little commands:
|
||||
|
||||
cd change Lisp's current directory to home
|
||||
cd dir dir can be a path separated by / or >.
|
||||
if no "hostname" is given, it's assumed {DSK}
|
||||
ls [dir] list current directory or a directory that's given
|
||||
non-feature: ls foo only prints foo; you need to
|
||||
specify ls foo/
|
||||
pwd print working directory
|
||||
|
||||
File diff suppressed because one or more lines are too long
BIN
lispusers/migration/IL-SIM.gz
Normal file
BIN
lispusers/migration/IL-SIM.gz
Normal file
Binary file not shown.
63
run-medley
63
run-medley
@@ -41,6 +41,7 @@ pass=""
|
||||
mem="-m 256"
|
||||
scroll=22
|
||||
noscroll=""
|
||||
title="Medley Interlisp"
|
||||
|
||||
if [ -z "$LDEDESTSYSOUT" ] ; then
|
||||
if [ -z "$LOGINDIR" ] ; then
|
||||
@@ -58,86 +59,88 @@ export LDEKBDTYPE=x
|
||||
|
||||
while [ "$#" -ne 0 ]; do
|
||||
case "$1" in
|
||||
"-loadup")
|
||||
-loadup)
|
||||
# Keep (GREET) from finding a different init file
|
||||
mkdir -p $MEDLEYDIR/tmp/logindir
|
||||
export LOGINDIR=$MEDLEYDIR/tmp/logindir
|
||||
|
||||
export MEDLEYLOADUP="$2"
|
||||
export LDEINIT="$2"
|
||||
shift
|
||||
;;
|
||||
"-nogreet" | "--nogreet")
|
||||
-nogreet | --nogreet)
|
||||
# Keep (GREET) from finding an init file
|
||||
mkdir -p $MEDLEYDIR/tmp/logindir
|
||||
export LOGINDIR=$MEDLEYDIR/tmp/logindir
|
||||
|
||||
export LDEINIT="$MEDLEYDIR/greetfiles/NOGREET"
|
||||
;;
|
||||
"-greet" | "--greet")
|
||||
-greet | --greet)
|
||||
export LDEINIT="$2"
|
||||
shift
|
||||
;;
|
||||
"-noscroll")
|
||||
-noscroll)
|
||||
scroll=0
|
||||
noscroll="-noscroll"
|
||||
;;
|
||||
"--dimensions" | "-dimensions")
|
||||
--dimensions | -dimensions)
|
||||
sw=`expr "$2" : "\([0-9]*\)x[0-9]*$"`
|
||||
sh=`expr "$2" : "[0-9]*x\([0-9]*\)$"`
|
||||
if [ -n "$sw" -a -n "$sh" ] ; then
|
||||
sw=$(( (31+$sw)/32*32 ))
|
||||
gw=$(( $scroll+$sw ))
|
||||
gh=$(( $scroll+$sh ))
|
||||
geometry="-g ${gw}x${gh}"
|
||||
screensize="-sc ${sw}x${sh}"
|
||||
sw=$(( (31+$sw)/32*32 ))
|
||||
gw=$(( $scroll+$sw ))
|
||||
gh=$(( $scroll+$sh ))
|
||||
geometry="-g ${gw}x${gh}"
|
||||
screensize="-sc ${sw}x${sh}"
|
||||
fi
|
||||
shift
|
||||
;;
|
||||
"--geometry" | "-geometry" | "-g")
|
||||
--geometry | -geometry | -g)
|
||||
geometry="-g $2"
|
||||
shift
|
||||
;;
|
||||
"--screensize" | "-screensize" | "-sc")
|
||||
--screensize | -screensize | -sc)
|
||||
screensize="-sc $2"
|
||||
shift
|
||||
;;
|
||||
"--display" | "-d")
|
||||
--display | -d)
|
||||
export DISPLAY="$2"
|
||||
shift
|
||||
;;
|
||||
"-prog" )
|
||||
-prog)
|
||||
prog="$2"
|
||||
shift
|
||||
;;
|
||||
"-m" | "-mem" )
|
||||
-m | -mem)
|
||||
mem="-m $2 "
|
||||
shift
|
||||
;;
|
||||
"-vmem" | "--vmem" | "-vmfile" )
|
||||
-title)
|
||||
title="$2"
|
||||
shift
|
||||
;;
|
||||
-vmem | --vmem | -vmfile)
|
||||
export LDEDESTSYSOUT="$2"
|
||||
shift
|
||||
;;
|
||||
"-full")
|
||||
-full)
|
||||
export LDESRCESYSOUT="$MEDLEYDIR/loadups/full.sysout"
|
||||
;;
|
||||
"-lisp")
|
||||
-lisp)
|
||||
export LDESRCESYSOUT="$MEDLEYDIR/loadups/lisp.sysout"
|
||||
;;
|
||||
"-n" | "-new" | "-newfull" )
|
||||
-n | -new | -newfull)
|
||||
export LDESRCESYSOUT="$MEDLEYDIR/tmp/full.sysout"
|
||||
;;
|
||||
"-nl" | "-newlisp" )
|
||||
-nl | -newlisp)
|
||||
export LDESRCESYSOUT="$MEDLEYDIR/tmp/lisp.sysout"
|
||||
;;
|
||||
"-NF")
|
||||
pass="$pass $1"
|
||||
-NF)
|
||||
pass="$pass $1" # for making init, don't fork
|
||||
;;
|
||||
"-*")
|
||||
-*)
|
||||
pass="$pass $1 $2"
|
||||
shift
|
||||
;;
|
||||
*)
|
||||
shift
|
||||
;;
|
||||
*)
|
||||
echo sysout "$1"
|
||||
export LDESRCESYSOUT="$1"
|
||||
;;
|
||||
@@ -194,10 +197,10 @@ if ! command -v "$prog" > /dev/null 2>&1; then
|
||||
fi
|
||||
fi
|
||||
|
||||
echo "running: $prog $noscroll $geometry $screensize $mem $pass $LDESRCESYSOUT"
|
||||
echo "running: $prog $noscroll $geometry $screensize -title \"$title\" $mem $pass $LDESRCESYSOUT"
|
||||
echo "greet: $LDEINIT"
|
||||
|
||||
export INMEDLEY=1
|
||||
|
||||
"$prog" $noscroll $geometry $screensize $mem -t "Medley Interlisp" $pass "$LDESRCESYSOUT"
|
||||
"$prog" $noscroll $geometry $screensize $mem -title "$title" $pass "$LDESRCESYSOUT"
|
||||
|
||||
|
||||
@@ -11,12 +11,9 @@ fi
|
||||
./scripts/loadup-mid-from-init.sh && \
|
||||
./scripts/loadup-lisp-from-mid.sh && \
|
||||
./scripts/loadup-full-from-lisp.sh && \
|
||||
./scripts/loadup-aux.sh
|
||||
./scripts/loadup-aux.sh && \
|
||||
./scripts/copy-all.sh
|
||||
|
||||
echo "loadups are in $MEDLEYDIR/tmp"
|
||||
echo use
|
||||
echo " ./scripts/copy-all.sh "
|
||||
echo "to copy to loadups library"
|
||||
echo "**** DONE ****"
|
||||
|
||||
|
||||
|
||||
@@ -7,14 +7,14 @@ if [ ! -f run-medley ] ; then
|
||||
exit 1
|
||||
fi
|
||||
|
||||
touch tmp/loadup.timestamp
|
||||
touch tmp/db.timestamp
|
||||
|
||||
scr="-sc 1024x768 -g 1042x790"
|
||||
|
||||
echo '" (IL:MEDLEY-INIT-VARS)(IL:FILESLOAD MEDLEY-UTILS)(IL:MAKE-FULLER-DB)(IL:LOGOUT T)"' > tmp/loadup-db.cm
|
||||
./run-medley $scr -loadup "$MEDLEYDIR"/tmp/loadup-db.cm tmp/full.sysout
|
||||
echo '" (IL:MEDLEY-INIT-VARS)(IL:FILESLOAD MEDLEY-UTILS)(IL:MAKE-FULLER-DB)(IL:LOGOUT T)"' > tmp/db.cm
|
||||
./run-medley $scr -loadup "$MEDLEYDIR"/tmp/db.cm -full
|
||||
|
||||
if [ tmp/fuller.database -nt tmp/loadup.timestamp ]; then
|
||||
if [ tmp/fuller.database -nt tmp/db.timestamp ]; then
|
||||
|
||||
echo ---- made ----
|
||||
ls -l tmp/fuller*
|
||||
|
||||
@@ -2,6 +2,7 @@
|
||||
|
||||
# Usage 'lsee file'
|
||||
# translates CR as newline
|
||||
# translate _ and ^
|
||||
# changes font-change control-characters ^F^x
|
||||
# to linux color escapes:
|
||||
# A regular
|
||||
@@ -9,9 +10,11 @@
|
||||
# C comment yellow
|
||||
# D big/bold red
|
||||
|
||||
export LANG=C
|
||||
export LANG=en_US.UTF-8
|
||||
tr '\r' '\n' < $1 | \
|
||||
sed -e 's//[0m/g' \
|
||||
sed -e 's/_/←/g' \
|
||||
-e 's/^/↑/g' \
|
||||
-e 's//[0m/g' \
|
||||
-e 's//[31m/g'\
|
||||
-e 's//[1m/g' \
|
||||
-e 's//[33m/g'\
|
||||
|
||||
117
sources/APUTDQ
117
sources/APUTDQ
@@ -1,13 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "25-Aug-2021 13:12:07" {DSK}<home>larry>medley>sources>APUTDQ.;2 11185
|
||||
|
||||
changes to%: (FNS ENDLOADUP)
|
||||
(FILECREATED "25-Oct-2022 11:44:17" {DSK}<home>larry>ilisp>medley>sources>APUTDQ.;3 14079
|
||||
|
||||
previous date%: "25-Aug-2021 12:11:36" {DSK}<home>larry>medley>sources>APUTDQ.;1)
|
||||
:CHANGES-TO (FNS ENDLOADUP)
|
||||
|
||||
:PREVIOUS-DATE "25-Oct-2022 11:07:06" {DSK}<home>larry>ilisp>medley>sources>APUTDQ.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1981-1988, 1990, 2021 by Venue & Xerox Corporation.
|
||||
Copyright (c) 1981-1988, 1990, 2021-2022 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT APUTDQCOMS)
|
||||
@@ -139,33 +140,26 @@ Copyright (c) 1981-1988, 1990, 2021 by Venue & Xerox Corporation.
|
||||
(SMASHFILECOMS X])
|
||||
|
||||
(ENDLOADUP
|
||||
[LAMBDA NIL (* ; "Edited 25-Aug-2021 13:07 by larry")
|
||||
[LAMBDA NIL
|
||||
(DECLARE (GLOBALVARS USERRECLST SYSTEMINITVARS MEDLEY-INIT-VARS))
|
||||
(* ; "Edited 25-Oct-2022 11:43 by lmm")
|
||||
|
||||
(* ;; "set up for NONET configuration; sites with ethernet can load in init from other places")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "All records existing at this point in time have been loaded as part of the system.")
|
||||
|
||||
(DECLARE (GLOBALVARS USERRECLST SYSTEMINITVARS MEDLEY-INIT-VARS AFTERSYSOUTFORMS))
|
||||
(FOR R IN USERRECLST DO (RECORDPRIORITY R 'SYSTEM))
|
||||
|
||||
(* ;; "reset variables to nil")
|
||||
|
||||
(MEDLEY-INIT-VARS T)
|
||||
(* ;; " MEDLEY-INIT-VARS is done by aroundexitfn")
|
||||
|
||||
[FOR X IN SYSTEMINITVARS WHEN (NOT (ASSOC (CAR X)
|
||||
MEDLEY-INIT-VARS))
|
||||
MEDLEY-INIT-VARS))
|
||||
DO (SETTOPVAL (CAR X)
|
||||
(COPY (CDR X]
|
||||
|
||||
(* ;; " make sure these are done first")
|
||||
|
||||
(SETQ AFTERSYSOUTFORMS (CONS '(MEDLEY-INIT-VARS)
|
||||
(REMOVE '(MEDLEY-INIT-VARS)
|
||||
AFTERSYSOUTFORMS)))
|
||||
(SETQ AFTERMAKESYSFORMS (CONS '(MEDLEY-INIT-VARS)
|
||||
(REMOVE '(MEDLEY-INIT-VARS)
|
||||
AFTERMAKESYSFORMS)))
|
||||
(COPY (CDR X]
|
||||
(FOR FILE IN (OPENP) DO (PRINTOUT T (CLOSEF FILE)
|
||||
" closed" T))
|
||||
" closed" T))
|
||||
|
||||
(* ;; "get rid of files loaded")
|
||||
|
||||
@@ -261,12 +255,87 @@ Copyright (c) 1981-1988, 1990, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PRETTYCOMPRINT APUTDQCOMS)
|
||||
|
||||
(RPAQQ APUTDQCOMS
|
||||
[
|
||||
(* ;; " this file contains some dummy definitions of functions whose real implementation is on other files")
|
||||
|
||||
(DECLARE%: EVAL@LOAD DONTCOPY (P (PRIN1 "Warning: APUTDQ contains dummy definitions of " T)
|
||||
(PRIN1
|
||||
"FAULTEVAL FAULTAPPLY ERRORX SET-DOCUMENTATION SMASHFILECOMS"
|
||||
T)
|
||||
(PRIN1 "Be careful not to confuse with the real definitions"
|
||||
T)
|
||||
(TERPRI T)))
|
||||
(FNS GREETFILENAME FAULTEVAL FAULTAPPLY ERRORX SET-DOCUMENTATION)
|
||||
(FNS SMASHFILECOMS SMASHFILECOMSLST)
|
||||
(INITVARS (DEFAULTREGISTRY)
|
||||
(USERGREETFILES)
|
||||
(LOGINHOST/DIR '{DSK}))
|
||||
(FNS LOADUP ENDLOADUP)
|
||||
(ALISTS (SYSTEMINITVARS \CONNECTED.DIRECTORY DWIMFLG ADDSPELLFLG FILEPKGFLG BUILDMAPFLG
|
||||
UPDATEMAPFLG DEFAULTREGISTRY DEFAULTPRINTINGHOST DIRECTORIES USERGREETFILES
|
||||
NETWORKOSTYPES CH.NET.HINT CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION
|
||||
ADVISEDFNS LISPUSERSDIRECTORIES DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS
|
||||
INTERPRESSFONTDIRECTORIES))
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(* ;; "many of these are obsolete and can be removed, but it is unclear which ones")
|
||||
|
||||
(P (DUMMYDEF (ADDSTATS *)
|
||||
(LISPXWATCH NILL)
|
||||
(CLBUFS NILL)
|
||||
(FINDFILE INFILEP)
|
||||
(FILEMAP *)
|
||||
(VIRGINFN GETD))
|
||||
(DUMMYDEF (* QUOTE)
|
||||
(GETP GETPROP)
|
||||
(DECLARE QUOTE)
|
||||
(FRPLNODE2 RPLNODE2)
|
||||
(DISPLAYTERMP TRUE)
|
||||
(FRPLACA RPLACA)
|
||||
(FRPLACD RPLACD)
|
||||
(MISSPELLED? NILL)
|
||||
(UNDOSAVE NILL)
|
||||
(SETLINELENGTH ZERO)
|
||||
(DOBE NILL)
|
||||
(RELINK NILL)
|
||||
(PUT PUTPROP)
|
||||
(/PUT PUTPROP)))
|
||||
(ADDVARS (SYSFILES)
|
||||
(LISPXHISTORY)
|
||||
(LINKEDFNS))
|
||||
(VARS (CLEARSTKLST T)
|
||||
(SYSHASHARRAY (HASHARRAY 50))
|
||||
(DISPLAYTERMFLG T)
|
||||
(%#UNDOSAVES)
|
||||
(NLAMA)
|
||||
(NLAML)
|
||||
(LAMS)
|
||||
(TTYLINELENGTH 82)
|
||||
(COMPILE.EXT 'LCOM)
|
||||
(FASL.EXT 'DFASL)
|
||||
(*COMPILED-EXTENSIONS* '(DFASL LCOM))
|
||||
(SYSOUT.EXT 'SYSOUT]
|
||||
(LOCALVARS . T)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS APUTDQ COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
2021))
|
||||
2021 2022))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3963 6171 (GREETFILENAME 3973 . 5846) (FAULTEVAL 5848 . 5920) (FAULTAPPLY 5922 . 6008)
|
||||
(ERRORX 6010 . 6076) (SET-DOCUMENTATION 6078 . 6169)) (6172 7192 (SMASHFILECOMS 6182 . 6524) (
|
||||
SMASHFILECOMSLST 6526 . 7190)) (7286 9211 (LOADUP 7296 . 7719) (ENDLOADUP 7721 . 9209)))))
|
||||
(FILEMAP (NIL (3978 6186 (GREETFILENAME 3988 . 5861) (FAULTEVAL 5863 . 5935) (FAULTAPPLY 5937 . 6023)
|
||||
(ERRORX 6025 . 6091) (SET-DOCUMENTATION 6093 . 6184)) (6187 7207 (SMASHFILECOMS 6197 . 6539) (
|
||||
SMASHFILECOMSLST 6541 . 7205)) (7301 8744 (LOADUP 7311 . 7734) (ENDLOADUP 7736 . 8742)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")
|
||||
(IL:FILECREATED "16-May-90 12:12:42" IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;2| 38319
|
||||
(DEFINE-FILE-INFO PACKAGE "SYSTEM" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:BREAK-AND-TRACECOMS)
|
||||
(IL:FILECREATED "12-Sep-2022 21:16:02"
|
||||
IL:|{DSK}<users>kaplan>local>medley3.5>working-medley>sources>BREAK-AND-TRACE.;2| 37228
|
||||
|
||||
IL:|previous| IL:|date:| "12-Jul-88 18:49:08"
|
||||
IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
:PREVIOUS-DATE "16-May-90 12:12:42"
|
||||
IL:|{DSK}<users>kaplan>local>medley3.5>working-medley>sources>BREAK-AND-TRACE.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988, 1990 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:BREAK-AND-TRACECOMS)
|
||||
|
||||
@@ -63,14 +63,14 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
)
|
||||
|
||||
(DEFVAR IL:TRACEREGION (IL:|create| IL:REGION
|
||||
IL:LEFT IL:_ 8
|
||||
IL:BOTTOM IL:_ 3
|
||||
IL:WIDTH IL:_ 547
|
||||
IL:HEIGHT IL:_ 310))
|
||||
IL:LEFT IL:_ 8
|
||||
IL:BOTTOM IL:_ 3
|
||||
IL:WIDTH IL:_ 547
|
||||
IL:HEIGHT IL:_ 310))
|
||||
|
||||
(DEFUN XCL:CREATE-TRACE-WINDOW (&KEY (XCL::REGION IL:TRACEREGION)
|
||||
(XCL::OPEN? NIL)
|
||||
(XCL::TITLE "*Trace-Output*"))
|
||||
(XCL::OPEN? NIL)
|
||||
(XCL::TITLE "*Trace-Output*"))
|
||||
|
||||
(IL:* IL:|;;;| "Create and return a window suitable for use as the value of *TRACE-OUTPUT*.")
|
||||
|
||||
@@ -92,8 +92,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
ARG-LIST)
|
||||
,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA))
|
||||
`((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST)
|
||||
(LIST ARG-LIST)
|
||||
ARG-LIST)))))
|
||||
(LIST ARG-LIST)
|
||||
ARG-LIST)))))
|
||||
(IL:\\CALLME '(:TRACED ,(IF (NULL IN-FN)
|
||||
TRACED-FN
|
||||
`(,TRACED-FN :IN ,IN-FN))))
|
||||
@@ -103,18 +103,18 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$)
|
||||
(IL:FONTCHANGEFLG $IMAGE-STREAM?$))
|
||||
(DECLARE (SPECIAL IL:FONTCHANGEFLG))
|
||||
,@(CONSTRUCT-ENTRY-PRINTING-CODE TRACED-FN IN-FN LAMBDA-CAR ARG-LIST))
|
||||
,@(CONSTRUCT-ENTRY-PRINTING-CODE TRACED-FN IN-FN LAMBDA-CAR ARG-LIST))
|
||||
(LET (($TRACED-FN-VALUES$ (MULTIPLE-VALUE-LIST (LET ((XCL:*TRACE-DEPTH*
|
||||
(1+ XCL:*TRACE-DEPTH*)))
|
||||
,CALLING-FORM))))
|
||||
(LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$)
|
||||
(IL:FONTCHANGEFLG $IMAGE-STREAM?$))
|
||||
(DECLARE (SPECIAL IL:FONTCHANGEFLG))
|
||||
(PRINT-TRACE-EXIT-INFO ',TRACED-FN ',IN-FN $TRACED-FN-VALUES$))
|
||||
(PRINT-TRACE-EXIT-INFO ',TRACED-FN ',IN-FN $TRACED-FN-VALUES$))
|
||||
(VALUES-LIST $TRACED-FN-VALUES$))))))
|
||||
|
||||
(DEFUN CONSTRUCT-ENTRY-PRINTING-CODE (TRACED-FN IN-FN LAMBDA-CAR ARG-LIST)
|
||||
`((PRINT-TRACE-ENTRY-INFO ',TRACED-FN ',IN-FN)
|
||||
`((PRINT-TRACE-ENTRY-INFO ',TRACED-FN ',IN-FN)
|
||||
(LET
|
||||
((*PRINT-LEVEL* XCL:*TRACE-LEVEL*)
|
||||
(*PRINT-LENGTH* XCL:*TRACE-LENGTH*))
|
||||
@@ -124,46 +124,45 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
IL:THEN
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Interlisp spread function. The ARG-LIST is, in fact, a list of argument names.")
|
||||
"Interlisp spread function. The ARG-LIST is, in fact, a list of argument names.")
|
||||
|
||||
`((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4))))
|
||||
,@(IL:FOR VAR IL:IN ARG-LIST
|
||||
IL:COLLECT `(PRINT-TRACED-ARGUMENT ',VAR ,VAR $$INDENT$$))))
|
||||
IL:COLLECT `(PRINT-TRACED-ARGUMENT ',VAR ,VAR $$INDENT$$))))
|
||||
IL:ELSEIF (EQ LAMBDA-CAR 'IL:LAMBDA)
|
||||
IL:THEN
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Interlisp Lambda no-spread function. Print out at most *TRACE-LENGTH* arguments.")
|
||||
"Interlisp Lambda no-spread function. Print out at most *TRACE-LENGTH* arguments.")
|
||||
|
||||
`((IL:BIND ($$INDENT$$ IL:_ (+ 10 (* XCL:*TRACE-DEPTH* 4))) IL:FOR
|
||||
|
||||
`((IL:BIND ($$INDENT$$ IL:_ (+ 10 (* XCL:*TRACE-DEPTH* 4))) IL:FOR
|
||||
$ARG-COUNTER$
|
||||
IL:FROM 1 IL:TO (IF (NULL XCL:*TRACE-LENGTH*)
|
||||
,ARG-LIST
|
||||
(MIN XCL:*TRACE-LENGTH* ,ARG-LIST))
|
||||
IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ (IL:ARG ,ARG-LIST
|
||||
$ARG-COUNTER$)
|
||||
$$INDENT$$)))
|
||||
,ARG-LIST
|
||||
(MIN XCL:*TRACE-LENGTH* ,ARG-LIST))
|
||||
IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ (IL:ARG ,ARG-LIST
|
||||
$ARG-COUNTER$)
|
||||
$$INDENT$$)))
|
||||
IL:ELSE
|
||||
|
||||
(IL:* IL:|;;| "Interlisp NLambda no-spread function. Print out at most *TRACE-LENGTH* arguments. Also, be careful to check that the argument list is really a list.")
|
||||
|
||||
`((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4))))
|
||||
(IF (LISTP ,ARG-LIST)
|
||||
(IL:FOR $ARGUMENT$ IL:IN ,ARG-LIST IL:AS $ARG-COUNTER$
|
||||
IL:FROM 1 IL:WHILE (OR (NULL XCL:*TRACE-LENGTH*)
|
||||
(<= $ARG-COUNTER$
|
||||
XCL:*TRACE-LENGTH*))
|
||||
IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ $ARGUMENT$
|
||||
$$INDENT$$))
|
||||
(PRINT-TRACED-ARGUMENT ',ARG-LIST ,ARG-LIST $$INDENT$$))))))
|
||||
(IL:FOR $ARGUMENT$ IL:IN ,ARG-LIST IL:AS $ARG-COUNTER$ IL:FROM
|
||||
1
|
||||
IL:WHILE (OR (NULL XCL:*TRACE-LENGTH*)
|
||||
(<= $ARG-COUNTER$ XCL:*TRACE-LENGTH*))
|
||||
IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ $ARGUMENT$ $$INDENT$$
|
||||
))
|
||||
(PRINT-TRACED-ARGUMENT ',ARG-LIST ,ARG-LIST $$INDENT$$))))))
|
||||
((LAMBDA)
|
||||
|
||||
(IL:* IL:|;;| "A Common Lisp function.")
|
||||
|
||||
(MULTIPLE-VALUE-BIND (REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS)
|
||||
(PARSE-CL-ARGLIST ARG-LIST)
|
||||
`((PRINT-TRACED-CL-ARGLIST XCL:ARGLIST ',REQUIRED ',OPTIONAL
|
||||
`((PRINT-TRACED-CL-ARGLIST XCL:ARGLIST ',REQUIRED ',OPTIONAL
|
||||
',REST
|
||||
',KEY
|
||||
,KEY-APPEARED?
|
||||
@@ -203,8 +202,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(PRINC " =>")
|
||||
(TERPRI)
|
||||
(IL:FOR VALUE IL:IN FN-VALUES IL:DO (IL:SPACES (+ 10 (* XCL:*TRACE-DEPTH* 4)))
|
||||
(PRIN1 VALUE)
|
||||
(TERPRI)))
|
||||
(PRIN1 VALUE)
|
||||
(TERPRI)))
|
||||
|
||||
(DEFUN PRINT-TRACED-ARGUMENT (NAME VALUE INDENT &OPTIONAL PRIN1-THE-NAME?)
|
||||
(IL:SPACES INDENT)
|
||||
@@ -218,52 +217,49 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(TERPRI))
|
||||
|
||||
(DEFUN PRINT-TRACED-CL-ARGLIST (ARGS REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS
|
||||
SMALL-INDENT VERBOSE?)
|
||||
SMALL-INDENT VERBOSE?)
|
||||
(DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
|
||||
(LET* ((INDENT (+ SMALL-INDENT 2)))
|
||||
(WHEN REQUIRED
|
||||
(IL:FOR VAR IL:IN REQUIRED IL:DO (COND
|
||||
((NULL ARGS)
|
||||
(IL:SPACES INDENT)
|
||||
(PRINC VAR)
|
||||
(IL:CHANGEFONT IL:BOLDFONT)
|
||||
(PRINC " ** NOT SUPPLIED **")
|
||||
(IL:CHANGEFONT IL:DEFAULTFONT)
|
||||
(TERPRI))
|
||||
(T (PRINT-TRACED-ARGUMENT VAR
|
||||
(POP ARGS)
|
||||
INDENT)))))
|
||||
((NULL ARGS)
|
||||
(IL:SPACES INDENT)
|
||||
(PRINC VAR)
|
||||
(IL:CHANGEFONT IL:BOLDFONT)
|
||||
(PRINC " ** NOT SUPPLIED **")
|
||||
(IL:CHANGEFONT IL:DEFAULTFONT)
|
||||
(TERPRI))
|
||||
(T (PRINT-TRACED-ARGUMENT VAR (POP ARGS)
|
||||
INDENT)))))
|
||||
(WHEN OPTIONAL
|
||||
(WHEN VERBOSE?
|
||||
(IL:SPACES SMALL-INDENT)
|
||||
(PRINC '&OPTIONAL)
|
||||
(TERPRI))
|
||||
(IL:FOR VAR IL:IN OPTIONAL IL:DO (IF (NULL ARGS)
|
||||
(WHEN VERBOSE?
|
||||
(IL:SPACES INDENT)
|
||||
(PRINC VAR)
|
||||
(PRINC " not supplied")
|
||||
(TERPRI))
|
||||
(PRINT-TRACED-ARGUMENT VAR (POP ARGS)
|
||||
INDENT))))
|
||||
(WHEN VERBOSE?
|
||||
(IL:SPACES INDENT)
|
||||
(PRINC VAR)
|
||||
(PRINC " not supplied")
|
||||
(TERPRI))
|
||||
(PRINT-TRACED-ARGUMENT VAR (POP ARGS)
|
||||
INDENT))))
|
||||
(WHEN REST
|
||||
(WHEN VERBOSE?
|
||||
(IL:SPACES SMALL-INDENT)
|
||||
(PRINC '&REST)
|
||||
(TERPRI))
|
||||
(PRINT-TRACED-ARGUMENT REST ARGS INDENT))
|
||||
(PRINT-TRACED-ARGUMENT REST ARGS INDENT))
|
||||
(WHEN KEY
|
||||
(WHEN VERBOSE?
|
||||
(IL:SPACES SMALL-INDENT)
|
||||
(PRINC '&KEY)
|
||||
(TERPRI))
|
||||
(IL:FOR VAR IL:IN KEY IL:DO (IL:FOR TAIL IL:ON ARGS IL:BY CDDR
|
||||
IL:DO (WHEN (EQ VAR (CAR TAIL))
|
||||
(PRINT-TRACED-ARGUMENT
|
||||
VAR
|
||||
(CADR TAIL)
|
||||
INDENT T)
|
||||
(RETURN)))))
|
||||
IL:DO (WHEN (EQ VAR (CAR TAIL))
|
||||
(PRINT-TRACED-ARGUMENT VAR (CADR TAIL)
|
||||
INDENT T)
|
||||
(RETURN)))))
|
||||
(WHEN KEY-APPEARED?
|
||||
(LET (TEMP)
|
||||
(COND
|
||||
@@ -278,8 +274,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(TERPRI))
|
||||
((SETQ TEMP (IL:FIND KEYWORD IL:IN ARGS IL:BY (CDDR KEYWORD)
|
||||
IL:SUCHTHAT (IF ALLOW-OTHER-KEYS
|
||||
(NOT (KEYWORDP KEYWORD))
|
||||
(NOT (MEMBER KEYWORD KEY :TEST 'EQ)))))
|
||||
(NOT (KEYWORDP KEYWORD))
|
||||
(NOT (MEMBER KEYWORD KEY :TEST 'EQ)))))
|
||||
(IL:SPACES SMALL-INDENT)
|
||||
(IL:CHANGEFONT IL:BOLDFONT)
|
||||
(PRINC "** Illegal &KEY argument: **")
|
||||
@@ -322,7 +318,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
|
||||
)
|
||||
|
||||
(DEFVAR *TRACE-OUTPUT* (XCL:CREATE-TRACE-WINDOW))
|
||||
(DEFVAR *TRACE-OUTPUT* (XCL:CREATE-TRACE-WINDOW))
|
||||
(IL:DEFINEQ
|
||||
|
||||
(trace
|
||||
@@ -359,21 +355,19 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
)
|
||||
|
||||
(DEFUN XCL:TRACE-FUNCTION (XCL::FN-TO-TRACE &KEY ((:IN XCL::IN-FN))
|
||||
XCL::REBREAK?)
|
||||
XCL::REBREAK?)
|
||||
(COND
|
||||
((CONSP XCL::FN-TO-TRACE)
|
||||
(IL:FOR XCL::FN IL:IN XCL::FN-TO-TRACE IL:JOIN (XCL:TRACE-FUNCTION XCL::FN :IN
|
||||
XCL::IN-FN)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::FN-TO-TRACE IL:JOIN (XCL:TRACE-FUNCTION XCL::FN :IN XCL::IN-FN)))
|
||||
((CONSP XCL::IN-FN)
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:TRACE-FUNCTION XCL::FN-TO-TRACE :IN
|
||||
XCL::FN)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:TRACE-FUNCTION XCL::FN-TO-TRACE :IN XCL::FN)))
|
||||
((NULL (IL:GETD XCL::FN-TO-TRACE))
|
||||
(ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-TRACE)
|
||||
NIL)
|
||||
((IL:UNSAFE.TO.MODIFY XCL::FN-TO-TRACE "trace")
|
||||
(FORMAT *ERROR-OUTPUT* "~S not traced.~%" XCL::FN-TO-TRACE)
|
||||
NIL)
|
||||
(T (XCL:UNBREAK-FUNCTION XCL::FN-TO-TRACE :IN XCL::IN-FN :NO-ERROR T)
|
||||
(T (XCL:UNBREAK-FUNCTION XCL::FN-TO-TRACE :IN XCL::IN-FN :NO-ERROR T)
|
||||
(UNLESS XCL::REBREAK? (IL:* IL:\; "Save the breaking information for REBREAK, but don't save it if we're being called from REBREAK itself.")
|
||||
(SETF (GETHASH (IF (NULL XCL::IN-FN)
|
||||
XCL::FN-TO-TRACE
|
||||
@@ -385,7 +379,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(MAKE-SYMBOL (FORMAT NIL "Original ~A" XCL::FN-TO-TRACE)))))
|
||||
(IL:PUTD XCL::ORIGINAL (IL:GETD XCL::FN-TO-TRACE)
|
||||
T)
|
||||
(IL:PUTD XCL::FN-TO-TRACE (COMPILE NIL (CREATE-TRACED-DEFINITION XCL::FN-TO-TRACE
|
||||
(IL:PUTD XCL::FN-TO-TRACE (COMPILE NIL (CREATE-TRACED-DEFINITION XCL::FN-TO-TRACE
|
||||
NIL XCL::ORIGINAL))
|
||||
T)
|
||||
(SETF (GET XCL::FN-TO-TRACE 'IL:BROKEN)
|
||||
@@ -397,7 +391,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(LET ((XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::FN-TO-TRACE XCL::IN-FN)))
|
||||
(IF (NOT (HAS-CALLS XCL::IN-FN XCL::FN-TO-TRACE))
|
||||
(ERROR "~S is not called from ~S." XCL::FN-TO-TRACE XCL::IN-FN))
|
||||
(COMPILE XCL::MIDDLE-MAN (CREATE-TRACED-DEFINITION XCL::FN-TO-TRACE XCL::IN-FN
|
||||
(COMPILE XCL::MIDDLE-MAN (CREATE-TRACED-DEFINITION XCL::FN-TO-TRACE XCL::IN-FN
|
||||
XCL::FN-TO-TRACE))
|
||||
(CHANGE-CALLS XCL::FN-TO-TRACE XCL::MIDDLE-MAN XCL::IN-FN
|
||||
'UNBREAK-FROM-RESTORE-CALLS)
|
||||
@@ -414,19 +408,19 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
|
||||
|
||||
(DEFUN XCL:BREAK-FUNCTION (XCL::FN-TO-BREAK &KEY ((:IN XCL::IN-FN))
|
||||
((:WHEN XCL::WHEN-EXPR)
|
||||
T)
|
||||
XCL::TRACE? XCL::REBREAK?)
|
||||
((:WHEN XCL::WHEN-EXPR)
|
||||
T)
|
||||
XCL::TRACE? XCL::REBREAK?)
|
||||
(COND
|
||||
(XCL::TRACE? (XCL:TRACE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :REBREAK? XCL::REBREAK?))
|
||||
(XCL::TRACE? (XCL:TRACE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :REBREAK? XCL::REBREAK?))
|
||||
((CONSP XCL::FN-TO-BREAK)
|
||||
(IL:FOR XCL::FN IL:IN XCL::FN-TO-BREAK
|
||||
IL:JOIN (XCL:BREAK-FUNCTION XCL::FN :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK?
|
||||
XCL::REBREAK?)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::FN-TO-BREAK IL:JOIN (XCL:BREAK-FUNCTION XCL::FN :IN XCL::IN-FN
|
||||
:WHEN XCL::WHEN-EXPR :REBREAK?
|
||||
XCL::REBREAK?)))
|
||||
((CONSP XCL::IN-FN)
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN
|
||||
IL:JOIN (XCL:BREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::FN :WHEN XCL::WHEN-EXPR :REBREAK?
|
||||
XCL::REBREAK?)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:BREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::FN
|
||||
:WHEN XCL::WHEN-EXPR :REBREAK? XCL::REBREAK?))
|
||||
)
|
||||
((IL:UNSAFE.TO.MODIFY XCL::FN-TO-BREAK "break")
|
||||
(FORMAT *ERROR-OUTPUT* "~S not broken." XCL::FN-TO-BREAK)
|
||||
NIL)
|
||||
@@ -442,14 +436,14 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
#'(LAMBDA NIL (IF XCL::TRIGGERED-YET?
|
||||
NIL
|
||||
(SETQ XCL::TRIGGERED-YET? T)))))))
|
||||
(XCL:UNBREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
|
||||
(XCL:UNBREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
|
||||
(IF (NULL XCL::IN-FN)
|
||||
(LET* ((XCL::ORIGINAL-DEF (OR (IL:GETD XCL::FN-TO-BREAK)
|
||||
(ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-BREAK)))
|
||||
(XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE))
|
||||
(MAKE-SYMBOL (FORMAT NIL "Original ~A" XCL::FN-TO-BREAK)))))
|
||||
(IL:PUTD XCL::ORIGINAL XCL::ORIGINAL-DEF T)
|
||||
(IL:PUTD XCL::FN-TO-BREAK (COMPILE NIL (CREATE-BROKEN-DEFINITION XCL::FN-TO-BREAK
|
||||
(IL:PUTD XCL::FN-TO-BREAK (COMPILE NIL (CREATE-BROKEN-DEFINITION XCL::FN-TO-BREAK
|
||||
XCL::FN-TO-BREAK XCL::ORIGINAL
|
||||
XCL::WHEN-EXPR XCL::FN-TO-BREAK))
|
||||
T)
|
||||
@@ -462,7 +456,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(IF (NOT (HAS-CALLS XCL::IN-FN XCL::FN-TO-BREAK))
|
||||
(ERROR "~S is not called from ~S." XCL::FN-TO-BREAK XCL::IN-FN))
|
||||
(XCL:UNADVISE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
|
||||
(COMPILE XCL::MIDDLE-MAN (CREATE-BROKEN-DEFINITION XCL::FN-TO-BREAK XCL::MIDDLE-MAN
|
||||
(COMPILE XCL::MIDDLE-MAN (CREATE-BROKEN-DEFINITION XCL::FN-TO-BREAK XCL::MIDDLE-MAN
|
||||
XCL::FN-TO-BREAK XCL::WHEN-EXPR
|
||||
`(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN)))
|
||||
(CHANGE-CALLS XCL::FN-TO-BREAK XCL::MIDDLE-MAN XCL::IN-FN
|
||||
@@ -474,14 +468,12 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
(LIST `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN)))))))
|
||||
|
||||
(DEFUN XCL:UNBREAK-FUNCTION (XCL::BROKEN-FN &KEY ((:IN XCL::IN-FN))
|
||||
XCL::NO-ERROR)
|
||||
XCL::NO-ERROR)
|
||||
(COND
|
||||
((CONSP XCL::BROKEN-FN)
|
||||
(IL:FOR XCL::FN IL:IN XCL::BROKEN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::FN :IN
|
||||
XCL::IN-FN)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::BROKEN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::FN :IN XCL::IN-FN)))
|
||||
((CONSP XCL::IN-FN)
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::BROKEN-FN :IN
|
||||
XCL::FN)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::BROKEN-FN :IN XCL::FN)))
|
||||
((NULL XCL::IN-FN)
|
||||
(LET ((XCL::ORIGINAL (GET XCL::BROKEN-FN 'IL:BROKEN)))
|
||||
(COND
|
||||
@@ -509,17 +501,17 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
XCL::BROKEN-FN XCL::IN-FN))
|
||||
NIL)
|
||||
(T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::BROKEN-FN XCL::IN-FN)
|
||||
(FINISH-UNBREAKING XCL::BROKEN-FN XCL::IN-FN XCL::MIDDLE-MAN XCL::ENTRY)
|
||||
(FINISH-UNBREAKING XCL::BROKEN-FN XCL::IN-FN XCL::MIDDLE-MAN XCL::ENTRY)
|
||||
(LIST `(,XCL::BROKEN-FN :IN ,XCL::IN-FN))))))))
|
||||
|
||||
(DEFUN XCL:REBREAK-FUNCTION (XCL::FN-TO-REBREAK &KEY ((:IN XCL::IN-FN)))
|
||||
(COND
|
||||
((CONSP XCL::FN-TO-REBREAK)
|
||||
(IL:FOR XCL::FN IL:IN XCL::FN-TO-REBREAK IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN :IN
|
||||
XCL::IN-FN)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::FN-TO-REBREAK IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN :IN XCL::IN-FN)
|
||||
))
|
||||
((CONSP XCL::IN-FN)
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN-TO-REBREAK
|
||||
:IN XCL::FN)))
|
||||
(IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN-TO-REBREAK :IN XCL::FN)
|
||||
))
|
||||
(T (LET* ((XCL::NAME (IF (NULL XCL::IN-FN)
|
||||
XCL::FN-TO-REBREAK
|
||||
`(,XCL::FN-TO-REBREAK :IN ,XCL::IN-FN)))
|
||||
@@ -530,8 +522,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
NIL)
|
||||
(T (APPLY 'XCL:BREAK-FUNCTION XCL::INFO)))))))
|
||||
|
||||
(DEFUN CREATE-BROKEN-DEFINITION (WRAPPED-FN-NAME BROKEN-FN-NAME FN-TO-CALL WHEN-EXPR
|
||||
BREAKPOINT-NAME)
|
||||
(DEFUN CREATE-BROKEN-DEFINITION (WRAPPED-FN-NAME BROKEN-FN-NAME FN-TO-CALL WHEN-EXPR BREAKPOINT-NAME)
|
||||
|
||||
(IL:* IL:|;;;|
|
||||
"WRAPPED-FN-NAME must be the symbol naming the function that will break when it is called.")
|
||||
@@ -553,8 +544,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
ARG-LIST)
|
||||
,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA))
|
||||
`((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST)
|
||||
(LIST ARG-LIST)
|
||||
ARG-LIST)))))
|
||||
(LIST ARG-LIST)
|
||||
ARG-LIST)))))
|
||||
(IL:\\CALLME '(:BROKEN ,BREAKPOINT-NAME))
|
||||
(IF ,WHEN-EXPR
|
||||
(LET (($POS$ (IL:STKNTH -1)))
|
||||
@@ -578,7 +569,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
IL:BROKENFNS)))
|
||||
(ASSERT (EQ TO (THIRD ENTRY))
|
||||
NIL "BUG: Inconsistency in SI::UNBREAK-FROM-RESTORE-CALLS")
|
||||
(FINISH-UNBREAKING FROM FN TO ENTRY)
|
||||
(FINISH-UNBREAKING FROM FN TO ENTRY)
|
||||
(FORMAT *TERMINAL-IO* "(~S :IN ~S) unbroken.~%" FROM FN)))
|
||||
|
||||
(DEFUN FINISH-UNBREAKING (BROKEN-FN IN-FN MIDDLE-MAN ENTRY)
|
||||
@@ -696,7 +687,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
)
|
||||
|
||||
(XCL:DEFINE-SPECIAL-FORM IL:BREAK1 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION
|
||||
&ENVIRONMENT IL:ENV)
|
||||
&ENVIRONMENT IL:ENV)
|
||||
(IL:IF (EVAL IL:WHEN IL:ENV)
|
||||
IL:THEN (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T))
|
||||
(LET ((IL:POS (IL:STKNTH 0 IL:FN)))
|
||||
@@ -708,25 +699,23 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
IL:ELSE (EVAL IL:EXP IL:ENV)))
|
||||
|
||||
(XCL:DEFOPTIMIZER IL:BREAK1 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION)
|
||||
(WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T
|
||||
))
|
||||
`(FLET
|
||||
(($BRKEXP$ NIL ,IL:EXP))
|
||||
(IL:IF ,IL:WHEN
|
||||
IL:THEN
|
||||
(LET
|
||||
(($POS$ (IL:STKNTH 0 ',IL:FN)))
|
||||
(UNWIND-PROTECT
|
||||
(XCL:DEBUGGER
|
||||
:FORM
|
||||
`(FUNCALL ',#'$BRKEXP$)
|
||||
:ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION
|
||||
,(OR XCL:CONDITION
|
||||
`(IL:LOADTIMECONSTANT (XCL:MAKE-CONDITION
|
||||
'BREAKPOINT :FUNCTION
|
||||
',IL:FN))))
|
||||
(IL:RELSTK $POS$)))
|
||||
IL:ELSE ($BRKEXP$))))
|
||||
(WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T))
|
||||
`(FLET
|
||||
(($BRKEXP$ NIL ,IL:EXP))
|
||||
(IL:IF ,IL:WHEN
|
||||
IL:THEN
|
||||
(LET
|
||||
(($POS$ (IL:STKNTH 0 ',IL:FN)))
|
||||
(UNWIND-PROTECT
|
||||
(XCL:DEBUGGER
|
||||
:FORM
|
||||
`(FUNCALL ',#'$BRKEXP$)
|
||||
:ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION
|
||||
,(OR XCL:CONDITION `(IL:LOADTIMECONSTANT
|
||||
(XCL:MAKE-CONDITION 'BREAKPOINT
|
||||
:FUNCTION ',IL:FN))))
|
||||
(IL:RELSTK $POS$)))
|
||||
IL:ELSE ($BRKEXP$))))
|
||||
|
||||
|
||||
|
||||
@@ -746,7 +735,14 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>BREAK-AND-TRACE.;1|)
|
||||
)
|
||||
(IL:PUTPROPS IL:BREAK-AND-TRACE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (15387 17225 (TRACE 15400 . 15987) (UNTRACE 15989 . 17223)) (30814 34614 (IL:BREAK
|
||||
30827 . 31413) (IL:BREAK0 31415 . 32227) (IL:REBREAK 32229 . 33091) (XCL:UNBREAK 33093 . 34284) (
|
||||
IL:UNBREAK0 34286 . 34612)) (34615 35663 (IL:BREAK1 34628 . 35661)))))
|
||||
(IL:FILEMAP (NIL (2635 3370 (XCL:CREATE-TRACE-WINDOW 2635 . 3370)) (3372 5298 (
|
||||
CREATE-TRACED-DEFINITION 3372 . 5298)) (5300 8596 (CONSTRUCT-ENTRY-PRINTING-CODE 5300 . 8596)) (8598
|
||||
9058 (PRINT-TRACE-ENTRY-INFO 8598 . 9058)) (9060 9726 (PRINT-TRACE-EXIT-INFO 9060 . 9726)) (9728 9994
|
||||
(PRINT-TRACED-ARGUMENT 9728 . 9994)) (9996 14052 (PRINT-TRACED-CL-ARGLIST 9996 . 14052)) (14764 16602
|
||||
(TRACE 14777 . 15364) (UNTRACE 15366 . 16600)) (16604 19681 (XCL:TRACE-FUNCTION 16604 . 19681)) (19731
|
||||
23843 (XCL:BREAK-FUNCTION 19731 . 23843)) (23845 25958 (XCL:UNBREAK-FUNCTION 23845 . 25958)) (25960
|
||||
26848 (XCL:REBREAK-FUNCTION 25960 . 26848)) (26850 28538 (CREATE-BROKEN-DEFINITION 26850 . 28538)) (
|
||||
28540 29405 (UNBREAK-FROM-RESTORE-CALLS 28540 . 29405)) (29407 29647 (FINISH-UNBREAKING 29407 . 29647)
|
||||
) (29904 33704 (IL:BREAK 29917 . 30503) (IL:BREAK0 30505 . 31317) (IL:REBREAK 31319 . 32181) (XCL:UNBREAK
|
||||
32183 . 33374) (IL:UNBREAK0 33376 . 33702)) (33705 34753 (IL:BREAK1 33718 . 34751)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
|
||||
(IL:FILECREATED " 3-Sep-93 09:49:06" IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLENVIRONMENT.;4| 7109
|
||||
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARIABLES *FEATURES*)
|
||||
(IL:FILECREATED "12-Aug-2022 12:31:32" IL:|{DSK}<home>larry>medley>sources>CMLENVIRONMENT.;2| 6958
|
||||
|
||||
IL:|previous| IL:|date:| " 8-Nov-90 17:26:56"
|
||||
IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLENVIRONMENT.;3|)
|
||||
:CHANGES-TO (IL:FUNCTIONS ROOM)
|
||||
|
||||
:PREVIOUS-DATE " 3-Sep-93 09:49:06" IL:|{DSK}<home>larry>medley>sources>CMLENVIRONMENT.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1986-1988, 1990, 1993 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:CMLENVIRONMENTCOMS)
|
||||
|
||||
@@ -22,8 +22,7 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLENVIRONMENT.;3|)
|
||||
(IL:FUNCTIONS ROOM)
|
||||
(IL:COMS
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Functions for printing the system information for Customer Support:")
|
||||
(IL:* IL:|;;| "Functions for printing the system information for Customer Support:")
|
||||
|
||||
(IL:FNS IL:PRINT-LISP-INFORMATION IL:PRINT-LOADED-FILE-INFORMATION))
|
||||
(IL:VARIABLES *FEATURES*)
|
||||
@@ -61,7 +60,7 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLENVIRONMENT.;3|)
|
||||
(DEFUN MACHINE-VERSION ()
|
||||
(IL:SELECTQ (IL:MACHINETYPE)
|
||||
(IL:MAIKO (IL:* IL:\;
|
||||
"For emulators, convert the emulator creation date from microcodeversion.")
|
||||
"For emulators, convert the emulator creation date from microcodeversion.")
|
||||
(FORMAT NIL "Emulator created: ~A, memory size: ~D"
|
||||
(IL:SUBSTRING (IL:GDATE (+ (IL:IDATE "14-OCT-87 12:00:00")
|
||||
(* 86400 (IL:MICROCODEVERSION))))
|
||||
@@ -100,23 +99,21 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLENVIRONMENT.;3|)
|
||||
(OR XCL:*LONG-SITE-NAME* XCL:*SHORT-SITE-NAME* "Unknown"))
|
||||
|
||||
(DEFUN ROOM (&OPTIONAL (TYPES NIL SP)
|
||||
(PAGE-LIMIT (IF SP
|
||||
NIL
|
||||
20))
|
||||
(IN-USE-LIMIT NIL))
|
||||
(PAGE-LIMIT (IF SP
|
||||
NIL
|
||||
20))
|
||||
(IN-USE-LIMIT NIL)) (IL:* IL:\; "Edited 12-Aug-2022 12:25 by lmm")
|
||||
|
||||
(IL:* IL:|;;| "The three args are identical to those of IL:STORAGE, except that TYPES = NIL, T or omitted is handled per silver book (small, maximal, medium, respectively).")
|
||||
|
||||
(LET* ((STORAGE-LEFT (IL:STORAGE.LEFT))
|
||||
(DATA-REMAINING (ROUND (* 100 (SECOND STORAGE-LEFT))))
|
||||
(SYMBOLS-REMAINING (ROUND (* 100 (FIFTH STORAGE-LEFT))))
|
||||
(ONE-PERCENT-VMEM (ROUND (+ IL:\\LASTVMEMFILEPAGE 50)
|
||||
100))
|
||||
(VMEM-PERCENT (- 100 (ROUND (+ (IL:VMEMSIZE)
|
||||
(ASH ONE-PERCENT-VMEM -1))
|
||||
ONE-PERCENT-VMEM))))
|
||||
(FORMAT T "Data area remaining:~25t~a%~%" DATA-REMAINING)
|
||||
(FORMAT T "Symbol area remaining:~25t~a%~%" SYMBOLS-REMAINING)
|
||||
(FORMAT T "Vmem remaining:~25t~a%~%" VMEM-PERCENT)
|
||||
(WHEN (OR TYPES PAGE-LIMIT IN-USE-LIMIT)
|
||||
(TERPRI T)
|
||||
@@ -172,6 +169,10 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLENVIRONMENT.;3|)
|
||||
(IL:PUTPROPS IL:CMLENVIRONMENT IL:FILETYPE :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:CMLENVIRONMENT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (5523 6724 (IL:PRINT-LISP-INFORMATION 5536 . 6161) (IL:PRINT-LOADED-FILE-INFORMATION
|
||||
6163 . 6722)))))
|
||||
(IL:FILEMAP (NIL (1272 1329 (LISP-IMPLEMENTATION-TYPE 1272 . 1329)) (1331 1534 (
|
||||
LISP-IMPLEMENTATION-VERSION 1331 . 1534)) (1536 2186 (MACHINE-INSTANCE 1536 . 2186)) (2188 2886 (
|
||||
MACHINE-VERSION 2188 . 2886)) (2888 2934 (SOFTWARE-TYPE 2888 . 2934)) (2936 3140 (SOFTWARE-VERSION
|
||||
2936 . 3140)) (3142 3456 (MACHINE-TYPE 3142 . 3456)) (3537 3607 (SHORT-SITE-NAME 3537 . 3607)) (3609
|
||||
3699 (LONG-SITE-NAME 3609 . 3699)) (3701 5278 (ROOM 3701 . 5278)) (5372 6573 (IL:PRINT-LISP-INFORMATION
|
||||
5385 . 6010) (IL:PRINT-LOADED-FILE-INFORMATION 6012 . 6571)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
277
sources/CMLUNDO
277
sources/CMLUNDO
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
|
||||
(IL:FILECREATED "16-May-90 14:54:01" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLUNDO.;2| 30797
|
||||
(DEFINE-FILE-INFO PACKAGE "XEROX-COMMON-LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:CMLUNDOCOMS)
|
||||
(IL:FILECREATED "18-Oct-2022 16:24:32" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;2| 31891
|
||||
|
||||
IL:|previous| IL:|date:| "29-Feb-88 19:40:15" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLUNDO.;1|
|
||||
)
|
||||
:CHANGES-TO (IL:FUNCTIONS UNDOABLY)
|
||||
|
||||
:PREVIOUS-DATE "15-Oct-2022 17:21:17" IL:|{DSK}<home>larry>ilisp>medley>sources>CMLUNDO.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1986-1988, 1990, 2022 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:CMLUNDOCOMS)
|
||||
|
||||
@@ -38,7 +38,7 @@
|
||||
(PSETF . UNDOABLY-PSETF)
|
||||
(PUSH . UNDOABLY-PUSH)
|
||||
(PUSHNEW . UNDOABLY-PUSHNEW)
|
||||
((REMF) . UNDOABLY-REMF)
|
||||
(REMF . UNDOABLY-REMF)
|
||||
(ROTATEF . UNDOABLY-ROTATEF)
|
||||
(SHIFTF . UNDOABLY-SHIFTF)
|
||||
(DECF . UNDOABLY-DECF)
|
||||
@@ -69,60 +69,75 @@
|
||||
(DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
|
||||
(APPLY FN ARGS))
|
||||
|
||||
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV)
|
||||
(WALK-FORM
|
||||
(IL:MKPROGN FORMS)
|
||||
:ENVIRONMENT ENV :WALK-FUNCTION
|
||||
#'(LAMBDA
|
||||
(X CONTEXT)
|
||||
(COND
|
||||
((NOT (CONSP X))
|
||||
X)
|
||||
((NOT (SYMBOLP (CAR X)))
|
||||
X)
|
||||
(T
|
||||
(CASE (CAR X)
|
||||
((SETQ SETQ SETF)
|
||||
(VALUES
|
||||
(IL:MKPROGN
|
||||
(WITH-COLLECTION
|
||||
(DO ((TAIL (CDR X)
|
||||
(CDDR TAIL)))
|
||||
((NULL TAIL))
|
||||
(COLLECT
|
||||
(IF (SYMBOLP (CAR TAIL))
|
||||
(IF (VARIABLE-LEXICAL-P (CAR TAIL))
|
||||
`(SETQ ,(CAR TAIL)
|
||||
,(WALK-FORM-INTERNAL (CADR TAIL)))
|
||||
(PROGN (WARN "Variable ~S presumed special in UNDOABLY.. SETQ"
|
||||
(CAR TAIL))
|
||||
`(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
|
||||
,(WALK-FORM-INTERNAL (CADR TAIL)))))
|
||||
(MULTIPLE-VALUE-BIND
|
||||
(FORMALS ACTUALS NEW-VALUE SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD (CAR TAIL))
|
||||
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
|
||||
(LIST X (WALK-FORM-INTERNAL Y)))
|
||||
FORMALS ACTUALS)
|
||||
(,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
|
||||
,(CADR TAIL)))
|
||||
,SETTER)))))))
|
||||
T))
|
||||
(STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
|
||||
T))
|
||||
(T (LET ((UNDONAME (CDR (MEMBER (CAR X)
|
||||
IL:LISPXFNS :TEST #'EQ))))
|
||||
(IF UNDONAME
|
||||
(CONS UNDONAME (CDR X))
|
||||
(IF (AND (OR (GET (CAR X)
|
||||
':DEFINER-FOR)
|
||||
(GET (CAR X)
|
||||
'IL:DEFINER-FOR))
|
||||
(NOT *IN-DEFINER*))
|
||||
(LET ((*IN-DEFINER* T))
|
||||
(VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
|
||||
T))
|
||||
X))))))))))
|
||||
(DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (IL:* IL:\; "Edited 18-Oct-2022 16:20 by lmm")
|
||||
(IL:* IL:\; "Edited 15-Oct-2022 11:47 by lmm")
|
||||
(IF (NULL IL:LISPXHIST)
|
||||
(IL:MKPROGN FORMS)
|
||||
(WALK-FORM
|
||||
(IL:MKPROGN FORMS)
|
||||
:ENVIRONMENT ENV :WALK-FUNCTION
|
||||
#'(LAMBDA
|
||||
(X CONTEXT)
|
||||
(COND
|
||||
((NOT (CONSP X))
|
||||
X)
|
||||
((NOT (SYMBOLP (CAR X)))
|
||||
X)
|
||||
(T
|
||||
(CASE (CAR X)
|
||||
((SETQ IL:SETQ SETF)
|
||||
(VALUES
|
||||
(IL:MKPROGN
|
||||
(WITH-COLLECTION
|
||||
(DO ((TAIL (CDR X)
|
||||
(CDDR TAIL)))
|
||||
((NULL TAIL))
|
||||
(COLLECT
|
||||
(IF (SYMBOLP (CAR TAIL))
|
||||
(IF (VARIABLE-LEXICAL-P (CAR TAIL))
|
||||
`(,(CAR X)
|
||||
,(CAR TAIL)
|
||||
,(WALK-FORM-INTERNAL (CADR TAIL)))
|
||||
(PROGN (COND
|
||||
((NOT (OR (VARIABLE-SPECIAL-P (CAR TAIL))
|
||||
(BOUNDP (CAR TAIL))))
|
||||
|
||||
(IL:* IL:|;;| "should possibly spelling correct? ")
|
||||
|
||||
(WHEN NIL
|
||||
|
||||
(IL:* IL:|;;| "this warning just seems uselsss; it doesn't proclaim anything or mark it as changed in FILEPKG or ...")
|
||||
|
||||
(WARN
|
||||
"Variable ~S proclaimed SPECIAL UNDOABLY.. SETQ"
|
||||
(CAR TAIL)))))
|
||||
`(UNDOABLY-SET-SYMBOL ',(CAR TAIL)
|
||||
,(WALK-FORM-INTERNAL (CADR TAIL)))))
|
||||
(MULTIPLE-VALUE-BIND
|
||||
(FORMALS ACTUALS NEW-VALUE SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD (CAR TAIL))
|
||||
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
|
||||
(LIST X (WALK-FORM-INTERNAL Y)))
|
||||
FORMALS ACTUALS)
|
||||
(,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
|
||||
,(CADR TAIL)))
|
||||
,SETTER)))))))
|
||||
T))
|
||||
(STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
|
||||
T))
|
||||
(T (LET ((UNDONAME (CDR (ASSOC (CAR X)
|
||||
IL:LISPXFNS :TEST #'EQ))))
|
||||
(IF UNDONAME
|
||||
(CONS UNDONAME (CDR X))
|
||||
(IF (AND (OR (GET (CAR X)
|
||||
':DEFINER-FOR)
|
||||
(GET (CAR X)
|
||||
'IL:DEFINER-FOR))
|
||||
(NOT *IN-DEFINER*))
|
||||
(LET ((*IN-DEFINER* T))
|
||||
(VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
|
||||
T))
|
||||
X)))))))))))
|
||||
|
||||
(DEFUN UNDOABLY-FMAKUNBOUND (SYMBOL)
|
||||
(IL:/PUTD SYMBOL NIL)
|
||||
@@ -137,11 +152,9 @@
|
||||
(IL:* IL:|;;| "Make a symbol unbound.")
|
||||
|
||||
(IL:SAVESET SYMBOL 'IL:NOBIND) (IL:* IL:\;
|
||||
" unbound symbols are set to IL:NOBIND")
|
||||
(IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH) (IL:* IL:\;
|
||||
"remove any constant entry")
|
||||
(IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL) (IL:* IL:\;
|
||||
" left by PROCLAIM special")
|
||||
" unbound symbols are set to IL:NOBIND")
|
||||
(IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH) (IL:* IL:\; "remove any constant entry")
|
||||
(IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL) (IL:* IL:\; " left by PROCLAIM special")
|
||||
(IL:/REMPROP SYMBOL 'IL:GLOBALVAR) (IL:* IL:\; "")
|
||||
SYMBOL)
|
||||
|
||||
@@ -155,19 +168,19 @@
|
||||
|
||||
(IL:* IL:|;;| "assumes variable is not lexical !")
|
||||
|
||||
`(UNDOABLY-SET-SYMBOL ',PLACE ,NEW-VALUE))
|
||||
`(UNDOABLY-SET-SYMBOL ',PLACE ,NEW-VALUE))
|
||||
(T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
|
||||
(,(CAR NEWVAL)
|
||||
,NEW-VALUE))
|
||||
,SETTER)))))
|
||||
|
||||
(DEFUN UNDOHOOK (FORM ENV &AUX (*APPLYHOOK* NIL))
|
||||
(DEFUN UNDOHOOK (FORM ENV &AUX (*APPLYHOOK* NIL)) (IL:* IL:\; "Edited 14-Oct-2022 13:54 by lmm")
|
||||
(IF (ATOM FORM)
|
||||
(EVAL FORM ENV)
|
||||
(CASE (CAR FORM)
|
||||
((SETQ SETQ SETF)
|
||||
((SETQ IL:SETQ SETF)
|
||||
(DO ((TAIL (CDR FORM))
|
||||
VALUE)
|
||||
((NULL TAIL)
|
||||
@@ -175,8 +188,8 @@
|
||||
(SETQ
|
||||
VALUE
|
||||
(IF (SYMBOLP (CAR TAIL))
|
||||
(UNDOABLY-SET-SYMBOL (POP TAIL)
|
||||
(UNDOHOOK (POP TAIL)
|
||||
(UNDOABLY-SET-SYMBOL (POP TAIL)
|
||||
(UNDOHOOK (POP TAIL)
|
||||
ENV)
|
||||
ENV)
|
||||
(EVAL
|
||||
@@ -184,13 +197,13 @@
|
||||
|
||||
(MULTIPLE-VALUE-BIND
|
||||
(FORMALS VALS NEW-VALUE SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD (POP TAIL)
|
||||
(GET-UNDOABLE-SETF-METHOD (POP TAIL)
|
||||
ENV)
|
||||
`(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
|
||||
(LIST X (LIST 'UNDOABLY Y)))
|
||||
FORMALS VALS)
|
||||
(,(CAR NEW-VALUE)
|
||||
(UNDOABLY ,(POP TAIL))))
|
||||
(UNDOABLY ,(POP TAIL))))
|
||||
,SETTER))
|
||||
ENV)))))
|
||||
(STOP-UNDOABLY
|
||||
@@ -199,7 +212,7 @@
|
||||
|
||||
(IL:\\EVAL-PROGN (CDR FORM)
|
||||
ENV))
|
||||
(T (LET ((UNDONAME (CDR (MEMBER (CAR FORM)
|
||||
(T (LET ((UNDONAME (CDR (ASSOC (CAR FORM)
|
||||
IL:LISPXFNS :TEST #'EQ))))
|
||||
(IF UNDONAME
|
||||
(EVALHOOK (CONS UNDONAME (CDR FORM))
|
||||
@@ -215,16 +228,16 @@
|
||||
((NULL ARGS)
|
||||
NIL)
|
||||
(T `(PROG1 NIL
|
||||
(UNDOABLY-SETF ,(POP ARGS)
|
||||
(UNDOABLY-SETF ,(POP ARGS)
|
||||
(PROG1 ,(POP ARGS)
|
||||
(UNDOABLY-PSETF ,@ARGS)))))))
|
||||
(UNDOABLY-PSETF ,@ARGS)))))))
|
||||
|
||||
(DEFMACRO UNDOABLY-POP (PLACE &ENVIRONMENT ENV)
|
||||
(IF (SYMBOLP PLACE)
|
||||
`(PROG1 (CAR ,PLACE)
|
||||
(UNDOABLY-SETQ ,PLACE (CDR ,PLACE)))
|
||||
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
|
||||
,(LIST (CAR NEWVAL)
|
||||
GETTER))
|
||||
@@ -240,7 +253,7 @@
|
||||
(IF (SYMBOLP PLACE)
|
||||
`(UNDOABLY-SETQ ,PLACE (CONS ,OBJ ,PLACE))
|
||||
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
|
||||
(,(CAR NEWVAL)
|
||||
(CONS ,OBJ ,GETTER)))
|
||||
@@ -250,7 +263,7 @@
|
||||
(IF (SYMBOLP PLACE)
|
||||
`(UNDOABLY-SETQ ,PLACE (ADJOIN ,OBJ ,PLACE ,@KEYS))
|
||||
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
`(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
|
||||
(,(CAR NEWVAL)
|
||||
(ADJOIN ,OBJ ,GETTER ,@KEYS)))
|
||||
@@ -258,7 +271,7 @@
|
||||
|
||||
(DEFMACRO UNDOABLY-REMF (PLACE INDICATOR &ENVIRONMENT ENV)
|
||||
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
(GET-UNDOABLE-SETF-METHOD PLACE ENV)
|
||||
(LET ((IND-TEMP (GENSYM))
|
||||
(LOCAL1 (GENSYM))
|
||||
(LOCAL2 (GENSYM)))
|
||||
@@ -303,7 +316,7 @@
|
||||
,@(REVERSE SETF-LIST)
|
||||
NIL))
|
||||
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD (CAR A)
|
||||
(GET-UNDOABLE-SETF-METHOD (CAR A)
|
||||
ENV)
|
||||
(DO ((D DUMMIES (CDR D))
|
||||
(V VALS (CDR V)))
|
||||
@@ -335,7 +348,7 @@
|
||||
,@(REVERSE SETF-LIST)
|
||||
,RESULT))
|
||||
(MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD (CAR A)
|
||||
(GET-UNDOABLE-SETF-METHOD (CAR A)
|
||||
ENV)
|
||||
(DO ((D DUMMIES (CDR D))
|
||||
(V VALS (CDR V)))
|
||||
@@ -348,8 +361,8 @@
|
||||
(PUSH SETTER SETF-LIST)
|
||||
(SETQ NEXT-VAR (CAR NEWVAL)))))))
|
||||
|
||||
(DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL
|
||||
DOC-STRING)
|
||||
(DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL DOC-STRING
|
||||
)
|
||||
(LET
|
||||
((OTHER-ARGS NIL)
|
||||
(REST-ARG NIL))
|
||||
@@ -371,7 +384,7 @@
|
||||
SI::%$$MODIFY-MACRO-ENVIRONMENT)
|
||||
,DOC-STRING (MULTIPLE-VALUE-BIND
|
||||
(DUMMIES VALS NEWVAL SETTER GETTER)
|
||||
(GET-UNDOABLE-SETF-METHOD SI::%$$MODIFY-MACRO-FORM
|
||||
(GET-UNDOABLE-SETF-METHOD SI::%$$MODIFY-MACRO-FORM
|
||||
SI::%$$MODIFY-MACRO-ENVIRONMENT)
|
||||
(MULTIPLE-VALUE-BIND
|
||||
(DUMMIES VALS NEWVALS SETTER GETTER)
|
||||
@@ -384,10 +397,10 @@
|
||||
,SETTER))))))
|
||||
|
||||
(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF (&OPTIONAL (DELTA 1))
|
||||
-)
|
||||
-)
|
||||
|
||||
(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-INCF (&OPTIONAL (DELTA 1))
|
||||
+)
|
||||
+)
|
||||
|
||||
(DEFUN UNDOABLY-PROCLAIM (PROCLAMATION)
|
||||
|
||||
@@ -396,34 +409,34 @@
|
||||
(WHEN (CONSP PROCLAMATION)
|
||||
(CASE (CAR PROCLAMATION)
|
||||
(SPECIAL (DOLIST (X (CDR PROCLAMATION))
|
||||
(UNDOABLY (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
|
||||
(UNDOABLY (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
|
||||
T)
|
||||
(SETF (IL:VARIABLE-GLOBAL-P X)
|
||||
NIL)
|
||||
(SETF (CONSTANTP X)
|
||||
NIL))))
|
||||
(GLOBAL (DOLIST (X (CDR PROCLAMATION))
|
||||
(UNDOABLY (SETF (IL:VARIABLE-GLOBAL-P X)
|
||||
(UNDOABLY (SETF (IL:VARIABLE-GLOBAL-P X)
|
||||
T)
|
||||
(SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
|
||||
NIL)
|
||||
(SETF (CONSTANTP X)
|
||||
NIL))))
|
||||
(SI::CONSTANT (DOLIST (X (CDR PROCLAMATION))
|
||||
(UNDOABLY (SETF (CONSTANTP X)
|
||||
(UNDOABLY (SETF (CONSTANTP X)
|
||||
T)
|
||||
(SETF (IL:VARIABLE-GLOBAL-P X)
|
||||
NIL)
|
||||
(SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
|
||||
NIL))))
|
||||
(DECLARATION (DOLIST (X (CDR PROCLAMATION))
|
||||
(UNDOABLY (SETF (DECL-SPECIFIER-P X)
|
||||
(UNDOABLY (SETF (DECL-SPECIFIER-P X)
|
||||
T))))
|
||||
(NOTINLINE (DOLIST (X (CDR PROCLAMATION))
|
||||
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
|
||||
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
|
||||
T))))
|
||||
(INLINE (DOLIST (X (CDR PROCLAMATION))
|
||||
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
|
||||
(UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X)
|
||||
NIL)))))))
|
||||
|
||||
(DEFUN MAKE-UNDOABLE (FORM &OPTIONAL ENV)
|
||||
@@ -438,7 +451,7 @@
|
||||
(DEFUN UNDOABLY-SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"NOTE: If you change this version, be sure to change the not-undoable version on LLSYMBOL!")
|
||||
"NOTE: If you change this version, be sure to change the not-undoable version on LLSYMBOL!")
|
||||
|
||||
(IL:* IL:|;;| " undoable inverse of SYMBOL-FUNCTION")
|
||||
|
||||
@@ -449,9 +462,9 @@
|
||||
(IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.")
|
||||
|
||||
(CASE (CAR DEFINITION)
|
||||
(:MACRO (UNDOABLY-SETF (MACRO-FUNCTION SYMBOL)
|
||||
(:MACRO (UNDOABLY-SETF (MACRO-FUNCTION SYMBOL)
|
||||
(CDR DEFINITION)))
|
||||
(:SPECIAL-FORM (UNDOABLY-SETF (GET SYMBOL 'IL:SPECIAL-FORM)
|
||||
(:SPECIAL-FORM (UNDOABLY-SETF (GET SYMBOL 'IL:SPECIAL-FORM)
|
||||
(CDR DEFINITION)))
|
||||
(T (IL:/PUTD SYMBOL DEFINITION T))))
|
||||
|
||||
@@ -480,14 +493,14 @@
|
||||
(IL:* IL:|;;| "undoable setf of macro-function")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"NOTE: If you change this, be sure to change the not-undoable version on CMLMACROS!")
|
||||
"NOTE: If you change this, be sure to change the not-undoable version on CMLMACROS!")
|
||||
|
||||
(PROG1 (UNDOABLY-SETF (GET X 'IL:MACRO-FN)
|
||||
(PROG1 (UNDOABLY-SETF (GET X 'IL:MACRO-FN)
|
||||
BODY)
|
||||
(AND (IL:GETD X)
|
||||
(CASE (IL:ARGTYPE X)
|
||||
((1 3) (IL:* IL:\;
|
||||
"Leave Interlisp nlambda definition alone")
|
||||
"Leave Interlisp nlambda definition alone")
|
||||
)
|
||||
(OTHERWISE (IL:/PUTD X NIL))))))
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY
|
||||
@@ -498,18 +511,18 @@
|
||||
)
|
||||
|
||||
(IL:ADDTOVAR IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM)
|
||||
(POP . UNDOABLY-POP)
|
||||
(PSETF . UNDOABLY-PSETF)
|
||||
(PUSH . UNDOABLY-PUSH)
|
||||
(PUSHNEW . UNDOABLY-PUSHNEW)
|
||||
((REMF) . UNDOABLY-REMF)
|
||||
(ROTATEF . UNDOABLY-ROTATEF)
|
||||
(SHIFTF . UNDOABLY-SHIFTF)
|
||||
(DECF . UNDOABLY-DECF)
|
||||
(INCF . UNDOABLY-INCF)
|
||||
(SET . UNDOABLY-SET-SYMBOL)
|
||||
(MAKUNBOUND . UNDOABLY-MAKUNBOUND)
|
||||
(FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))
|
||||
(POP . UNDOABLY-POP)
|
||||
(PSETF . UNDOABLY-PSETF)
|
||||
(PUSH . UNDOABLY-PUSH)
|
||||
(PUSHNEW . UNDOABLY-PUSHNEW)
|
||||
(REMF . UNDOABLY-REMF)
|
||||
(ROTATEF . UNDOABLY-ROTATEF)
|
||||
(SHIFTF . UNDOABLY-SHIFTF)
|
||||
(DECF . UNDOABLY-DECF)
|
||||
(INCF . UNDOABLY-INCF)
|
||||
(SET . UNDOABLY-SET-SYMBOL)
|
||||
(MAKUNBOUND . UNDOABLY-MAKUNBOUND)
|
||||
(FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))
|
||||
|
||||
(DEFUN GET-UNDOABLE-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT &AUX TEMP)
|
||||
(COND
|
||||
@@ -524,7 +537,7 @@
|
||||
|
||||
(IL:* IL:|;;| "always expand local macros")
|
||||
|
||||
(GET-UNDOABLE-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT)
|
||||
(GET-UNDOABLE-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT)
|
||||
ENVIRONMENT))
|
||||
((SETQ TEMP (GET (CAR FORM)
|
||||
':UNDOABLE-SETF-INVERSE))
|
||||
@@ -553,12 +566,12 @@
|
||||
(T (MULTIPLE-VALUE-BIND (MAC MORE)
|
||||
(MACROEXPAND-1 FORM ENVIRONMENT)
|
||||
(IF (AND MORE (NOT (EQ MAC FORM)))
|
||||
(RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD MAC ENVIRONMENT))
|
||||
(RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD MAC ENVIRONMENT))
|
||||
(ERROR "~S is not a known location specifier for SETF."
|
||||
(CAR FORM))))))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"this is lexically correct, but doesn't work in bytecompiler, interlisp")
|
||||
"this is lexically correct, but doesn't work in bytecompiler, interlisp")
|
||||
|
||||
(IL:* IL:|;;| "(cl:values dummies vals newval `(cl:labels ((undostore (,@newval) (undosave (list #'undostore ,getter)) ,setter)) (undostore ,@newval)) getter)")
|
||||
|
||||
@@ -580,7 +593,7 @@
|
||||
(WHEN ENVIRONMENT
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"This function only saves undo info when there is no lexical binding for the variable.")
|
||||
"This function only saves undo info when there is no lexical binding for the variable.")
|
||||
|
||||
(SETQ ENVIRONMENT (IL:ENVIRONMENT-VARS ENVIRONMENT))
|
||||
(LOOP (IF (NULL ENVIRONMENT)
|
||||
@@ -593,7 +606,7 @@
|
||||
IL:*SPECIAL-BINDING-MARK*)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"it is a special binding, or a mark that we are using the special value")
|
||||
"it is a special binding, or a mark that we are using the special value")
|
||||
|
||||
(RETURN NIL) (IL:* IL:\; "return from WHILE")
|
||||
)
|
||||
@@ -634,26 +647,25 @@
|
||||
(IL:\\RPLPTR VP 0 VALUE))))))
|
||||
(IL:DEFINEQ
|
||||
|
||||
(undoably-setq
|
||||
(il:nlambda varvalue (il:* il:\; "Edited 8-Oct-87 18:54 by jop")
|
||||
(il:* il:\; "Interlisp version")
|
||||
|
||||
(undoably-set-symbol (car varvalue)
|
||||
(il:\\evprog1 (cdr varvalue)))))
|
||||
(UNDOABLY-SETQ
|
||||
(IL:NLAMBDA VARVALUE (IL:* IL:\; "Edited 8-Oct-87 18:54 by jop")
|
||||
(IL:* IL:\; "Interlisp version")
|
||||
(UNDOABLY-SET-SYMBOL (CAR VARVALUE)
|
||||
(IL:\\EVPROG1 (CDR VARVALUE)))))
|
||||
)
|
||||
|
||||
(DEFINE-SPECIAL-FORM UNDOABLY (&REST FORMS &ENVIRONMENT ENV)
|
||||
(LOOP (IF (NULL (CDR FORMS))
|
||||
(RETURN (UNDOHOOK (CAR FORMS)
|
||||
(RETURN (UNDOHOOK (CAR FORMS)
|
||||
ENV))
|
||||
(UNDOHOOK (POP FORMS)
|
||||
(UNDOHOOK (POP FORMS)
|
||||
ENV))))
|
||||
|
||||
(DEFINE-SPECIAL-FORM UNDOABLY-SETQ (&REST TAIL &ENVIRONMENT ENV)
|
||||
(LET (VALUE)
|
||||
(LOOP (IF (NULL TAIL)
|
||||
(RETURN NIL)
|
||||
(SETQ VALUE (UNDOABLY-SET-SYMBOL (POP TAIL)
|
||||
(SETQ VALUE (UNDOABLY-SET-SYMBOL (POP TAIL)
|
||||
(EVAL (POP TAIL)
|
||||
ENV)
|
||||
ENV))))
|
||||
@@ -678,7 +690,16 @@
|
||||
|
||||
(IL:ADDTOVAR IL:LAMA )
|
||||
)
|
||||
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
|
||||
(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 2022))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (29112 29437 (UNDOABLY-SETQ 29125 . 29435)))))
|
||||
(IL:FILEMAP (NIL (4227 4310 (NOHOOK 4227 . 4310)) (4312 7992 (UNDOABLY 4312 . 7992)) (7994 8214 (
|
||||
UNDOABLY-FMAKUNBOUND 7994 . 8214)) (8216 8792 (UNDOABLY-MAKUNBOUND 8216 . 8792)) (8794 9521 (
|
||||
UNDOABLY-SETF 8794 . 9521)) (9523 11417 (UNDOHOOK 9523 . 11417)) (11419 11766 (UNDOABLY-PSETF 11419 .
|
||||
11766)) (11768 12368 (UNDOABLY-POP 11768 . 12368)) (12370 12930 (UNDOABLY-PUSH 12370 . 12930)) (12932
|
||||
13391 (UNDOABLY-PUSHNEW 12932 . 13391)) (13393 14759 (UNDOABLY-REMF 13393 . 14759)) (14761 15907 (
|
||||
UNDOABLY-ROTATEF 14761 . 15907)) (15909 17049 (UNDOABLY-SHIFTF 15909 . 17049)) (18845 20667 (
|
||||
UNDOABLY-PROCLAIM 18845 . 20667)) (20669 20740 (MAKE-UNDOABLE 20669 . 20740)) (20742 20888 (
|
||||
STOP-UNDOABLY 20742 . 20888)) (20890 22570 (UNDOABLY-SETF-SYMBOL-FUNCTION 20890 . 22570)) (22572 23161
|
||||
(UNDOABLY-SETF-MACRO-FUNCTION 22572 . 23161)) (24059 27459 (GET-UNDOABLE-SETF-METHOD 24059 . 27459))
|
||||
(27461 30185 (UNDOABLY-SET-SYMBOL 27461 . 30185)) (30186 30514 (UNDOABLY-SETQ 30199 . 30512)))))
|
||||
IL:STOP
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user