Compare commits
24 Commits
medley-211
...
medley-220
| Author | SHA1 | Date | |
|---|---|---|---|
|
b791bff070 | ||
|
|
ab8e97ff7b | ||
|
f8e4bbd7cb | ||
|
c7272e78f2 | ||
|
|
f531e89dde | ||
|
|
293c973f1d | ||
|
|
fe62e8e6e2 | ||
|
|
51f0c19ad1 | ||
|
|
1438ddba1f | ||
|
|
ae3851ccf9 | ||
|
|
e3f9a4ca9a | ||
|
|
7966704f1e | ||
|
|
311e4f049c | ||
|
|
e119314a9e | ||
|
|
27d4df45e6 | ||
|
|
312e99b0f4 | ||
|
|
82eaacc542 | ||
|
|
479de87011 | ||
|
|
5445a12b7e | ||
|
|
fadf81012b | ||
|
|
792edfdad5 | ||
|
fd2e5ed93e | ||
|
|
e3e9156452 | ||
|
|
f0feca759b |
@@ -14,7 +14,7 @@ There (soon) will also be Docker containers with the latest, and a way to try ou
|
||||
|
||||
### Getting releases
|
||||
|
||||
Get the Maiko release [here](https://github.com/Interlisp/maiko/releases). You'll need the one corresponding to your operating system and processor (for Windows with WSL or Intel linux, use `linux.x86_64`; for Macs use `darwin.x86_64` for Intel and `darwin.aarch64` for M1.)
|
||||
Get the Maiko release [here](https://github.com/Interlisp/maiko/releases). You'll need the one corresponding to your operating system and processor (for Windows with WSL or Intel Linux, use `linux.x86_64`; for Macs use `darwin.x86_64` for Intel and `darwin.aarch64` for M1.)
|
||||
|
||||
Or, build your own maiko (the binaries `lde` `ldex` and `ldeinit`.) We can build for other OS arch pairs depending on what is available for GitHub actions.
|
||||
|
||||
@@ -99,7 +99,7 @@ Or from the Common Lisp prompt with:
|
||||
```
|
||||
(IL:LOGOUT)
|
||||
```
|
||||
When you logout of the system, Medley automatically creates a binary
|
||||
When you log out of the system, Medley automatically creates a binary
|
||||
dump of your system located in your home directory named
|
||||
`lisp.virtualmem`. The next time you run the system, if you don't
|
||||
specify a specific image to run, Medley restores that image so that
|
||||
|
||||
@@ -1,43 +1,41 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "25-Oct-2021 14:54:43" |{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;14| 9472
|
||||
(FILECREATED "26-Dec-2021 18:58:43" |{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;2| 9049
|
||||
|
||||
|changes| |to:| (VARS MEDLEY-UTILSCOMS)
|
||||
(FNS GATHER-INFO)
|
||||
:CHANGES-TO (FNS GATHER-INFO)
|
||||
|
||||
|previous| |date:| "23-Oct-2021 14:53:16"
|
||||
|{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;2|)
|
||||
:PREVIOUS-DATE "25-Oct-2021 14:54:43" |{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;1|
|
||||
)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
|
||||
(RPAQQ MEDLEY-UTILSCOMS ((FNS GATHER-INFO MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
|
||||
(VARS MEDLEY-FIX-DIRS)
|
||||
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)))
|
||||
(VARS MEDLEY-FIX-DIRS)
|
||||
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)))
|
||||
(DEFINEQ
|
||||
|
||||
(GATHER-INFO
|
||||
(LAMBDA (PHASE) (* \;
|
||||
"Edited 24-Oct-2021 09:43 by larry")
|
||||
"Edited 26-Dec-2021 18:56 by larry")
|
||||
(* \;
|
||||
"Edited 24-Oct-2021 09:43 by larry")
|
||||
(SELECTQ PHASE
|
||||
(ALL (SETQ SYSFILES (UNION SYSFILES FILELST))
|
||||
(SETQ FILELST NIL)
|
||||
(FILESLOAD (SOURCE)
|
||||
SYSEDIT)
|
||||
(|for| I |from| 1 |to| 4 |do| (GATHER-INFO I)))
|
||||
(1 (SETQ LOADEDFILES (|for| X |in| LOADEDFILELST |collect| (FILENAMEFIELD
|
||||
X
|
||||
'NAME)))
|
||||
(ALL (|for| I |from| 0 |to| 4 |do| (GATHER-INFO I)))
|
||||
(0 (SETQ SYSFILES (UNION SYSFILES FILELST))
|
||||
(SETQ FILELST NIL)
|
||||
(FILESLOAD (SOURCE)
|
||||
SYSEDIT))
|
||||
(1 (SETQ LOADEDFILES (|for| X |in| LOADEDFILELST |collect| (FILENAMEFIELD X 'NAME)))
|
||||
(FILESLOAD FILESETS)
|
||||
(SETQ ALLFILESETSFILES (|for| X |in| FILESETS |join| (APPEND (EVAL X))))
|
||||
(SETQ SOURCES (|for| X |in| (DIRECTORY (MEDLEYDIR "sources" "*.*;" T))
|
||||
|when| (NOT (MEMB (FILENAMEFIELD X 'EXTENSION)
|
||||
'(LCOM DFASL TEDIT TXT)))
|
||||
'(LCOM DFASL TEDIT TXT)))
|
||||
|collect| (FILENAMEFIELD X 'NAME))))
|
||||
(-1 (PRINTOUT T " loaded files not in SYSFILES or FILELST: "
|
||||
(|for| X |in| LOADEDFILES |when| (NOT (OR (FMEMB X SYSFILES)
|
||||
(FMEMB X FILELST)))
|
||||
|collect| X)
|
||||
(FMEMB X FILELST))) |collect| X)
|
||||
T)
|
||||
(PRINTOUT T "Sources not loaded: " (CL:SET-DIFFERENCE SOURCES (APPEND ALLFILESETSFILES
|
||||
LOADEDFILES))
|
||||
@@ -52,50 +50,45 @@
|
||||
DEFD))
|
||||
(|for| X |in| DEFINEDFNS |when| (CCODEP X)
|
||||
|do| (LET ((Y (PUTPROP X 'CCC (CALLSCCODE X))))
|
||||
(|for| REV |in| '(BLOCK-CALLED-BY CALLED-BY SPECIAL-BY GLOBAL-BY)
|
||||
|as| VAL |in| Y
|
||||
|do| (|for| S |in| VAL
|
||||
|do| (PUTPROP S REV (CONS X (GETPROP S REV)))))))
|
||||
(|for| REV |in| '(BLOCK-CALLED-BY CALLED-BY SPECIAL-BY GLOBAL-BY)
|
||||
|as| VAL |in| Y |do| (|for| S |in| VAL
|
||||
|do| (PUTPROP S REV (CONS X (GETPROP S REV)))))))
|
||||
(SETQ CALLEDFNS NIL)
|
||||
(MAPATOMS (FUNCTION (LAMBDA (X)
|
||||
(|if| (AND (NOT (GETD X))
|
||||
(GETPROP X 'CALLED-BY))
|
||||
(GETPROP X 'CALLED-BY))
|
||||
|then| (CL:PUSH X CALLEDFNS))))))
|
||||
(-2 (PRINTOUT T "Functions called and not defined" CALLEDFNS T))
|
||||
(3 (|for| X |in| SYSFILES
|
||||
|do|
|
||||
(LOAD X 'PROP)
|
||||
(PUTPROP X 'CONTENT (READFILE X))
|
||||
(|for| EXR |in| (GETPROP X 'CONTENT)
|
||||
|do| (SELECTQ (CAR EXR)
|
||||
(DEFINEQ (|for| DFN |in| (CDR EXR)
|
||||
|do| (|if| (EQUAL (CADR DFN)
|
||||
(GETPROP (CAR DFN)
|
||||
'EXPR))
|
||||
|then| (PRINTOUT T (CAR DFN)
|
||||
" ")
|
||||
(PUTPROP (CAR DFN)
|
||||
'EXPR
|
||||
(CADR DFN))
|
||||
|else| (PRINTOUT T (CAR DFN)
|
||||
"* "))))
|
||||
NIL)))
|
||||
(SETQ ALLCONTENT (|for| X |in| SYSFILES |collect| (CONS X (GETPROP
|
||||
X
|
||||
'CONTENT))))
|
||||
|do| (LOAD X 'PROP)
|
||||
(PUTPROP X 'CONTENT (READFILE X))
|
||||
(|for| EXR |in| (GETPROP X 'CONTENT)
|
||||
|do| (SELECTQ (CAR EXR)
|
||||
(DEFINEQ (|for| DFN |in| (CDR EXR)
|
||||
|do| (|if| (EQUAL (CADR DFN)
|
||||
(GETPROP (CAR DFN)
|
||||
'EXPR))
|
||||
|then| (PRINTOUT T (CAR DFN)
|
||||
" ")
|
||||
(PUTPROP (CAR DFN)
|
||||
'EXPR
|
||||
(CADR DFN))
|
||||
|else| (PRINTOUT T (CAR DFN)
|
||||
"* "))))
|
||||
NIL)))
|
||||
(SETQ ALLCONTENT (|for| X |in| SYSFILES |collect| (CONS X (GETPROP X 'CONTENT))))
|
||||
(* \; " don't edit with SEDIT")
|
||||
(LET (DUPS)
|
||||
(|for| X |in| SYSFILES
|
||||
|do| (|for| FN |in| (FILEFNSLST X)
|
||||
|do| (|if| (GETPROP FN 'WHEREIS)
|
||||
|then| (NCONC1 (GETPROP FN 'WHEREIS)
|
||||
X)
|
||||
(OR (FMEMB FN DUPS)
|
||||
(SETQ DUPS (CONS FN DUPS)))
|
||||
|else| (PUTPROP FN 'WHEREIS (LIST X)))))
|
||||
|do| (|if| (GETPROP FN 'WHEREIS)
|
||||
|then| (NCONC1 (GETPROP FN 'WHEREIS)
|
||||
X)
|
||||
(OR (FMEMB FN DUPS)
|
||||
(SETQ DUPS (CONS FN DUPS)))
|
||||
|else| (PUTPROP FN 'WHEREIS (LIST X)))))
|
||||
(SETQ DUPFNS DUPS))
|
||||
(SETQ NO-SOURCE (|for| X |in| DEFINEDFNS |when| (NOT (GETPROP X 'EXPR))
|
||||
|collect| X)))
|
||||
(SETQ NO-SOURCE (|for| X |in| DEFINEDFNS |when| (NOT (GETPROP X 'EXPR)) |collect| X)))
|
||||
(-3 (PRINTOUT T "Functions compiled but no expr" NO-SOURCE T)
|
||||
(PRINTOUT T "Functions on more than one file: " DUPFNS T))
|
||||
(4 (PRINTOUT T T "STARTING MASTERSCOPE PHASE ON " (DATE)
|
||||
@@ -104,7 +97,7 @@
|
||||
SYSEDIT)
|
||||
(|for| X |in| SYSFILES |do| (MSNOTICEFILE X))
|
||||
(|for| X |in| SYSFILES |do| (PRINTOUT T T "Analyzing " X T)
|
||||
(MASTERSCOPE `(ANALYZE ON ,(KWOTE X)))))
|
||||
(MASTERSCOPE `(ANALYZE ON ,(KWOTE X)))))
|
||||
(-4 "No queries yet")
|
||||
(HELP))))
|
||||
|
||||
@@ -124,7 +117,7 @@
|
||||
)
|
||||
|
||||
(RPAQQ MEDLEY-FIX-DIRS ("sources" "library" "lispusers" "internal/library" "greetfiles"
|
||||
"docs>Documentation Tools"))
|
||||
"docs>Documentation Tools"))
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-EXPORTS-ALL
|
||||
@@ -157,6 +150,6 @@
|
||||
(DRIBBLE))))
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (618 7420 (GATHER-INFO 628 . 6522) (MEDLEY-FIX-LINKS 6524 . 7047) (MEDLEY-FIX-DATES 7049
|
||||
. 7418)) (7578 9449 (MAKE-EXPORTS-ALL 7588 . 8604) (MAKE-WHEREIS-HASH 8606 . 9447)))))
|
||||
(FILEMAP (NIL (553 7001 (GATHER-INFO 563 . 6103) (MEDLEY-FIX-LINKS 6105 . 6628) (MEDLEY-FIX-DATES 6630
|
||||
. 6999)) (7155 9026 (MAKE-EXPORTS-ALL 7165 . 8181) (MAKE-WHEREIS-HASH 8183 . 9024)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,91 +0,0 @@
|
||||
;; Function To Be Tested: LIST*
|
||||
;;
|
||||
;; Source: Guy L Steele's CLTL
|
||||
;; Section: 15.2 Lists
|
||||
;; Page: 267
|
||||
;;
|
||||
;; Created By: Kelly Roach
|
||||
;;
|
||||
;; Creation Date: June 27,1986
|
||||
;;
|
||||
;; Last Update: June 27,1986
|
||||
;; July 15, 1986 Sye/ create test cases
|
||||
;;
|
||||
;; Filed As: {ERIS}<LISPCORE>CML>TEST>15-2-LIST*.TEST
|
||||
;;
|
||||
;;
|
||||
;; Syntax: (LIST* ARG &REST OTHERS)
|
||||
;;
|
||||
;; Function Description:
|
||||
;; LIST* is like LIST except that the last CONS
|
||||
;; of the constructed list is ``dotted.'' The last argument to LIST*
|
||||
;; is used as the CDR of the last cons constructed;
|
||||
;; this need not be an atom. If it is not an atom,
|
||||
;; then the effect is to add several new elements to the front of a list.
|
||||
;; For example:
|
||||
;;
|
||||
;; (LIST* 'A 'B 'C 'D) => (A B C . D)
|
||||
;; This is like
|
||||
;; (CONS 'A (CONS 'B (CONS 'C 'D)))
|
||||
;; Also:
|
||||
;; (LIST* 'A 'B 'C '(D E F)) => (A B C D E F)
|
||||
;; (LIST* X) = X
|
||||
;;
|
||||
;;
|
||||
;; Argument(s): ARG - anything
|
||||
;; OTHERS - anything
|
||||
;;
|
||||
;; Returns: a dotted list
|
||||
;;
|
||||
(do-test "test list*0 - test case copied from page 267 of CLtL"
|
||||
(and (EQUAL (LIST* 'A 'B 'C 'D) '(A B C . D))
|
||||
(EQUAL (LIST* 'A 'B 'C '(D E F)) '(A B C D E F))
|
||||
(EQUAL (LIST* 'X) 'X)
|
||||
)
|
||||
)
|
||||
|
||||
(do-test "test list*1"
|
||||
(and (equal (list* 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999
|
||||
999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999)
|
||||
(append (make-list 48 :initial-element 999) '(999 . 999)))
|
||||
|
||||
(equal (list* "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" . Shanti))
|
||||
)
|
||||
)
|
||||
|
||||
(do-test "test list*2"
|
||||
(equal (list* 1.009 'a (cons 3 4) (funcall #'list* 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0))
|
||||
(apply #'list* 'm 'n 'b '(88)) (list* (+ 2 3) (caddr '(w x y z))) )
|
||||
'(1.009 a (3 . 4) (2.009 #\g . "string") t nil (m n b . 88) 5 . y)))
|
||||
|
||||
(do-test "test list*3"
|
||||
(progn
|
||||
(setq aa '(a b c d e f g h))
|
||||
(equal (list* (last aa) (nth 3 aa) (nthcdr 5 aa) (list* (car aa) (endp aa))
|
||||
(progn 1 2 3 (setq x 1 y 2 z 3))
|
||||
(prog2 (defun fun () "fun1") (fun))
|
||||
(prog1 (setq a 100) (setq a (1+ a)))
|
||||
(progn (defmacro mac () `(list* ,(* 2 2) ,(list-length ()))) (mac)))
|
||||
'( (h) d (f g h) (a . nil) 3 "fun1" 100 4 . 0)) ))
|
||||
|
||||
(do-test "test list*4 - nested list* functions"
|
||||
(and
|
||||
(equal (setq aa (list* (list* (list* (list* (list* (list* (list* (list* (list* (list* 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k)))))))))))
|
||||
'(a b c d e f g h i j . k) )
|
||||
(equal (list* aa aa aa aa aa)
|
||||
'((a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k)
|
||||
a b c d e f g h i j . k) )
|
||||
)
|
||||
)
|
||||
|
||||
(do-test "test list*5 - (list* x) is equivalent to x [page 268]"
|
||||
(and (eq (list* ()) ())
|
||||
(eq (list* 10) 10)
|
||||
(equal (list* '(1)) '(1))
|
||||
(equal (list* (list* (list 2))) '(2))
|
||||
(prog2 (setq a (list* #'-)) (= (funcall a 4 3 2 1) -2))
|
||||
(equal (list* (list (list* 1 2 3) '(4) ) '(5 . "a")) '(((1 2 . 3) (4)) 5 . "a"))
|
||||
)
|
||||
)
|
||||
|
||||
STOP
|
||||
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED "18-Aug-2021 12:13:11" {DSK}<home>larry>medley>library>MSANALYZE.;5 62745
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS MSPRGMACRO MSFINDP)
|
||||
(VARS MSMACROPROPS)
|
||||
(FILECREATED "26-Dec-2021 10:10:02" {DSK}<home>larry>medley>library>MSANALYZE.;6 62468
|
||||
|
||||
previous date%: "18-Aug-2021 10:56:25" {DSK}<home>larry>medley>library>MSANALYZE.;4)
|
||||
:CHANGES-TO (FNS MSPRGTEMPLATE)
|
||||
|
||||
:PREVIOUS-DATE "18-Aug-2021 12:13:11" {DSK}<home>larry>medley>library>MSANALYZE.;5)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -269,7 +269,7 @@ DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS MSVBNOTICED MACRO [OPENLAMBDA (VERB MOD)
|
||||
(CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED])
|
||||
(CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED])
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -752,19 +752,18 @@ DONTCOPY
|
||||
(CDR TEMPLATE])
|
||||
|
||||
(MSPRGTEMPLATE
|
||||
(LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* lmm "23-Jul-86 00:15")
|
||||
(BLOCK) (*
|
||||
"Masterscope should block every once and a while. This is one place to do it.")
|
||||
[LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* ; "Edited 26-Dec-2021 10:09 by larry")
|
||||
(* lmm "23-Jul-86 00:15")
|
||||
(PROG ((VARS VARS)
|
||||
TEM)
|
||||
(COND
|
||||
((EQ TEMPLATE 'MACRO)
|
||||
[(EQ TEMPLATE 'MACRO)
|
||||
(COND
|
||||
((SETQ TEM (GETMACROPROP (CAR PARENT)
|
||||
MSMACROPROPS))
|
||||
(MSPRGMACRO PARENT TEM))
|
||||
(T (MSPRGTEMPLATE1 PARENT '(CALL .. EVAL)))))
|
||||
(T (MSPRGTEMPLATE1 PARENT TEMPLATE))))))
|
||||
(T (MSPRGTEMPLATE1 PARENT '(CALL |..| EVAL]
|
||||
(T (MSPRGTEMPLATE1 PARENT TEMPLATE])
|
||||
|
||||
(MSPRGLAMBDA
|
||||
[LAMBDA (EXPR FLG TYPE) (* ; "Edited 3-Jun-88 10:23 by jrb:")
|
||||
@@ -1036,22 +1035,21 @@ DONTCOPY
|
||||
|
||||
(RPAQQ MSRECORDTRANFLG NIL)
|
||||
|
||||
(ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16
|
||||
$$17)
|
||||
(ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS INCLISP MACRO ((.X.)
|
||||
(COND
|
||||
((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.)))
|
||||
INCLISP)
|
||||
(T .X.))))
|
||||
(COND
|
||||
((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.)))
|
||||
INCLISP)
|
||||
(T .X.))))
|
||||
|
||||
(PUTPROPS LTEMPLATE MACRO [LAMBDA (Y)
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
|
||||
@@ -1265,10 +1263,10 @@ DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(PUTPROPS LTEMPLATE MACRO [LAMBDA (Y)
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -1288,11 +1286,11 @@ DONTCOPY
|
||||
)
|
||||
(PUTPROPS MSANALYZE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1988 1990 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3820 11339 (VARS 3830 . 3971) (FREEVARS 3973 . 4126) (CALLS 4128 . 10469) (
|
||||
COLLECTFNDATA 10471 . 10850) (CALLS3 10852 . 11337)) (13596 52783 (ALLCALLS 13606 . 14285) (
|
||||
MSINITFNDATA 14287 . 14531) (MSPRGE 14533 . 21607) (MSPRGMACRO 21609 . 22205) (MSPRGCALL 22207 . 22531
|
||||
) (MSBINDVAR 22533 . 23052) (MSPRGRECORD 23054 . 29967) (MSPRGERR 29969 . 30137) (MSPRGTEMPLATE1 30139
|
||||
. 39300) (MSPRGTEMPLATE 39302 . 39982) (MSPRGLAMBDA 39984 . 49579) (MSPRGLST 49581 . 49749) (ADDTO
|
||||
49751 . 50542) (NLAMBDAFNP 50544 . 51296) (MSPRGDWIM 51298 . 52117) (MSDWIMTRAN 52119 . 52781)) (62109
|
||||
62541 (MSFINDP 62119 . 62539)))))
|
||||
(FILEMAP (NIL (3759 11278 (VARS 3769 . 3910) (FREEVARS 3912 . 4065) (CALLS 4067 . 10408) (
|
||||
COLLECTFNDATA 10410 . 10789) (CALLS3 10791 . 11276)) (13527 52635 (ALLCALLS 13537 . 14216) (
|
||||
MSINITFNDATA 14218 . 14462) (MSPRGE 14464 . 21538) (MSPRGMACRO 21540 . 22136) (MSPRGCALL 22138 . 22462
|
||||
) (MSBINDVAR 22464 . 22983) (MSPRGRECORD 22985 . 29898) (MSPRGERR 29900 . 30068) (MSPRGTEMPLATE1 30070
|
||||
. 39231) (MSPRGTEMPLATE 39233 . 39834) (MSPRGLAMBDA 39836 . 49431) (MSPRGLST 49433 . 49601) (ADDTO
|
||||
49603 . 50394) (NLAMBDAFNP 50396 . 51148) (MSPRGDWIM 51150 . 51969) (MSDWIMTRAN 51971 . 52633)) (61832
|
||||
62264 (MSFINDP 61842 . 62262)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,17 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED " 4-May-92 13:10:53" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;3| 23489
|
||||
|
||||
|changes| |to:| (TEMPLATES CL:DECF CL:INCF CL:PUSH)
|
||||
(FILECREATED "15-Jan-2022 20:17:21" |{DSK}<home>larry>medley>library>MSCOMMON.;4| 24053
|
||||
|
||||
|previous| |date:| "12-Jun-90 10:17:31" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;2|)
|
||||
: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)
|
||||
|
||||
:PREVIOUS-DATE " 4-May-92 13:10:53" |{DSK}<home>larry>medley>library>MSCOMMON.;3|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT MSCOMMONCOMS)
|
||||
|
||||
@@ -37,8 +42,8 @@
|
||||
CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP
|
||||
CL:STRING-UPCASE CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>=
|
||||
CL:SUBLIS CL:SUBSETP CL:SUBST CL:SUBST-IF CL:SUBST-IF-NOT CL:SUBSTITUTE
|
||||
CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:VECTOR-PUSH
|
||||
CL:VECTOR-PUSH-EXTEND WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING)
|
||||
CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:UNLESS CL:VECTOR-PUSH
|
||||
CL:VECTOR-PUSH-EXTEND CL:WHEN WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING)
|
||||
(P
|
||||
(* |;;| "First tell Masterscope how to find FUNCTIONS and VARIABLES")
|
||||
|
||||
@@ -46,7 +51,7 @@
|
||||
(MSADDANALYZE 'FUNCTIONS 'FUNCTION 'FUNCTIONS 'FUNCTIONSMSGETDEF 'FUNCTIONSMSMC)
|
||||
|
||||
(* |;;|
|
||||
"Then add KEYWORD support. Templates may now contain the following as their last element:")
|
||||
"Then add KEYWORD support. Templates may now contain the following as their last element:")
|
||||
|
||||
|
||||
(* |;;| "... KEYWORDS list of keywords accepted)")
|
||||
@@ -65,7 +70,7 @@
|
||||
(MSADDMODIFIER 'SPECIFY 'KEYWORDS 'KEYSPECIFY)
|
||||
|
||||
(* |;;|
|
||||
"Stuff for locally-defined things. We don't attempt to handle them (*sigh*), just record them.")
|
||||
"Stuff for locally-defined things. We don't attempt to handle them (*sigh*), just record them.")
|
||||
|
||||
(MSADDRELATION '(FLET FLETS FLETTING FLET))
|
||||
(MSADDRELATION '(LABEL LABELS LABELLING LABELLED))
|
||||
@@ -87,42 +92,48 @@
|
||||
(DEFINEQ
|
||||
|
||||
(FUNCTIONSMSGETDEF
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 31-Mar-88 17:31 by jrb:")
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 31-Mar-88 17:31 by jrb:")
|
||||
(LET ((BODY (REMOVE-COMMENTS (GETDEF NAME 'FUNCTIONS SOURCE OPTIONS))))
|
||||
(AND BODY (SELECTQ (CAR BODY)
|
||||
(DEFMACRO (OR (GETTEMPLATE NAME)
|
||||
(SETTEMPLATE NAME 'MACRO))
|
||||
NIL)
|
||||
(CL:DEFUN
|
||||
(* |;;| "Body is of the form:")
|
||||
(* |;;| "(DEFUN name (args...) bodies...)")
|
||||
(* |;;| "We want to hand Masterscope a massaged form it will understand.")
|
||||
(* |;;| "Which I believe is of this form:")
|
||||
(* |;;| "Body is of the form:")
|
||||
|
||||
`(CL:LAMBDA ,(CADDR BODY) ,@(CDDDR BODY)))
|
||||
(* |;;| "(DEFUN name (args...) bodies...)")
|
||||
|
||||
(* |;;|
|
||||
"We want to hand Masterscope a massaged form it will understand.")
|
||||
|
||||
(* |;;| "Which I believe is of this form:")
|
||||
|
||||
`(CL:LAMBDA ,(CADDR BODY)
|
||||
,@(CDDDR BODY)))
|
||||
NIL)))))
|
||||
|
||||
(FUNCTIONSMSMC
|
||||
(LAMBDA (NAME TYPE REASON) (* \; "Edited 1-Apr-88 13:47 by jrb:")
|
||||
(* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them")
|
||||
(LAMBDA (NAME TYPE REASON) (* \; "Edited 1-Apr-88 13:47 by jrb:")
|
||||
|
||||
(* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them")
|
||||
|
||||
(|if| (EQ (CAR (GETDEF NAME 'FUNCTIONS NIL '(NOERROR)))
|
||||
'DEFMACRO)
|
||||
'DEFMACRO)
|
||||
|then| (CHANGEMACRO NAME TYPE REASON)
|
||||
NIL
|
||||
|else| T)))
|
||||
|
||||
(VARIABLESMSGETDEF
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 19-Feb-88 19:46 by jrb:")
|
||||
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 19-Feb-88 19:46 by jrb:")
|
||||
(LET ((BODY (GETDEF NAME 'VARIABLES SOURCE OPTIONS))
|
||||
SPECVARP)
|
||||
(AND BODY
|
||||
|
||||
(* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things")
|
||||
|
||||
(* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things")
|
||||
|
||||
`(CL:LAMBDA NIL ,(IF (CADDR BODY)
|
||||
THEN `(SETQ ,(CADR BODY) ,(CADDR BODY))))))))
|
||||
THEN `(SETQ ,(CADR BODY)
|
||||
,(CADDR BODY))))))))
|
||||
)
|
||||
|
||||
|
||||
@@ -162,9 +173,9 @@
|
||||
:LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE))
|
||||
|
||||
(SETTEMPLATE 'CL:COMPILER-LET '(! NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT)
|
||||
NIL))
|
||||
NIL))
|
||||
(|..| (IF LISTP ((BOTH BIND COMPILER-LET))
|
||||
(BOTH BIND COMPILER-LET))))
|
||||
(BOTH BIND COMPILER-LET))))
|
||||
|..| EFFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'CL:COUNT '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY))
|
||||
@@ -179,10 +190,10 @@
|
||||
|
||||
(SETTEMPLATE 'DECLARE '(|..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR))
|
||||
(LOCALVARS '(IF LISTP (|..| LOCALVARS)
|
||||
LOCALVARS))
|
||||
LOCALVARS))
|
||||
((SPECVARS CL:SPECIAL)
|
||||
'(IF LISTP (|..| SPECVARS)
|
||||
SPECVARS))
|
||||
SPECVARS))
|
||||
NIL)))))
|
||||
|
||||
(SETTEMPLATE 'CL:DELETE '(EVAL SMASH KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY))
|
||||
@@ -391,7 +402,7 @@
|
||||
(SETTEMPLATE 'CL:REPLACE '(SMASH EVAL KEYWORDS :START1 :END1 :START2 :END2))
|
||||
|
||||
(SETTEMPLATE 'CL:ROTATEF '(|..| (IF (ATOM EXPR)
|
||||
SET SMASH)))
|
||||
SET SMASH)))
|
||||
|
||||
(SETTEMPLATE 'CL:SEARCH '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1
|
||||
:END2))
|
||||
@@ -401,7 +412,7 @@
|
||||
(SETTEMPLATE 'CL:SET-EXCLUSIVE-OR '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
|
||||
|
||||
(SETTEMPLATE 'CL:SHIFTF '(|..| (IF (ATOM EXPR)
|
||||
SET SMASH)
|
||||
SET SMASH)
|
||||
EVAL))
|
||||
|
||||
(SETTEMPLATE 'CL:SORT '(EVAL FUNCTION KEYWORDS :KEY))
|
||||
@@ -459,10 +470,14 @@
|
||||
|
||||
(SETTEMPLATE 'CL:UNION '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
|
||||
|
||||
(SETTEMPLATE 'CL:UNLESS '(TEST |..| EFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'CL:VECTOR-PUSH '(EVAL SMASH))
|
||||
|
||||
(SETTEMPLATE 'CL:VECTOR-PUSH-EXTEND '(EVAL SMASH EVAL))
|
||||
|
||||
(SETTEMPLATE 'CL:WHEN '(TEST |..| EFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'WRITE '(EVAL KEYWORDS :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE
|
||||
:GENSYM :ARRAY))
|
||||
|
||||
@@ -539,6 +554,6 @@
|
||||
(CLRHASH USERTEMPLATES)
|
||||
(PUTPROPS MSCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (5000 6811 (FUNCTIONSMSGETDEF 5010 . 5804) (FUNCTIONSMSMC 5806 . 6286) (
|
||||
VARIABLESMSGETDEF 6288 . 6809)))))
|
||||
(FILEMAP (NIL (5280 7291 (FUNCTIONSMSGETDEF 5290 . 6258) (FUNCTIONSMSMC 6260 . 6731) (
|
||||
VARIABLESMSGETDEF 6733 . 7289)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
414
library/SPY
414
library/SPY
@@ -1,22 +1,22 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "29-Apr-94 14:13:52" {DSK}<king>export>lispcore>library>SPY.;4 64372
|
||||
|
||||
changes to%: (FILES GRAPHER)
|
||||
(FNS SPY.GRAPH.EDITOR SPY.UPDATE.TITLE SPY.MERGEINFO SPY.MAKEGRAPHNODES SPY.MAX
|
||||
SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.MAKE.TREE
|
||||
SPY.DELETE SPY.DUMP.BUFFER SPY.ORIGINAL SPY.MERGE.CALLEES)
|
||||
(FILECREATED " 4-Jan-2022 14:09:48" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>SPY.;2 63314
|
||||
|
||||
previous date%: "28-Apr-94 15:56:32" {DSK}<king>export>lispcore>library>SPY.;3)
|
||||
:CHANGES-TO (VARS SPYCOMS)
|
||||
(FNS SPY.MAKE.TREE)
|
||||
|
||||
:PREVIOUS-DATE "29-Apr-94 14:13:52" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>SPY.;1
|
||||
)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1984-1985, 1987-1988, 1990-1991, 1993-1994 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SPYCOMS)
|
||||
|
||||
(RPAQQ SPYCOMS
|
||||
((VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
|
||||
(RPAQQ SPYCOMS
|
||||
[(VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
|
||||
(SPY.GRAPH.MENU)
|
||||
SPY.SHOW.PERCENTAGES SPY.SMALLGHOSTS SPY.ICON)
|
||||
(INITVARS (SPY.NEXT 0)
|
||||
@@ -42,38 +42,41 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
(MACROS WITH-SPY WITH.SPY)
|
||||
(DECLARE%: DONTCOPY (RECORDS SPYRECORD SPYDATA))
|
||||
(INITRECORDS SPYRECORD)
|
||||
(DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))))
|
||||
(DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))
|
||||
(P (MOVD? 'NILL 'MODERNWINDOW])
|
||||
|
||||
(RPAQQ SPY.BORDERS ((NORMAL "Normal" 2 -1)
|
||||
(GHOST "Shown elsewhere" 2 8840)
|
||||
(RECURSIVEGHOST "End of recursive chain" 2 0 -1)
|
||||
(MERGED "Includes other branches" 4 42405)
|
||||
(SELFRECURSIVE "Includes self-recursive calls" 2 61375)
|
||||
(RECURSIVE "Head of recursive chain" 4 28086)
|
||||
(ENDOFLINE "exceeded depth limit" 6 64510)))
|
||||
(RPAQQ SPY.BORDERS
|
||||
((NORMAL "Normal" 2 -1)
|
||||
(GHOST "Shown elsewhere" 2 8840)
|
||||
(RECURSIVEGHOST "End of recursive chain" 2 0 -1)
|
||||
(MERGED "Includes other branches" 4 42405)
|
||||
(SELFRECURSIVE "Includes self-recursive calls" 2 61375)
|
||||
(RECURSIVE "Head of recursive chain" 4 28086)
|
||||
(ENDOFLINE "exceeded depth limit" 6 64510)))
|
||||
|
||||
(RPAQQ SPY.BUFFER.SIZE 5120)
|
||||
|
||||
(RPAQQ SPY.FRAGMENTS T)
|
||||
|
||||
(RPAQQ SPY.NOMERGEFNS (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER
|
||||
\INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
|
||||
(RPAQQ SPY.NOMERGEFNS (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER
|
||||
\INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
|
||||
|
||||
(RPAQQ SPY.MERGEINFO ((EXEC :EXEC)
|
||||
(EXEC-READ-LINE :EXEC)
|
||||
(EXEC-READ :EXEC)
|
||||
(XCL-USER::LEX-DO-EVENT :EXEC)
|
||||
(DO-EVENT :EXEC)
|
||||
(EVAL-INPUT :EXEC)
|
||||
(SI::*UNWIND-PROTECT* :ANY)
|
||||
(\MAKE.PROCESS0 T)
|
||||
(\PROC.REPEATEDLYEVALQT T)
|
||||
(\EVALFORM T :EVAL)
|
||||
(PROGN PROGN :EVAL T)
|
||||
(TTYIN1 TTYIN)
|
||||
(TTBIN TTYIN)
|
||||
(TTWAITFORINPUT TTYIN)
|
||||
(\PROGV :ANY)))
|
||||
(RPAQQ SPY.MERGEINFO
|
||||
((EXEC :EXEC)
|
||||
(EXEC-READ-LINE :EXEC)
|
||||
(EXEC-READ :EXEC)
|
||||
(XCL-USER::LEX-DO-EVENT :EXEC)
|
||||
(DO-EVENT :EXEC)
|
||||
(EVAL-INPUT :EXEC)
|
||||
(SI::*UNWIND-PROTECT* :ANY)
|
||||
(\MAKE.PROCESS0 T)
|
||||
(\PROC.REPEATEDLYEVALQT T)
|
||||
(\EVALFORM T :EVAL)
|
||||
(PROGN PROGN :EVAL T)
|
||||
(TTYIN1 TTYIN)
|
||||
(TTBIN TTYIN)
|
||||
(TTWAITFORINPUT TTYIN)
|
||||
(\PROGV :ANY)))
|
||||
|
||||
(RPAQQ SPY.HASH NIL)
|
||||
|
||||
@@ -102,19 +105,19 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
|
||||
(RPAQ? SPY.TREE )
|
||||
|
||||
(RPAQQ SPYOBJCOMS ((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX
|
||||
SPYOBJ.DISPLAY SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON
|
||||
SPY.MERGEINFO)
|
||||
[VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE]
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
|
||||
(INITRECORDS SPYOBJDATA)))
|
||||
(RPAQQ SPYOBJCOMS
|
||||
((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX SPYOBJ.DISPLAY
|
||||
SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON SPY.MERGEINFO)
|
||||
[VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE]
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
|
||||
(INITRECORDS SPYOBJDATA)))
|
||||
(DEFINEQ
|
||||
|
||||
(SPYOBJ
|
||||
@@ -176,148 +179,145 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
then '(:INTERPRETER CL:EVAL])
|
||||
)
|
||||
|
||||
(RPAQ SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE))
|
||||
(RPAQ SPYOBJ.IMAGEFNS
|
||||
(IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE))
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index")
|
||||
(BLOCKRECORD FXBLOCK ((FLAGS BITS 3) (* ; "= \STK.FX")
|
||||
(FAST FLAG)
|
||||
(NIL FLAG)
|
||||
(INCALL FLAG) (* ;
|
||||
"set when fncall microcode has to punt")
|
||||
(VALIDNAMETABLE FLAG)(* ;
|
||||
"if on, NAMETABLE field is filled in. If off, is same as FNHEADER")
|
||||
(NOPUSH FLAG) (* ;
|
||||
"when returning to this frame, don't push a value. Set by interrupt code")
|
||||
(USECNT BITS 8)
|
||||
(%#ALINK WORD) (* ; "low bit is SLOWP")
|
||||
(FNHEADER FULLXPOINTER)
|
||||
(NEXTBLOCK WORD)
|
||||
(PC WORD)
|
||||
(NAMETABLE# FULLXPOINTER)
|
||||
(%#BLINK WORD)
|
||||
(%#CLINK WORD)))
|
||||
(BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
|
||||
(NIL BYTE)
|
||||
(NIL BITS 15) (* ; "most of the bits of #ALINK")
|
||||
(SLOWP FLAG) (* ;
|
||||
"if on, then BLINK and CLINK fields are valid. If off, they are implicit")
|
||||
(NIL FULLXPOINTER 2)
|
||||
(NAMETABHI WORD)
|
||||
(NAMETABLO WORD)))
|
||||
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
|
||||
\STK.FX))
|
||||
[ACCESSFNS FX ((NAMETABLE (COND
|
||||
((fetch (FX VALIDNAMETABLE) of DATUM)
|
||||
(fetch (FX NAMETABLE#) of DATUM))
|
||||
(T (fetch (FX FNHEADER) of DATUM)))
|
||||
(PROGN (replace (FX FAST) of DATUM with NIL)
|
||||
(replace (FX NAMETABLE#) of DATUM with
|
||||
NEWVALUE)
|
||||
(replace (FX VALIDNAMETABLE) of DATUM
|
||||
with T)))
|
||||
(FRAMENAME (fetch (FNHEADER FRAMENAME)
|
||||
of (fetch (FX NAMETABLE) of DATUM)))
|
||||
(INVALIDP (EQ DATUM 0)) (* ;
|
||||
"true when A/CLink points at nobody, i.e. FX is bottom of stack")
|
||||
[FASTP (NOT (fetch (FX SLOWP) of DATUM))
|
||||
(PROGN (CHECK (NULL NEWVALUE))
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with
|
||||
T]
|
||||
[BLINK (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX DUMMYBF) of DATUM))
|
||||
(T (fetch (FX %#BLINK) of DATUM)))
|
||||
(PROGN (replace (FX %#BLINK) of DATUM with
|
||||
NEWVALUE)
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with
|
||||
T]
|
||||
[CLINK (IDIFFERENCE (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX %#ALINK) of DATUM))
|
||||
(T (fetch (FX %#CLINK) of DATUM)))
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN (replace (FX %#CLINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET))
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with
|
||||
T]
|
||||
[ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM)
|
||||
WORDSPERCELL)
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM]
|
||||
(replace (FX %#ALINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET
|
||||
(SUB1 WORDSPERCELL]
|
||||
[ACLINK (SHOULDNT)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM]
|
||||
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index")
|
||||
(BLOCKRECORD FXBLOCK ((FLAGS BITS 3) (* ; "= \STK.FX")
|
||||
(FAST FLAG)
|
||||
(NIL FLAG)
|
||||
(INCALL FLAG) (* ;
|
||||
"set when fncall microcode has to punt")
|
||||
(VALIDNAMETABLE FLAG) (* ;
|
||||
"if on, NAMETABLE field is filled in. If off, is same as FNHEADER")
|
||||
(NOPUSH FLAG) (* ;
|
||||
"when returning to this frame, don't push a value. Set by interrupt code")
|
||||
(USECNT BITS 8)
|
||||
(%#ALINK WORD) (* ; "low bit is SLOWP")
|
||||
(FNHEADER FULLXPOINTER)
|
||||
(NEXTBLOCK WORD)
|
||||
(PC WORD)
|
||||
(NAMETABLE# FULLXPOINTER)
|
||||
(%#BLINK WORD)
|
||||
(%#CLINK WORD)))
|
||||
(BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
|
||||
(NIL BYTE)
|
||||
(NIL BITS 15) (* ; "most of the bits of #ALINK")
|
||||
(SLOWP FLAG) (* ;
|
||||
"if on, then BLINK and CLINK fields are valid. If off, they are implicit")
|
||||
(NIL FULLXPOINTER 2)
|
||||
(NAMETABHI WORD)
|
||||
(NAMETABLO WORD)))
|
||||
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
|
||||
\STK.FX))
|
||||
[ACCESSFNS FX ((NAMETABLE (COND
|
||||
((fetch (FX VALIDNAMETABLE) of DATUM)
|
||||
(fetch (FX NAMETABLE#) of DATUM))
|
||||
(T (fetch (FX FNHEADER) of DATUM)))
|
||||
(PROGN (replace (FX FAST) of DATUM with NIL)
|
||||
(replace (FX NAMETABLE#) of DATUM with NEWVALUE)
|
||||
(replace (FX VALIDNAMETABLE) of DATUM with T)))
|
||||
(FRAMENAME (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE)
|
||||
of DATUM)))
|
||||
(INVALIDP (EQ DATUM 0)) (* ;
|
||||
"true when A/CLink points at nobody, i.e. FX is bottom of stack")
|
||||
[FASTP (NOT (fetch (FX SLOWP) of DATUM))
|
||||
(PROGN (CHECK (NULL NEWVALUE))
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET))
|
||||
(replace (FX %#ALINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET
|
||||
(SUB1 WORDSPERCELL]
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with T]
|
||||
[BLINK (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX DUMMYBF) of DATUM))
|
||||
(T (fetch (FX %#BLINK) of DATUM)))
|
||||
(PROGN (replace (FX %#BLINK) of DATUM with NEWVALUE)
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with T]
|
||||
[CLINK (IDIFFERENCE (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX %#ALINK) of DATUM))
|
||||
(T (fetch (FX %#CLINK) of DATUM)))
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN (replace (FX %#CLINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET)
|
||||
)
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with T]
|
||||
[ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM)
|
||||
WORDSPERCELL)
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM]
|
||||
(replace (FX %#ALINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET
|
||||
(SUB1
|
||||
WORDSPERCELL
|
||||
]
|
||||
[ACLINK (SHOULDNT)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM]
|
||||
(replace (FX %#CLINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET)
|
||||
)
|
||||
(replace (FX %#ALINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET
|
||||
(SUB1
|
||||
WORDSPERCELL
|
||||
]
|
||||
(* ;
|
||||
"replaces A & C Links at once more efficiently than separately")
|
||||
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
|
||||
"replaces A & C Links at once more efficiently than separately")
|
||||
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
|
||||
|
||||
(* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too.")
|
||||
(* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too.")
|
||||
|
||||
(IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF)
|
||||
of DATUM)))
|
||||
[CHECKED (AND (type? FX DATUM)
|
||||
(OR (IEQ (fetch (FX DUMMYBF) of DATUM)
|
||||
(fetch (FX BLINK) of DATUM))
|
||||
(AND (fetch (BF RESIDUAL)
|
||||
of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(IEQ (fetch (BF IVAR)
|
||||
of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(fetch (BF IVAR)
|
||||
of (fetch (FX BLINK)
|
||||
of DATUM]
|
||||
(FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T)))
|
||||
(IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF) of DATUM)))
|
||||
[CHECKED (AND (type? FX DATUM)
|
||||
(OR (IEQ (fetch (FX DUMMYBF) of DATUM)
|
||||
(fetch (FX BLINK) of DATUM))
|
||||
(AND (fetch (BF RESIDUAL) of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(IEQ (fetch (BF IVAR) of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(fetch (BF IVAR) of (fetch (FX BLINK)
|
||||
of DATUM]
|
||||
(FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T)))
|
||||
(* ; "stack offset of PVAR0")
|
||||
(FXSIZE (PROGN 10)) (* ;
|
||||
"fixed overhead from flags thru clink")
|
||||
(PADDING (PROGN 4)) (* ;
|
||||
"doublecell of garbage for microcode use")
|
||||
(FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM)
|
||||
(fetch (FX NPVARWORDS) of DATUM)
|
||||
(fetch (FX PADDING) of DATUM)))
|
||||
(FXSIZE (PROGN 10)) (* ;
|
||||
"fixed overhead from flags thru clink")
|
||||
(PADDING (PROGN 4)) (* ;
|
||||
"doublecell of garbage for microcode use")
|
||||
(FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM)
|
||||
(fetch (FX NPVARWORDS) of DATUM)
|
||||
(fetch (FX PADDING) of DATUM)))
|
||||
(* ;
|
||||
"note that NPVARWORDS is obtained from the FNHEADER")
|
||||
(SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM)
|
||||
DATUM])
|
||||
"note that NPVARWORDS is obtained from the FNHEADER")
|
||||
(SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM)
|
||||
DATUM])
|
||||
|
||||
(RECORD SPYOBJDATA (CACHEDLABEL PERCENT LABEL))
|
||||
)
|
||||
@@ -745,7 +745,9 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
", " TOPCOUNT " samples"])
|
||||
|
||||
(SPY.MAKE.TREE
|
||||
[LAMBDA (TREES SPYDATA WINDOW) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
|
||||
[LAMBDA (TREES SPYDATA WINDOW) (* ; "Edited 4-Jan-2022 14:08 by rmk")
|
||||
(* ;
|
||||
"Edited 28-Apr-94 13:59 by sybalsky")
|
||||
(PROG (GRAPH IDS W H THRSH TOPCOUNT (*PACKAGE* (fetch (SPYDATA PACKAGE) of SPYDATA))
|
||||
(*READTABLE* (fetch (SPYDATA READTABLE) of SPYDATA))
|
||||
(*PRINT-CASE* (fetch (SPYDATA PRINT-CASE) of SPYDATA)))
|
||||
@@ -755,8 +757,7 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
(SETQ THRSH (QUOTIENT (TIMES TOPCOUNT (fetch (SPYDATA THRESHOLD) of SPYDATA))
|
||||
100))
|
||||
(SETQ SPY.NODES)
|
||||
(SETQ SPY.TOPNODES (for X in TREES collect (SPY.MAKEGRAPHNODES X THRSH
|
||||
SPYDATA)))
|
||||
(SETQ SPY.TOPNODES (for X in TREES collect (SPY.MAKEGRAPHNODES X THRSH SPYDATA)))
|
||||
(SETQ TITLE (SPY.TITLE (CAR SPY.TOPNODES)
|
||||
TOPCOUNT SPYDATA))
|
||||
(SETQ SPY.WINDOW (SHOWGRAPH (LAYOUTGRAPH (REVERSE SPY.NODES)
|
||||
@@ -773,7 +774,8 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
(WINDOWPROP SPY.WINDOW 'SPYDATA SPYDATA)
|
||||
(WINDOWPROP SPY.WINDOW 'TREES TREES)
|
||||
(WINDOWPROP SPY.WINDOW 'SPYTITLE TITLE)
|
||||
(WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT])
|
||||
(WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT)
|
||||
(MODERNWINDOW SPY.WINDOW])
|
||||
|
||||
(SPY.UPDATE.TITLE
|
||||
[LAMBDA (W) (* ; "Edited 29-Apr-94 14:03 by sybalsky")
|
||||
@@ -965,23 +967,23 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS WITH-SPY MACRO ((FORM)
|
||||
(PUTPROPS WITH-SPY MACRO [(FORM)
|
||||
(PROGN (SPY.START)
|
||||
(PROG1 FORM (SPY.END]
|
||||
(PROG1 FORM (SPY.END])
|
||||
|
||||
[PUTPROPS WITH.SPY MACRO ((FORM)
|
||||
(PUTPROPS WITH.SPY MACRO [(FORM)
|
||||
(PROGN (SPY.START)
|
||||
(PROG1 FORM (SPY.END]
|
||||
(PROG1 FORM (SPY.END])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE SPYRECORD (NAME COUNT SUM CALLEES STATUS TREEFROM)
|
||||
STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT)))
|
||||
STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT)))
|
||||
|
||||
(PROPRECORD SPYDATA (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE
|
||||
READTABLE PRINT-CASE MERGEINFO PENDING)
|
||||
CUMULATIVE _ T)
|
||||
(PROPRECORD SPYDATA (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE READTABLE
|
||||
PRINT-CASE MERGEINFO PENDING)
|
||||
CUMULATIVE _ T)
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'SPYRECORD '(POINTER POINTER POINTER POINTER POINTER POINTER)
|
||||
@@ -1010,19 +1012,21 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
|
||||
(FILESLOAD GRAPHER READNUMBER IMAGEOBJ)
|
||||
)
|
||||
|
||||
(MOVD? 'NILL 'MODERNWINDOW)
|
||||
(PUTPROPS SPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1987 1988 1990 1991 1993 1994))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5474 8081 (SPYOBJ 5484 . 5773) (SPYOBJ.BUTTON 5775 . 5885) (SPYOBJ.SAVE 5887 . 6006) (
|
||||
SPYOBJ.COPY 6008 . 6070) (SPYOBJ.GET 6072 . 6201) (SPYOBJ.IMAGEBOX 6203 . 6727) (SPYOBJ.DISPLAY 6729
|
||||
. 7028) (SPYOBJ.LABEL 7030 . 7166) (SPYOBJ.HEIGHT 7168 . 7381) (SPYOBJ.COPYIN 7383 . 7426) (
|
||||
SPY.COPYBUTTON 7428 . 7520) (SPY.MERGEINFO 7522 . 8079)) (19431 60601 (SPY.FIND.TREE 19441 . 19850) (
|
||||
SPY.TOGGLE 19852 . 20042) (SPY.TREE 20044 . 21156) (SPY.LEGEND 21158 . 21508) (SPY.GRAPH.EDITOR 21510
|
||||
. 31075) (SPY.END 31077 . 31319) (SPY.MAKEGRAPHNODES 31321 . 33421) (SPY.MAX 33423 . 34306) (
|
||||
SPY.MERGE 34308 . 35739) (SPY.MERGE1 35741 . 42224) (SPY.MERGETREE 42226 . 45156) (SPY.NEXT.TREE 45158
|
||||
. 45832) (SPY.SUM 45834 . 46523) (SPY.TITLE 46525 . 46742) (SPY.MAKE.TREE 46744 . 48632) (
|
||||
SPY.UPDATE.TITLE 48634 . 51210) (SPY.DELETE 51212 . 51747) (SPY.DRAWBOX 51749 . 52274) (
|
||||
SPY.BUFFER.ENTRY 52276 . 52514) (SPY.BUTTON 52516 . 53085) (SPY.END.ENTRY 53087 . 53167) (SPY.START
|
||||
53169 . 53453) (SPY.INIT 53455 . 53690) (\SPY.INTERRUPT 53692 . 54328) (SPY.DUMP.BUFFER 54330 . 55790)
|
||||
(SPY.START.ENTRY 55792 . 55920) (SPY.ADD.ENTRY 55922 . 56304) (SPY.ORIGINAL 56306 . 57133) (
|
||||
SPY.OVERFLOW 57135 . 57236) (SPY.MERGE.CALLEES 57238 . 60274) (SPY.PRINT 60276 . 60599)))))
|
||||
(FILEMAP (NIL (4753 7360 (SPYOBJ 4763 . 5052) (SPYOBJ.BUTTON 5054 . 5164) (SPYOBJ.SAVE 5166 . 5285) (
|
||||
SPYOBJ.COPY 5287 . 5349) (SPYOBJ.GET 5351 . 5480) (SPYOBJ.IMAGEBOX 5482 . 6006) (SPYOBJ.DISPLAY 6008
|
||||
. 6307) (SPYOBJ.LABEL 6309 . 6445) (SPYOBJ.HEIGHT 6447 . 6660) (SPYOBJ.COPYIN 6662 . 6705) (
|
||||
SPY.COPYBUTTON 6707 . 6799) (SPY.MERGEINFO 6801 . 7358)) (18202 59509 (SPY.FIND.TREE 18212 . 18621) (
|
||||
SPY.TOGGLE 18623 . 18813) (SPY.TREE 18815 . 19927) (SPY.LEGEND 19929 . 20279) (SPY.GRAPH.EDITOR 20281
|
||||
. 29846) (SPY.END 29848 . 30090) (SPY.MAKEGRAPHNODES 30092 . 32192) (SPY.MAX 32194 . 33077) (
|
||||
SPY.MERGE 33079 . 34510) (SPY.MERGE1 34512 . 40995) (SPY.MERGETREE 40997 . 43927) (SPY.NEXT.TREE 43929
|
||||
. 44603) (SPY.SUM 44605 . 45294) (SPY.TITLE 45296 . 45513) (SPY.MAKE.TREE 45515 . 47540) (
|
||||
SPY.UPDATE.TITLE 47542 . 50118) (SPY.DELETE 50120 . 50655) (SPY.DRAWBOX 50657 . 51182) (
|
||||
SPY.BUFFER.ENTRY 51184 . 51422) (SPY.BUTTON 51424 . 51993) (SPY.END.ENTRY 51995 . 52075) (SPY.START
|
||||
52077 . 52361) (SPY.INIT 52363 . 52598) (\SPY.INTERRUPT 52600 . 53236) (SPY.DUMP.BUFFER 53238 . 54698)
|
||||
(SPY.START.ENTRY 54700 . 54828) (SPY.ADD.ENTRY 54830 . 55212) (SPY.ORIGINAL 55214 . 56041) (
|
||||
SPY.OVERFLOW 56043 . 56144) (SPY.MERGE.CALLEES 56146 . 59182) (SPY.PRINT 59184 . 59507)))))
|
||||
STOP
|
||||
|
||||
BIN
library/SPY.LCOM
BIN
library/SPY.LCOM
Binary file not shown.
104
library/TEDIT
104
library/TEDIT
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Dec-2021 12:34:26" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;21 142324
|
||||
(FILECREATED "30-Dec-2021 20:50:54" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;30 142870
|
||||
|
||||
:CHANGES-TO (FNS TEDIT-SEE)
|
||||
:CHANGES-TO (FNS TEDIT TEDIT-SEE)
|
||||
|
||||
:PREVIOUS-DATE "13-Oct-2021 10:00:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;20)
|
||||
:PREVIOUS-DATE "28-Dec-2021 11:02:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;24)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -250,21 +250,29 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
NIL])
|
||||
|
||||
(TEDIT
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 11-Jun-99 14:14 by rmk:")
|
||||
(* ; "Edited 11-Jun-99 14:13 by rmk:")
|
||||
(* ; "Edited 11-Jun-99 14:08 by rmk:")
|
||||
(* ; "Edited 3-Jun-88 14:27 by jds")
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 30-Dec-2021 20:50 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 00:12 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
(* ; "Edited 11-Jun-99 14:14 by rmk:")
|
||||
(* ; "Edited 3-Jun-88 14:27 by jds")
|
||||
|
||||
(* ;; "User entry to the text editor. Takes an optional window to be used for editing")
|
||||
(* ;; "User entry to the text editor. Takes an optional window to be used for editing")
|
||||
|
||||
(* ;; "DONTSPAWN => Don't try to create a new process for this edit.")
|
||||
(* ;; "DONTSPAWN => Don't try to create a new process for this edit.")
|
||||
|
||||
(PROG (PROC TEDITCREATEDWINDOW) (* ;
|
||||
"Include the default properties in the list.")
|
||||
(PROG (PROC TEDITCREATEDWINDOW) (* ;
|
||||
"Include the default properties in the list.")
|
||||
[COND
|
||||
((AND TEXT (ATOM TEXT)) (* ;
|
||||
"Make sure the file exists before trying to open the window.")
|
||||
((AND TEXT (ATOM TEXT)) (* ;
|
||||
"Make sure the file exists before trying to open the window.")
|
||||
(SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD '((TYPE TEXT]
|
||||
(CL:WHEN (AND WINDOW (OR (LITATOM WINDOW)
|
||||
(REGIONP WINDOW)))
|
||||
|
||||
(* ;; "Pass specified and typed regions to TEDIT.CREATEW")
|
||||
|
||||
(PUSH PROPS 'REGION-TYPE WINDOW)
|
||||
(SETQ WINDOW NIL))
|
||||
(RESETLST
|
||||
[RESETSAVE NIL `(AND ,WINDOW (WINDOWPROP ,WINDOW 'TEXTOBJ NIL]
|
||||
(WITH.MONITOR TEDIT.STARTUP.MONITORLOCK
|
||||
@@ -272,7 +280,8 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
((NOT WINDOW)
|
||||
(SETQ TEDITCREATEDWINDOW T)
|
||||
(SETQ WINDOW (COND
|
||||
[(OR (NOT TEDIT.DEFAULT.WINDOW)
|
||||
[(OR (LISTGET PROPS 'REGION-TYPE)
|
||||
(NOT TEDIT.DEFAULT.WINDOW)
|
||||
(\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW))
|
||||
(TEDIT.CREATEW (COND
|
||||
((AND TEXT (ATOM TEXT))
|
||||
@@ -288,28 +297,27 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
'REGION)
|
||||
TEXT
|
||||
(APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)))
|
||||
(* ; "Replace the old title")
|
||||
(* ; "Replace the old title")
|
||||
TEDIT.DEFAULT.WINDOW)))
|
||||
|
||||
(* ;;
|
||||
"Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")
|
||||
(* ;;
|
||||
"Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")
|
||||
|
||||
(* ;;
|
||||
"mark that we created the window so that we know we can update the title, etc.")
|
||||
(* ;;
|
||||
"mark that we created the window so that we know we can update the title, etc.")
|
||||
|
||||
(WINDOWPROP WINDOW 'TEXTOBJ T)))))
|
||||
[SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL (APPEND PROPS '(BEING-EDITED T]
|
||||
(* ;
|
||||
"Connect the editor to the window")
|
||||
(* ; "Connect the editor to the window")
|
||||
(replace (TEXTOBJ TXTEDITING) of (TEXTOBJ TEXT) with T)
|
||||
(* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")
|
||||
(* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")
|
||||
[COND
|
||||
(TEDITCREATEDWINDOW (TEXTPROP TEXT 'TEDITCREATEDWINDOW 'T]
|
||||
(COND
|
||||
(DONTSPAWN (* ;
|
||||
"Either no processes running, or specifically not to spawn one.")
|
||||
(DONTSPAWN (* ;
|
||||
"Either no processes running, or specifically not to spawn one.")
|
||||
(RETURN (\TEDIT2 TEXT WINDOW T)))
|
||||
(T (* ; "Spawn a process to do the edit.")
|
||||
(T (* ; "Spawn a process to do the edit.")
|
||||
[SETQ PROC (ADD.PROCESS (LIST '\TEDIT2 (KWOTE TEXT)
|
||||
WINDOW NIL)
|
||||
'NAME
|
||||
@@ -323,13 +331,14 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PROCESSPROP PROC 'WINDOW WINDOW)
|
||||
(COND
|
||||
((NOT (LISTGET (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS))
|
||||
'LEAVETTY)) (* ;
|
||||
"Unless he asked us to leave the tty where it is, TEdit should get it.")
|
||||
'LEAVETTY)) (* ;
|
||||
"Unless he asked us to leave the tty where it is, TEdit should get it.")
|
||||
(TTY.PROCESS PROC)))
|
||||
(RETURN PROC])
|
||||
|
||||
(TEDIT-SEE
|
||||
[LAMBDA (FILE WINDOW FORMAT TITLE) (* ; "Edited 16-Dec-2021 12:33 by rmk")
|
||||
[LAMBDA (FILE WINDOW FORMAT TITLE) (* ; "Edited 30-Dec-2021 18:03 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:33 by rmk")
|
||||
(* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
(* ; "Edited 1-Feb-88 19:00 by bvm:")
|
||||
@@ -362,11 +371,12 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CL:UNLESS (RANDACCESSP STREAM)
|
||||
(SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
|
||||
(COPYCHARS STREAM SEESTREAM)))
|
||||
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL `(READONLY T FONT ,DEFAULTFONT]
|
||||
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL
|
||||
`(READONLY T LEAVETTY T FONT ,DEFAULTFONT]
|
||||
[WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TITLE
|
||||
(OR TITLE (CONCAT "SEE window for " (FULLNAME STREAM]
|
||||
(FULLNAME STREAM])
|
||||
TSTREAM])
|
||||
|
||||
(TEDIT.CHARWIDTH
|
||||
[LAMBDA (CH FONT TERMSA) (* jds "22-OCT-83 19:32")
|
||||
@@ -2233,7 +2243,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* ; "TEDIT Support information")
|
||||
|
||||
|
||||
(RPAQQ TEDITSYSTEMDATE "16-Dec-2021 12:34:26")
|
||||
(RPAQQ TEDITSYSTEMDATE "30-Dec-2021 20:50:54")
|
||||
|
||||
(RPAQ TEDITSUPPORT "TEditSupport.PA")
|
||||
(DEFINEQ
|
||||
@@ -2259,19 +2269,19 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1992 1993 1995 1999 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4330 117494 (\TEDIT2 4340 . 7091) (COERCETEXTOBJ 7093 . 15869) (TEDIT 15871 . 20840) (
|
||||
TEDIT-SEE 20842 . 23170) (TEDIT.CHARWIDTH 23172 . 25196) (TEDIT.COPY 25198 . 33634) (TEDIT.DELETE
|
||||
33636 . 34326) (TEDIT.DO.BLUEPENDINGDELETE 34328 . 37395) (TEDIT.INSERT 37397 . 42927) (TEDIT.KILL
|
||||
42929 . 44486) (TEDIT.MAPLINES 44488 . 45887) (TEDIT.MAPPIECES 45889 . 46845) (TEDIT.MOVE 46847 .
|
||||
56631) (TEDIT.QUIT 56633 . 58633) (TEDIT.STRINGWIDTH 58635 . 59306) (TEDIT.\INSERT 59308 . 61333) (
|
||||
TEXTOBJ 61335 . 62460) (TEXTSTREAM 62462 . 64077) (\TEDIT.INCLUDE 64079 . 67979) (\TEDIT.INSERT.PIECES
|
||||
67981 . 77896) (\TEDIT.MOVE.PIECEMAPFN 77898 . 79977) (\TEDIT.OBJECT.SHOWSEL 79979 . 83608) (
|
||||
\TEDIT.RESTARTFN 83610 . 85605) (\TEDIT.CHARDELETE 85607 . 89569) (\TEDIT.COPY.PIECEMAPFN 89571 .
|
||||
92796) (\TEDIT.DELETE 92798 . 100316) (\TEDIT.DIFFUSE.PARALOOKS 100318 . 103082) (\TEDIT.FOREIGN.COPY?
|
||||
103084 . 106811) (\TEDIT.QUIT 106813 . 109959) (\TEDIT.WORDDELETE 109961 . 114794) (\TEDIT1 114796 .
|
||||
117492)) (117608 117724 (\CREATE.TEDIT.RESTART.MENU 117618 . 117722)) (117823 121512 (PLCHAIN 117833
|
||||
. 118107) (PRINTLINE 118109 . 120873) (SEEFILE 120875 . 121510)) (121553 141196 (TEDIT.INSERT.OBJECT
|
||||
121563 . 130640) (TEDIT.EDIT.OBJECT 130642 . 132898) (TEDIT.FIND.OBJECT 132900 . 133793) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 133795 . 134601) (TEDIT.PUT.OBJECT 134603 . 136262) (TEDIT.GET.OBJECT 136264
|
||||
. 139463) (TEDIT.OBJECT.CHANGED 139465 . 141194)) (141474 141837 (MAKETEDITFORM 141484 . 141835)))))
|
||||
(FILEMAP (NIL (4336 118040 (\TEDIT2 4346 . 7097) (COERCETEXTOBJ 7099 . 15875) (TEDIT 15877 . 21230) (
|
||||
TEDIT-SEE 21232 . 23716) (TEDIT.CHARWIDTH 23718 . 25742) (TEDIT.COPY 25744 . 34180) (TEDIT.DELETE
|
||||
34182 . 34872) (TEDIT.DO.BLUEPENDINGDELETE 34874 . 37941) (TEDIT.INSERT 37943 . 43473) (TEDIT.KILL
|
||||
43475 . 45032) (TEDIT.MAPLINES 45034 . 46433) (TEDIT.MAPPIECES 46435 . 47391) (TEDIT.MOVE 47393 .
|
||||
57177) (TEDIT.QUIT 57179 . 59179) (TEDIT.STRINGWIDTH 59181 . 59852) (TEDIT.\INSERT 59854 . 61879) (
|
||||
TEXTOBJ 61881 . 63006) (TEXTSTREAM 63008 . 64623) (\TEDIT.INCLUDE 64625 . 68525) (\TEDIT.INSERT.PIECES
|
||||
68527 . 78442) (\TEDIT.MOVE.PIECEMAPFN 78444 . 80523) (\TEDIT.OBJECT.SHOWSEL 80525 . 84154) (
|
||||
\TEDIT.RESTARTFN 84156 . 86151) (\TEDIT.CHARDELETE 86153 . 90115) (\TEDIT.COPY.PIECEMAPFN 90117 .
|
||||
93342) (\TEDIT.DELETE 93344 . 100862) (\TEDIT.DIFFUSE.PARALOOKS 100864 . 103628) (\TEDIT.FOREIGN.COPY?
|
||||
103630 . 107357) (\TEDIT.QUIT 107359 . 110505) (\TEDIT.WORDDELETE 110507 . 115340) (\TEDIT1 115342 .
|
||||
118038)) (118154 118270 (\CREATE.TEDIT.RESTART.MENU 118164 . 118268)) (118369 122058 (PLCHAIN 118379
|
||||
. 118653) (PRINTLINE 118655 . 121419) (SEEFILE 121421 . 122056)) (122099 141742 (TEDIT.INSERT.OBJECT
|
||||
122109 . 131186) (TEDIT.EDIT.OBJECT 131188 . 133444) (TEDIT.FIND.OBJECT 133446 . 134339) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 134341 . 135147) (TEDIT.PUT.OBJECT 135149 . 136808) (TEDIT.GET.OBJECT 136810
|
||||
. 140009) (TEDIT.OBJECT.CHANGED 140011 . 141740)) (142020 142383 (MAKETEDITFORM 142030 . 142381)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Sep-2021 15:33:24"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;10 106458
|
||||
|
||||
changes to%: (FNS TEDIT.HARDCOPYFN)
|
||||
(VARS TEDITHCPYCOMS)
|
||||
(FILECREATED "26-Jan-2022 23:03:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITHCPY.;15 106802
|
||||
|
||||
previous date%: "21-Sep-2021 12:54:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;7)
|
||||
:CHANGES-TO (VARS TEDITHCPYCOMS)
|
||||
|
||||
:PREVIOUS-DATE "27-Sep-2021 23:28:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITHCPY.;14)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -35,18 +34,18 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(VARS (TEDIT.DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 23495)))
|
||||
(* ;
|
||||
"0.75 inches from bottom, 1 from top")
|
||||
)
|
||||
"0.75 inches from bottom, 1 from top"))
|
||||
[COMS
|
||||
(* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.")
|
||||
|
||||
(FNS TEDIT.HARDCOPYFN \TEDIT.HARDCOPY \TEDIT.PRESS.HARDCOPY)
|
||||
(P (LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
|
||||
'TEDIT
|
||||
(FUNCTION \TEDIT.HARDCOPY)))
|
||||
[P (LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
|
||||
(COND (IPVALUES (* ;
|
||||
"Only install INTERPRESS printing if INTERPRESS is loaded.")
|
||||
(LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
|
||||
(P (LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
|
||||
(COND (PRESSVALUES (* ;
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
(LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
[COMS
|
||||
(* ;; "vars for Japanese Line Break")
|
||||
@@ -1568,14 +1567,16 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
PFILE)])
|
||||
)
|
||||
|
||||
(LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
|
||||
'TEDIT
|
||||
(FUNCTION \TEDIT.HARDCOPY))
|
||||
[LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
|
||||
(COND
|
||||
(IPVALUES (* ;
|
||||
"Only install INTERPRESS printing if INTERPRESS is loaded.")
|
||||
(LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
|
||||
|
||||
[LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
|
||||
(COND
|
||||
(PRESSVALUES (* ;
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
(LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
|
||||
|
||||
@@ -1616,11 +1617,11 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS TEDITHCPY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||
1991 1992 1993 1994 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3655 100373 (TEDIT.HARDCOPY 3665 . 4916) (TEDIT.HCPYFILE 4918 . 6992) (
|
||||
\TEDIT.HARDCOPY.DISPLAYLINE 6994 . 21139) (\TEDIT.HARDCOPY.FORMATLINE 21141 . 68463) (
|
||||
\DOFORMATTING.HARDCOPY 68465 . 81758) (\TEDIT.HARDCOPY.MODIFYLOOKS 81760 . 84167) (
|
||||
\TEDIT.HCPYLOOKS.UPDATE 84169 . 94777) (\TEDIT.HCPYFMTSPEC 94779 . 99799) (\TEDIT.INTEGER.IMAGEBOX
|
||||
99801 . 100371)) (100462 101546 (\TEDIT.SCALE 100472 . 100766) (\TEDIT.SCALEREGION 100768 . 101544)) (
|
||||
101789 104340 (TEDIT.HARDCOPYFN 101799 . 102704) (\TEDIT.HARDCOPY 102706 . 103615) (
|
||||
\TEDIT.PRESS.HARDCOPY 103617 . 104338)) (105405 106308 (TEDIT-BOOK 105415 . 106306)))))
|
||||
(FILEMAP (NIL (3784 100502 (TEDIT.HARDCOPY 3794 . 5045) (TEDIT.HCPYFILE 5047 . 7121) (
|
||||
\TEDIT.HARDCOPY.DISPLAYLINE 7123 . 21268) (\TEDIT.HARDCOPY.FORMATLINE 21270 . 68592) (
|
||||
\DOFORMATTING.HARDCOPY 68594 . 81887) (\TEDIT.HARDCOPY.MODIFYLOOKS 81889 . 84296) (
|
||||
\TEDIT.HCPYLOOKS.UPDATE 84298 . 94906) (\TEDIT.HCPYFMTSPEC 94908 . 99928) (\TEDIT.INTEGER.IMAGEBOX
|
||||
99930 . 100500)) (100591 101675 (\TEDIT.SCALE 100601 . 100895) (\TEDIT.SCALEREGION 100897 . 101673)) (
|
||||
101918 104469 (TEDIT.HARDCOPYFN 101928 . 102833) (\TEDIT.HARDCOPY 102835 . 103744) (
|
||||
\TEDIT.PRESS.HARDCOPY 103746 . 104467)) (105749 106652 (TEDIT-BOOK 105759 . 106650)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "29-Sep-2021 22:03:57"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;8 214517
|
||||
(FILECREATED "12-Jan-2022 18:56:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITSCREEN.;11 214540
|
||||
|
||||
changes to%: (FNS \DISPLAYLINE)
|
||||
:CHANGES-TO (FNS \SHOWTEXT)
|
||||
|
||||
previous date%: "21-Sep-2021 12:53:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;7)
|
||||
:PREVIOUS-DATE "12-Jan-2022 18:27:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITSCREEN.;10)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -1409,14 +1409,13 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS MI-TEDIT.BLTCHAR MACRO [(CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT
|
||||
CLIPRIGHT)
|
||||
(COND
|
||||
((EQ 'MAIKO (MACHINETYPE))
|
||||
(SUBRCALL TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
|
||||
(T (\TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT])
|
||||
(PUTPROPS MI-TEDIT.BLTCHAR MACRO [(CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT)
|
||||
(COND
|
||||
((EQ 'MAIKO (MACHINETYPE))
|
||||
(SUBRCALL TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX DISPLAYDATA
|
||||
DDPILOTBBT CLIPRIGHT))
|
||||
(T (\TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX DISPLAYDATA
|
||||
DDPILOTBBT CLIPRIGHT])
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -2212,53 +2211,58 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(\TEDIT.FIXINSSEL SEL TEXTOBJ CH#1 DCH])
|
||||
|
||||
(\SHOWTEXT
|
||||
[LAMBDA (TEXTOBJ LINES WINDOW) (* ; "Edited 12-Jun-90 19:22 by mitani")
|
||||
(* Fill the editor window with text,
|
||||
starting from the top of the file.)
|
||||
[LAMBDA (TEXTOBJ LINES WINDOW)
|
||||
|
||||
(* ;; "Edited 12-Jan-2022 18:56 by rmk: I took out the WAITINGCURSOR, the resetsave wasn't working for some reason, and it really isn't necessary for modern machines.")
|
||||
|
||||
(* ;; "Edited 12-Jun-90 19:22 by mitani")
|
||||
|
||||
(* ;; "Fill the editor window with text, starting from the top of the file.")
|
||||
|
||||
(COND
|
||||
((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (* If there is no edit window, just
|
||||
return.)
|
||||
(PROG (WREG)
|
||||
(SETQ WINDOW (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ)))
|
||||
(DSPFILL (PROG1 (DSPCLIPPINGREGION NIL WINDOW) (* For region within a window%:)
|
||||
(* (CREATEREGION (fetch
|
||||
(TEXTOBJ WLEFT) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)
|
||||
(IDIFFERENCE (fetch
|
||||
(TEXTOBJ WRIGHT) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ WLEFT) of TEXTOBJ))
|
||||
(IDIFFERENCE (fetch
|
||||
(TEXTOBJ WTOP) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))))
|
||||
)
|
||||
WHITESHADE
|
||||
'REPLACE WINDOW) (* Clear the window.)
|
||||
(RETURN (RESETLST
|
||||
(RESETSAVE (CURSOR WAITINGCURSOR)) (* Display the hourglass cursor as
|
||||
we work)
|
||||
(SETQ LINES
|
||||
(create LINEDESCRIPTOR
|
||||
YBOT _ (WINDOWPROP WINDOW 'HEIGHT)
|
||||
CHAR1 _ 0
|
||||
CHARLIM _ 0
|
||||
SPACELEFT _ -1
|
||||
RIGHTMARGIN _ (SUB1 (fetch (TEXTOBJ WRIGHT) of TEXTOBJ))
|
||||
NEXTLINE _ NIL
|
||||
CHARTOP _ -1
|
||||
LHEIGHT _ 0
|
||||
LXLIM _ (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)
|
||||
CR\END _ T
|
||||
ASCENT _ 0
|
||||
DESCENT _ 0
|
||||
LTRUEASCENT _ 0
|
||||
LFMTSPEC _ TEDIT.DEFAULT.FMTSPEC))
|
||||
(* Make sure we have the anchor
|
||||
pseudo-line)
|
||||
(WINDOWPROP WINDOW 'LINES LINES)
|
||||
(\FILLWINDOW (WINDOWPROP WINDOW 'HEIGHT)
|
||||
LINES TEXTOBJ NIL WINDOW) (* Fill the window as usual)
|
||||
(\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW)
|
||||
LINES)])
|
||||
((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (* ;
|
||||
"If there is no edit window, just return.")
|
||||
(PROG1 (PROG (WREG)
|
||||
(SETQ WINDOW (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ)))
|
||||
(DSPFILL (PROG1 (DSPCLIPPINGREGION NIL WINDOW)
|
||||
(* ; "For region within a window:")
|
||||
|
||||
(* ;; "(CREATEREGION (fetch (TEXTOBJ WLEFT) of TEXTOBJ) (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) (fetch (TEXTOBJ WLEFT) of TEXTOBJ)) (IDIFFERENCE (fetch (TEXTOBJ WTOP) of TEXTOBJ) (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)))")
|
||||
|
||||
)
|
||||
WHITESHADE
|
||||
'REPLACE WINDOW) (* ; "Clear the window.")
|
||||
(RETURN (RESETLST
|
||||
|
||||
(* ;; "RMK: For reasons unknown, the original cursor is not restored when this exits. But there is presumably no need for this waiting indicator in modern times. This only fills lines visible within a window, and machines are really fast.")
|
||||
|
||||
(* ;; "Display the hourglass cursor as we work")
|
||||
|
||||
(AND NIL (RESETSAVE (CURSOR WAITINGCURSOR)))
|
||||
(SETQ LINES
|
||||
(create LINEDESCRIPTOR
|
||||
YBOT _ (WINDOWPROP WINDOW 'HEIGHT)
|
||||
CHAR1 _ 0
|
||||
CHARLIM _ 0
|
||||
SPACELEFT _ -1
|
||||
RIGHTMARGIN _ (SUB1 (fetch (TEXTOBJ WRIGHT) of TEXTOBJ))
|
||||
NEXTLINE _ NIL
|
||||
CHARTOP _ -1
|
||||
LHEIGHT _ 0
|
||||
LXLIM _ (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)
|
||||
CR\END _ T
|
||||
ASCENT _ 0
|
||||
DESCENT _ 0
|
||||
LTRUEASCENT _ 0
|
||||
LFMTSPEC _ TEDIT.DEFAULT.FMTSPEC))
|
||||
(* ;
|
||||
"Make sure we have the anchor pseudo-line")
|
||||
(WINDOWPROP WINDOW 'LINES LINES)
|
||||
(\FILLWINDOW (WINDOWPROP WINDOW 'HEIGHT)
|
||||
LINES TEXTOBJ NIL WINDOW)
|
||||
(* ; "Fill the window as usual")
|
||||
(\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW)
|
||||
LINES)])
|
||||
|
||||
(\TEDIT.ADJUST.LINES
|
||||
[LAMBDA (TEXTOBJ FIRSTLINE WINDOW LINETOP DY) (* ; "Edited 30-May-91 15:59 by jds")
|
||||
@@ -2979,25 +2983,25 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
|
||||
|
||||
(* (VARS (TEDIT.DONT.BREAK.CHARS (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" "41,115"
|
||||
"41,133" "41,131" "41,127" "Hira,41" "Hira,43" "Hira,45" "Hira,47" "Hira,51" "Hira,103" "Hira,143"
|
||||
"Hira,145" "Hira,147" "Hira,156" "Kata,41" "Kata,43" "Kata,45" "Kata,47" "Kata,51" "Kata,103"
|
||||
"Kata,143" "Kata,145" "Kata,147" "Kata,156"))) (TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132"
|
||||
"41,130" "41,126"))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)))
|
||||
(* (VARS (TEDIT.DONT.BREAK.CHARS (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" "41,115" "41,133"
|
||||
"41,131" "41,127" "Hira,41" "Hira,43" "Hira,45" "Hira,47" "Hira,51" "Hira,103" "Hira,143" "Hira,145"
|
||||
"Hira,147" "Hira,156" "Kata,41" "Kata,43" "Kata,45" "Kata,47" "Kata,51" "Kata,103" "Kata,143"
|
||||
"Kata,145" "Kata,147" "Kata,156"))) (TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132" "41,130"
|
||||
"41,126"))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)))
|
||||
|
||||
(PUTPROPS TEDITSCREEN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||
1991 1992 1993 1994 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2767 76759 (\FORMATLINE 2777 . 56505) (\TEDIT.NSCHAR.RUN 56507 . 63324) (
|
||||
\TEDIT.PURGE.SPACES 63326 . 63784) (\DOFORMATTING 63786 . 76757)) (76760 98628 (\DISPLAYLINE 76770 .
|
||||
94628) (\TEDIT.LINECACHE 94630 . 95381) (\TEDIT.CREATE.LINECACHE 95383 . 96127) (\TEDIT.BLTCHAR 96129
|
||||
. 98626)) (99342 213797 (TEDIT.CR.UPDATESCREEN 99352 . 100603) (TEDIT.DELETELINE 100605 . 101639) (
|
||||
TEDIT.INSERT.DISPLAYTEXT 101641 . 116880) (TEDIT.INSERT.UPDATESCREEN 116882 . 123634) (
|
||||
TEDIT.UPDATE.SCREEN 123636 . 124854) (\BACKFORMAT 124856 . 129167) (\FILLWINDOW 129169 . 144273) (
|
||||
\FIXDLINES 144275 . 151512) (\FIXILINES 151514 . 159489) (\SHOWTEXT 159491 . 162747) (
|
||||
\TEDIT.ADJUST.LINES 162749 . 170216) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170218 . 170948) (
|
||||
\TEDIT.CLOSEUPLINES 170950 . 179466) (\TEDIT.COPY.LINEDESCRIPTOR 179468 . 185034) (
|
||||
\TEDIT.FIXCHANGEDLINE 185036 . 196215) (\TEDIT.FIXCHANGEDPART 196217 . 208644) (\TEDIT.INSERTLINE
|
||||
208646 . 209466) (\TEDIT.LINE.LIST 209468 . 209794) (\TEDIT.MARK.LINES.DIRTY 209796 . 211482) (
|
||||
\TEDIT.NEXT.LINE.BOTTOM 211484 . 213795)))))
|
||||
(FILEMAP (NIL (2761 76753 (\FORMATLINE 2771 . 56499) (\TEDIT.NSCHAR.RUN 56501 . 63318) (
|
||||
\TEDIT.PURGE.SPACES 63320 . 63778) (\DOFORMATTING 63780 . 76751)) (76754 98622 (\DISPLAYLINE 76764 .
|
||||
94622) (\TEDIT.LINECACHE 94624 . 95375) (\TEDIT.CREATE.LINECACHE 95377 . 96121) (\TEDIT.BLTCHAR 96123
|
||||
. 98620)) (99237 213820 (TEDIT.CR.UPDATESCREEN 99247 . 100498) (TEDIT.DELETELINE 100500 . 101534) (
|
||||
TEDIT.INSERT.DISPLAYTEXT 101536 . 116775) (TEDIT.INSERT.UPDATESCREEN 116777 . 123529) (
|
||||
TEDIT.UPDATE.SCREEN 123531 . 124749) (\BACKFORMAT 124751 . 129062) (\FILLWINDOW 129064 . 144168) (
|
||||
\FIXDLINES 144170 . 151407) (\FIXILINES 151409 . 159384) (\SHOWTEXT 159386 . 162770) (
|
||||
\TEDIT.ADJUST.LINES 162772 . 170239) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170241 . 170971) (
|
||||
\TEDIT.CLOSEUPLINES 170973 . 179489) (\TEDIT.COPY.LINEDESCRIPTOR 179491 . 185057) (
|
||||
\TEDIT.FIXCHANGEDLINE 185059 . 196238) (\TEDIT.FIXCHANGEDPART 196240 . 208667) (\TEDIT.INSERTLINE
|
||||
208669 . 209489) (\TEDIT.LINE.LIST 209491 . 209817) (\TEDIT.MARK.LINES.DIRTY 209819 . 211505) (
|
||||
\TEDIT.NEXT.LINE.BOTTOM 211507 . 213818)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Oct-2021 18:52:11"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;18 187780
|
||||
(FILECREATED "21-Jan-2022 23:14:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;32 189300
|
||||
|
||||
changes to%: (FNS TEDIT.DEACTIVATE.WINDOW)
|
||||
:CHANGES-TO (FNS TEDIT.GETINPUT)
|
||||
|
||||
previous date%: "12-Oct-2021 15:10:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;17)
|
||||
:PREVIOUS-DATE " 1-Jan-2022 23:55:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;31)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -34,7 +34,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(INITVARS (TEDIT.DEFAULT.WINDOW NIL))
|
||||
(GLOBALVARS TEDIT.DEFAULT.WINDOW)
|
||||
(COMS (* ;
|
||||
"User-level %"is this a TEdit window?%" function.")
|
||||
"User-level %"is this a TEdit window?%" function.")
|
||||
(FNS TEDITWINDOWP))
|
||||
(COMS (* ; "User-typein support")
|
||||
(FNS TEDIT.GETINPUT \TEDIT.MAKEFILENAME))
|
||||
@@ -51,8 +51,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(COMS (* ; "Process-world interfaces")
|
||||
(FNS \TEDIT.PROCIDLEFN \TEDIT.PROCENTRYFN \TEDIT.PROCEXITFN))
|
||||
(COMS (INITVARS (\CARETRATE 333))
|
||||
(* ;
|
||||
"Caret handler; stolen from CHAT.")
|
||||
(* ; "Caret handler; stolen from CHAT.")
|
||||
(FNS \EDIT.DOWNCARET \EDIT.FLIPCARET TEDIT.FLASHCARET \EDIT.UPCARET
|
||||
TEDIT.NORMALIZECARET \SETCARET \TEDIT.CARET))
|
||||
[COMS (* ; "Menu interfacing")
|
||||
@@ -89,15 +88,15 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(INITVARS (TEDIT.ICON.FONT (FONTCREATE 'HELVETICA 8 'BOLD))
|
||||
[TEDIT.ICON.TITLE.REGION (CONS 16 (CONS 4 (CONS 64 (CONS 77 NIL]
|
||||
(* ;
|
||||
"Original was (create REGION BOTTOM _ 4 LEFT _ 16 WIDTH _ 64 HEIGHT _ 77).")
|
||||
"Original was (create REGION BOTTOM _ 4 LEFT _ 16 WIDTH _ 64 HEIGHT _ 77).")
|
||||
(* ;
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
[TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS
|
||||
TEDIT.ICON.TITLE.REGION
|
||||
NIL]
|
||||
(* ; "Original was (create TITLEDICON ICON _ TEDITICON MASK _ TEDITMASK TITLEREG _ TEDIT.ICON.TITLE.REGION).")
|
||||
(* ;
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
])
|
||||
|
||||
(FILESLOAD TEDITDCL)
|
||||
@@ -119,27 +118,53 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(DEFINEQ
|
||||
|
||||
(TEDIT.CREATEW
|
||||
[LAMBDA (PROMPT FILE PROPS) (* jds "23-May-85 15:19")
|
||||
[LAMBDA (PROMPT FILE PROPS) (* ; "Edited 1-Jan-2022 23:54 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 23:00 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 16:35 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
(* ; "Edited 27-Oct-2021 12:25 by rmk:")
|
||||
|
||||
(* ;; "RMK: PROPS are passed to CREATEW and \TEDIT.ORIGINAL.WINDOW.TITLE. .")
|
||||
|
||||
(* ;;
|
||||
"RMK: If PROMPTWINDOW is in PROPS, I don't see how it gets attached to the new Tedit window.")
|
||||
|
||||
(* ;;
|
||||
"Also odd: The argument PROMPT gets printed, but then gets replaced by the property PROMPT")
|
||||
|
||||
(* ;; "Don't set the global TEDIT default window if we have a region property, that must be special purpose.")
|
||||
(* jds "23-May-85 15:19")
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW PROMPT T)
|
||||
(PROG ((PROMPT (LISTGET PROPS 'PROMPTWINDOW))
|
||||
(PHEIGHT 0)
|
||||
PWINDOW REGION)
|
||||
[COND
|
||||
((EQ PROMPT 'DON'T))
|
||||
(PROMPT)
|
||||
(T (SETQ PHEIGHT (HEIGHTIFWINDOW (ITIMES (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
(FONTPROP TEDIT.PROMPT.FONT 'HEIGHT]
|
||||
(SETQ REGION (GETREGION 32 (IPLUS PHEIGHT 32)))
|
||||
(add (fetch HEIGHT of REGION)
|
||||
(IMINUS PHEIGHT))
|
||||
(SETQ TEDIT.DEFAULT.WINDOW (CREATEW REGION (\TEDIT.ORIGINAL.WINDOW.TITLE FILE)))
|
||||
(CLRPROMPT)
|
||||
(OR PROMPT (GETPROMPTWINDOW TEDIT.DEFAULT.WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
TEDIT.PROMPT.FONT)))
|
||||
TEDIT.DEFAULT.WINDOW])
|
||||
(LET ((PROMPT (LISTGET PROPS 'PROMPTWINDOW))
|
||||
(PHEIGHT 0)
|
||||
REGION
|
||||
(REGIONTYPE (LISTGET PROPS 'REGION-TYPE))
|
||||
WINDOW)
|
||||
|
||||
(* ;; "All this prompt-height calculation would be unnecessary if the attachment in GETPROMPTWINDOW does the proper shrinking of the main window.")
|
||||
|
||||
[COND
|
||||
((EQ PROMPT 'DON'T))
|
||||
[PROMPT (CL:WHEN (WINDOWP PROMPT) (* ;
|
||||
"RMK: If not a window, PHEIGHT remains 0")
|
||||
(SETQ PHEIGHT (FETCH (REGION HEIGHT) OF (WINDOWREGION PROMPT))))]
|
||||
(T (SETQ PHEIGHT (HEIGHTIFWINDOW (ITIMES (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
(FONTPROP TEDIT.PROMPT.FONT 'HEIGHT]
|
||||
(SETQ REGION (OR (REGIONP REGIONTYPE)
|
||||
(GETREGION 32 (IPLUS PHEIGHT 32)
|
||||
REGIONTYPE)))
|
||||
(add (fetch HEIGHT of REGION)
|
||||
(IMINUS PHEIGHT))
|
||||
(SETQ WINDOW (CREATEW REGION (\TEDIT.ORIGINAL.WINDOW.TITLE FILE NIL PROPS)
|
||||
NIL NIL PROPS))
|
||||
(WINDOWPROP WINDOW 'TEDITCREATED T)
|
||||
(OR PROMPT (GETPROMPTWINDOW WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
TEDIT.PROMPT.FONT))
|
||||
(CL:UNLESS REGIONTYPE (SETQ TEDIT.DEFAULT.WINDOW WINDOW))
|
||||
WINDOW])
|
||||
|
||||
(\TEDIT.CREATEW.FROM.REGION
|
||||
[LAMBDA (REGION FILE PROPS) (* gbn "15-Nov-84 18:04")
|
||||
@@ -1446,7 +1471,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(DEFINEQ
|
||||
|
||||
(TEDIT.GETINPUT
|
||||
[LAMBDA (STREAM PROMPTSTRING DEFAULTSTRING DELIMITER.LIST)
|
||||
[LAMBDA (STREAM PROMPTSTRING DEFAULTSTRING DELIMITER.LIST) (* ; "Edited 21-Jan-2022 23:14 by rmk")
|
||||
(* ; "Edited 30-May-91 23:34 by jds")
|
||||
|
||||
(* ;; "Ask for input (file names, &c) for TEdit, perhaps with a default.")
|
||||
@@ -1462,20 +1487,20 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
TPROMPT))
|
||||
(COND
|
||||
(TPROMPT (* ;
|
||||
"If it's our own promptwindow, just clear it.")
|
||||
"If it's our own promptwindow, just clear it.")
|
||||
(CLEARW TPROMPT))
|
||||
(T (* ;
|
||||
"If it's the system's window, just move to a new line.")
|
||||
"If it's the system's window, just move to a new line.")
|
||||
(FRESHLINE PROMPTWINDOW)))
|
||||
(RETURN (PROG1 (PROMPTFORWORD PROMPTSTRING DEFAULTSTRING NIL (OR TPROMPT PROMPTWINDOW)
|
||||
(RETURN (PROG1 (TTYINPROMPTFORWORD PROMPTSTRING DEFAULTSTRING NIL (OR TPROMPT PROMPTWINDOW
|
||||
)
|
||||
NIL
|
||||
'TTY
|
||||
(OR DELIMITER.LIST (CHARCODE (EOL LF TAB ESCAPE)))
|
||||
NIL) (* ;
|
||||
"Get what the guy wants to tell us")
|
||||
NIL) (* ; "Get what the guy wants to tell us")
|
||||
(WINDOWPROP (OR TPROMPT PROMPTWINDOW)
|
||||
'PROCESS NIL) (* ;
|
||||
"Now detach the prompt window from its process, to avoid a circularity.")
|
||||
"Now detach the prompt window from its process, to avoid a circularity.")
|
||||
)])
|
||||
|
||||
(\TEDIT.MAKEFILENAME
|
||||
@@ -1627,43 +1652,36 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
""])
|
||||
|
||||
(\TEDIT.ORIGINAL.WINDOW.TITLE
|
||||
[LAMBDA (FILE DIRTY?) (* ; "Edited 24-Aug-2021 23:25 by rmk:")
|
||||
[LAMBDA (FILE DIRTY? PROPS) (* ; "Edited 27-Oct-2021 12:25 by rmk:")
|
||||
(* ; "Edited 24-Aug-2021 23:25 by rmk:")
|
||||
|
||||
(* ;; "Given a file name, derive a title for the TEdit window that is editing it.")
|
||||
(* ;; "Given a file name, derive a title for the TEdit window that is editing it. RMK: Title may be provided in a property")
|
||||
|
||||
(PROG (TITLE)
|
||||
(RETURN (COND
|
||||
((NULL FILE) (* ;
|
||||
"Just calling (TEDIT) should give a 'Text Editor Window'")
|
||||
(CONCAT (COND
|
||||
(DIRTY? "* ")
|
||||
(T ""))
|
||||
(LET (TITLE)
|
||||
[SETQ TITLE (COND
|
||||
((LISTGET PROPS 'TITLE))
|
||||
((NULL FILE) (* ;
|
||||
"Just calling (TEDIT) should give a 'Text Editor Window'")
|
||||
"Text Editor Window")
|
||||
((AND (STRINGP FILE)
|
||||
(ZEROP (NCHARS FILE))) (* ;
|
||||
"So should editing an empty string")
|
||||
"Text Editor Window")
|
||||
((WINDOWP FILE) (* ;
|
||||
"if \TEDIT.WINDOW.SETUP has assigned a title, use it")
|
||||
(OR (WINDOWPROP FILE 'TITLE)
|
||||
"Text Editor Window"))
|
||||
((AND (STRINGP FILE)
|
||||
(ZEROP (NCHARS FILE))) (* ;
|
||||
"So should editing an empty string")
|
||||
(CONCAT (COND
|
||||
(DIRTY? "* ")
|
||||
(T ""))
|
||||
"Text Editor Window"))
|
||||
((WINDOWP FILE)
|
||||
(COND
|
||||
((SETQ TITLE (WINDOWPROP FILE 'TITLE))
|
||||
(* ;
|
||||
"if \TEDIT.WINDOW.SETUP has assigned a title, use it")
|
||||
TITLE)
|
||||
(T "Text Editor Window")))
|
||||
(T (* ;
|
||||
"Strings use the string itself, otherwise grab the full file name.")
|
||||
(CONCAT (COND
|
||||
(DIRTY? "* ")
|
||||
(T ""))
|
||||
"Edit Window for: "
|
||||
(CL:TYPECASE FILE
|
||||
(STRINGP FILE)
|
||||
(STREAM (fetch (STREAM FULLNAME) of FILE))
|
||||
(LITATOM FILE)
|
||||
(T FILE))])
|
||||
(T (* ;
|
||||
"Strings use the string itself, otherwise grab the full file name.")
|
||||
(CONCAT "Edit Window for: " (CL:TYPECASE FILE
|
||||
(STRINGP FILE)
|
||||
(STREAM (fetch (STREAM FULLNAME)
|
||||
of FILE))
|
||||
(LITATOM FILE)
|
||||
(T FILE))]
|
||||
(COND
|
||||
(DIRTY? (CONCAT "* " TITLE))
|
||||
(T TITLE])
|
||||
|
||||
(\TEDIT.WINDOW.TITLE
|
||||
[LAMBDA (TEXTSTREAM NEW.TITLE) (* jds "23-May-85 15:20")
|
||||
@@ -2851,30 +2869,30 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
|
||||
(RPAQ? TEDIT.ICON.TITLE.REGION [CONS 16 (CONS 4 (CONS 64 (CONS 77 NIL])
|
||||
|
||||
(RPAQ? TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS TEDIT.ICON.TITLE.REGION
|
||||
NIL))))
|
||||
(RPAQ? TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS TEDIT.ICON.TITLE.REGION NIL))
|
||||
))
|
||||
(PUTPROPS TEDITWINDOW COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988
|
||||
1989 1990 1991 1993 1994 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7291 94107 (TEDIT.CREATEW 7301 . 8437) (\TEDIT.CREATEW.FROM.REGION 8439 . 9423) (
|
||||
TEDIT.CURSORMOVEDFN 9425 . 20811) (TEDIT.CURSOROUTFN 20813 . 21348) (TEDIT.WINDOW.SETUP 21350 . 23159)
|
||||
(TEDIT.MINIMAL.WINDOW.SETUP 23161 . 30950) (\TEDIT.ACTIVE.WINDOWP 30952 . 31933) (
|
||||
\TEDIT.BUTTONEVENTFN 31935 . 56925) (\TEDIT.WINDOW.OPS 56927 . 60888) (\TEDIT.EXPANDFN 60890 . 61293)
|
||||
(\TEDIT.MAINW 61295 . 62584) (\TEDIT.PRIMARYW 62586 . 63798) (\TEDIT.COPYINSERTFN 63800 . 64771) (
|
||||
\TEDIT.NEWREGIONFN 64773 . 67240) (\TEDIT.SET.WINDOW.EXTENT 67242 . 73344) (\TEDIT.SHRINK.ICONCREATE
|
||||
73346 . 75618) (\TEDIT.SHRINKFN 75620 . 76195) (\TEDIT.SPLITW 76197 . 82298) (\TEDIT.UNSPLITW 82300 .
|
||||
87994) (\TEDIT.WINDOW.SETUP 87996 . 93716) (\SAFE.FIRST 93718 . 94105)) (95437 96344 (TEDITWINDOWP
|
||||
95447 . 96342)) (96381 98877 (TEDIT.GETINPUT 96391 . 98374) (\TEDIT.MAKEFILENAME 98376 . 98875)) (
|
||||
98926 105377 (TEDIT.PROMPTPRINT 98936 . 101840) (TEDIT.PROMPTFLASH 101842 . 103797) (
|
||||
\TEDIT.PROMPT.PAGEFULLFN 103799 . 105375)) (105612 109674 (TEXTSTREAM.TITLE 105622 . 106243) (
|
||||
\TEDIT.ORIGINAL.WINDOW.TITLE 106245 . 108290) (\TEDIT.WINDOW.TITLE 108292 . 108962) (
|
||||
\TEXTSTREAM.FILENAME 108964 . 109672)) (109717 154616 (TEDIT.DEACTIVATE.WINDOW 109727 . 117034) (
|
||||
\TEDIT.REPAINTFN 117036 . 119893) (\TEDIT.RESHAPEFN 119895 . 125515) (\TEDIT.SCROLLFN 125517 . 154614)
|
||||
) (154658 156707 (\TEDIT.PROCIDLEFN 154668 . 156017) (\TEDIT.PROCENTRYFN 156019 . 156312) (
|
||||
\TEDIT.PROCEXITFN 156314 . 156705)) (156786 167786 (\EDIT.DOWNCARET 156796 . 157477) (\EDIT.FLIPCARET
|
||||
157479 . 159014) (TEDIT.FLASHCARET 159016 . 160130) (\EDIT.UPCARET 160132 . 160585) (
|
||||
TEDIT.NORMALIZECARET 160587 . 166538) (\SETCARET 166540 . 167460) (\TEDIT.CARET 167462 . 167784)) (
|
||||
167820 181575 (TEDIT.ADD.MENUITEM 167830 . 169745) (TEDIT.DEFAULT.MENUFN 169747 . 179014) (
|
||||
TEDIT.REMOVE.MENUITEM 179016 . 180017) (\TEDIT.CREATEMENU 180019 . 180472) (\TEDIT.MENU.WHENHELDFN
|
||||
180474 . 181244) (\TEDIT.MENU.WHENSELECTEDFN 181246 . 181573)))))
|
||||
(FILEMAP (NIL (7221 95655 (TEDIT.CREATEW 7231 . 9985) (\TEDIT.CREATEW.FROM.REGION 9987 . 10971) (
|
||||
TEDIT.CURSORMOVEDFN 10973 . 22359) (TEDIT.CURSOROUTFN 22361 . 22896) (TEDIT.WINDOW.SETUP 22898 . 24707
|
||||
) (TEDIT.MINIMAL.WINDOW.SETUP 24709 . 32498) (\TEDIT.ACTIVE.WINDOWP 32500 . 33481) (
|
||||
\TEDIT.BUTTONEVENTFN 33483 . 58473) (\TEDIT.WINDOW.OPS 58475 . 62436) (\TEDIT.EXPANDFN 62438 . 62841)
|
||||
(\TEDIT.MAINW 62843 . 64132) (\TEDIT.PRIMARYW 64134 . 65346) (\TEDIT.COPYINSERTFN 65348 . 66319) (
|
||||
\TEDIT.NEWREGIONFN 66321 . 68788) (\TEDIT.SET.WINDOW.EXTENT 68790 . 74892) (\TEDIT.SHRINK.ICONCREATE
|
||||
74894 . 77166) (\TEDIT.SHRINKFN 77168 . 77743) (\TEDIT.SPLITW 77745 . 83846) (\TEDIT.UNSPLITW 83848 .
|
||||
89542) (\TEDIT.WINDOW.SETUP 89544 . 95264) (\SAFE.FIRST 95266 . 95653)) (96985 97892 (TEDITWINDOWP
|
||||
96995 . 97890)) (97929 100502 (TEDIT.GETINPUT 97939 . 99999) (\TEDIT.MAKEFILENAME 100001 . 100500)) (
|
||||
100551 107002 (TEDIT.PROMPTPRINT 100561 . 103465) (TEDIT.PROMPTFLASH 103467 . 105422) (
|
||||
\TEDIT.PROMPT.PAGEFULLFN 105424 . 107000)) (107237 111230 (TEXTSTREAM.TITLE 107247 . 107868) (
|
||||
\TEDIT.ORIGINAL.WINDOW.TITLE 107870 . 109846) (\TEDIT.WINDOW.TITLE 109848 . 110518) (
|
||||
\TEXTSTREAM.FILENAME 110520 . 111228)) (111273 156172 (TEDIT.DEACTIVATE.WINDOW 111283 . 118590) (
|
||||
\TEDIT.REPAINTFN 118592 . 121449) (\TEDIT.RESHAPEFN 121451 . 127071) (\TEDIT.SCROLLFN 127073 . 156170)
|
||||
) (156214 158263 (\TEDIT.PROCIDLEFN 156224 . 157573) (\TEDIT.PROCENTRYFN 157575 . 157868) (
|
||||
\TEDIT.PROCEXITFN 157870 . 158261)) (158342 169342 (\EDIT.DOWNCARET 158352 . 159033) (\EDIT.FLIPCARET
|
||||
159035 . 160570) (TEDIT.FLASHCARET 160572 . 161686) (\EDIT.UPCARET 161688 . 162141) (
|
||||
TEDIT.NORMALIZECARET 162143 . 168094) (\SETCARET 168096 . 169016) (\TEDIT.CARET 169018 . 169340)) (
|
||||
169376 183131 (TEDIT.ADD.MENUITEM 169386 . 171301) (TEDIT.DEFAULT.MENUFN 171303 . 180570) (
|
||||
TEDIT.REMOVE.MENUITEM 180572 . 181573) (\TEDIT.CREATEMENU 181575 . 182028) (\TEDIT.MENU.WHENHELDFN
|
||||
182030 . 182800) (\TEDIT.MENU.WHENSELECTEDFN 182802 . 183129)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,43 +1,73 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 5-Sep-2020 19:02:30"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;3 20197
|
||||
|
||||
changes to%: (FNS \CS.COMPARE.MASTERS)
|
||||
(FILECREATED "25-Jan-2022 16:05:14" {MM}<lispusers>COMPARESOURCES.;115 41781
|
||||
|
||||
previous date%: "19-Apr-2018 10:50:03"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;2)
|
||||
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN)
|
||||
|
||||
:PREVIOUS-DATE "24-Jan-2022 23:12:17" {MM}<lispusers>COMPARESOURCES.;113)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPARESOURCESCOMS)
|
||||
|
||||
(RPAQQ COMPARESOURCESCOMS
|
||||
((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1
|
||||
\CS.FILTER.GARBAGE)
|
||||
(FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM
|
||||
\CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS
|
||||
\CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS)
|
||||
((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.EXAMINE \CS.FIXFNS
|
||||
\CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE)
|
||||
(FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM
|
||||
\CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM
|
||||
\CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM
|
||||
\CS.COMPARE.FPKGCOMS \CS.COMPARE.DEFINE-FILE-INFO)
|
||||
[COMS (FNS CSOBJ.CREATE CSOBJ.DISPLAYFN CSOBJ.IMAGEBOXFN CSOBJ.BUTTONEVENTINFN
|
||||
CSOBJ.COPYBUTTONEVENTINFN)
|
||||
(INITVARS (COMPARESOURCES-IMAGEFNS (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN
|
||||
NIL NIL NIL 'CSOBJ.BUTTONEVENTINFN
|
||||
'CSOBJ.COPYBUTTONEVENTINFN]
|
||||
(VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS)
|
||||
(COMS (FNS CSBROWSER)
|
||||
(INITVARS (COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW))
|
||||
(FILES (SYSLOAD)
|
||||
OBJECTWINDOW EXAMINEDEFS REGIONMANAGER))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE)
|
||||
(GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS))))
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARESOURCES
|
||||
[LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 19-Apr-2018 10:49 by rmk:")
|
||||
[LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 26-Dec-2021 21:32 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 09:51 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 23:13 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 19:54 by rmk")
|
||||
(* ; "Edited 23-Nov-2021 19:46 by rmk:")
|
||||
(* ; "Edited 30-Oct-2021 20:13 by rmk:")
|
||||
(* ; "Edited 19-Apr-2018 10:49 by rmk:")
|
||||
|
||||
(* ;;; "Compare two lisp source files, reporting differences.")
|
||||
(* ;;; "Compare two lisp source files, reporting differences. LISTSTREAM if given is an open stream")
|
||||
|
||||
(DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES))
|
||||
(PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY)
|
||||
[SETQ FILEX (OR (FINDFILE FILEX T)
|
||||
(RETURN (printout LISTSTREAM FILEX " not found" T]
|
||||
[SETQ FILEY (OR (FINDFILE FILEY T)
|
||||
(RETURN (printout LISTSTREAM FILEY " not found" T]
|
||||
(PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY DATECOL
|
||||
[INSERTOBJECTS (AND EXAMINE (IF (TEXTSTREAMP LISTSTREAM)
|
||||
THEN 'TEDIT
|
||||
ELSEIF (OBJWINDOWP LISTSTREAM)
|
||||
THEN 'OBJECTWINDOW]
|
||||
(COMPARESTREAM LISTSTREAM)
|
||||
(CONTEXTSTREAM LISTSTREAM)
|
||||
OBJECTS)
|
||||
(DECLARE (SPECVARS INSERTOBJECTS OBJECTABLE))
|
||||
(CL:WHEN INSERTOBJECTS
|
||||
(SETQ COMPARESTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
|
||||
(SETQ CONTEXTSTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
|
||||
(LINELENGTH 65535 COMPARESTREAM) (* ; "Let the receiver do the wrapping")
|
||||
(LINELENGTH 65535 CONTEXTSTREAM))
|
||||
(OR (INFILEP FILEX)
|
||||
(SETQ FILEX (FINDFILE FILEX T))
|
||||
(RETURN (printout CONTEXTSTREAM FILEX " not found" T)))
|
||||
(OR (INFILEP FILEY)
|
||||
(SETQ FILEY (FINDFILE FILEY T))
|
||||
(RETURN (printout CONTEXTSTREAM FILEY " not found" T)))
|
||||
|
||||
(* ;; "Read the two files, throwing out extraneous forms & such:")
|
||||
(* ;; "Read the two files, throwing out extraneous forms & such:")
|
||||
|
||||
(CL:MULTIPLE-VALUE-SETQ (BODYX ENVX)
|
||||
(READFILE FILEX))
|
||||
@@ -45,186 +75,324 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(CL:MULTIPLE-VALUE-SETQ (BODYY ENVY)
|
||||
(READFILE FILEY))
|
||||
(SETQ BODYY (\CS.FILTER.GARBAGE BODYY))
|
||||
(printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE)
|
||||
" and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE)
|
||||
":" T T)
|
||||
[SETQ DATECOL (PLUS 2 (CONSTANT (NCHARS "Comparing"))
|
||||
(IMAX (NCHARS FILEX)
|
||||
(NCHARS FILEY]
|
||||
(printout CONTEXTSTREAM "Comparing " FILEX .TAB0 DATECOL "dated " (GETFILEINFO FILEX
|
||||
'CREATIONDATE)
|
||||
.TAB
|
||||
[SUB1 (CONSTANT (IDIFFERENCE (NCHARS "Comparing ")
|
||||
(NCHARS "and "]
|
||||
" and " FILEY .TAB0 DATECOL "dated " (GETFILEINFO FILEY 'CREATIONDATE)
|
||||
T T)
|
||||
[SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR)
|
||||
'DECLARE%:]
|
||||
'DECLARE%:]
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX))
|
||||
[SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR)
|
||||
'DECLARE%:]
|
||||
'DECLARE%:]
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY))
|
||||
(WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT))
|
||||
(\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM)
|
||||
(\CS.COMPARE.MASTERS BODYX BODYY DW? CONTEXTSTREAM COMPARESTREAM)
|
||||
|
||||
(* ;; "Done with the non-DECLARE: expressions. Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare")
|
||||
(* ;; "Done with the non-DECLARE: expressions. Nw sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare")
|
||||
|
||||
(SETQ BODYX (\CS.SORT.DECLARES DECLAREX))
|
||||
(SETQ BODYY (\CS.SORT.DECLARES DECLAREY))
|
||||
[SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y))
|
||||
unless (SASSOC (CAR Y)
|
||||
BODYX]
|
||||
(* ;
|
||||
"Add placeholders for any declaration types in Y not in X to simplify what follows")
|
||||
BODYX]
|
||||
(* ;
|
||||
"Add placeholders for any declaration types in Y not in X to simplify what follows")
|
||||
[for X in BODYX bind Y TYPE
|
||||
do (SETQ Y (SASSOC (CAR X)
|
||||
BODYY))
|
||||
(SETQ TYPE (CAR X))
|
||||
[SETQ X (LDIFFERENCE (CDR X)
|
||||
(PROG1 (CDR Y)
|
||||
(SETQ Y (LDIFFERENCE (CDR Y)
|
||||
X)))]
|
||||
(COND
|
||||
((OR X Y)
|
||||
(printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
|
||||
BODYY))
|
||||
(SETQ TYPE (CAR X))
|
||||
(SETQ X (CL:SET-DIFFERENCE (CDR X)
|
||||
(PROG1 (CDR Y)
|
||||
(SETQ Y (CL:SET-DIFFERENCE (CDR Y)
|
||||
X :TEST (FUNCTION EQUALALL))))
|
||||
:TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
((OR X Y)
|
||||
(printout CONTEXTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
|
||||
CL:SET-DIFFERENCE
|
||||
TYPE
|
||||
DEFAULT.DECLARE.TAGS
|
||||
)
|
||||
'(--]
|
||||
" forms------" T) (* ;
|
||||
"REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")
|
||||
(\CS.COMPARE.MASTERS (REVERSE X)
|
||||
(REVERSE Y)
|
||||
DW? LISTSTREAM]
|
||||
(TERPRI LISTSTREAM))
|
||||
" forms------" T) (* ;
|
||||
"REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")
|
||||
(\CS.COMPARE.MASTERS (REVERSE X)
|
||||
(REVERSE Y)
|
||||
DW? CONTEXTSTREAM COMPARESTREAM]
|
||||
(TERPRI CONTEXTSTREAM))
|
||||
(SELECTQ INSERTOBJECTS
|
||||
(OBJECTWINDOW (CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE (CL:GET-OUTPUT-STREAM-STRING
|
||||
CONTEXTSTREAM))))
|
||||
(SETQ OBJECTS (DREVERSE OBJECTS))
|
||||
(OBJ.ADDMANYTOW LISTSTREAM OBJECTS))
|
||||
(TEDIT (HELP "Don't know about TEDIT"))
|
||||
(NIL)
|
||||
(HELP))
|
||||
(RETURN (OR (REVERSE DIFFERENCES)
|
||||
'SAME])
|
||||
|
||||
(\CS.COMPARE.MASTERS
|
||||
[LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 5-Sep-2020 19:01 by rmk:")
|
||||
(* ; "Edited 15-Apr-88 14:41 by bvm")
|
||||
(LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS)
|
||||
(DECLARE (USEDFREE DIFFERENCES))
|
||||
[SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR)
|
||||
'DEFINEQ]
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX))
|
||||
(SETQ FNSX (for BOD in FNSX join (CDR BOD)))
|
||||
[SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR)
|
||||
'DEFINEQ]
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY))
|
||||
(SETQ FNSY (for BOD in FNSY join (CDR BOD)))
|
||||
[COND
|
||||
((OR FNSX FNSY)
|
||||
(printout LISTSTREAM "---Functions: " T)
|
||||
[COND
|
||||
(DW? (LET ((NOSPELLFLG T))
|
||||
(DECLARE (SPECVARS NOSPELLFLG))
|
||||
(for X in FNSX when (SETQ Y (ASSOC (CAR X)
|
||||
FNSY))
|
||||
do (* ;
|
||||
"Only bother dwimifying the ones that look different")
|
||||
(DWIMIFY (CADR X)
|
||||
T)
|
||||
(DWIMIFY (CADR Y)
|
||||
T]
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL [FUNCTION (LAMBDA (X Y STREAM)
|
||||
(COMPARELISTS
|
||||
(CADR X)
|
||||
(CADR Y)
|
||||
STREAM]
|
||||
(FUNCTION CAR)
|
||||
LISTSTREAM))
|
||||
(push DIFFERENCES (CONS 'FNS DIFS]
|
||||
[for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE)
|
||||
(SETQ DEFFERS (GET TYPE :DEFINED-BY)))
|
||||
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 18-Jan-2022 22:00 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 21:05 by rmk")
|
||||
(* ; "Edited 5-Sep-2020 19:01 by rmk:")
|
||||
(* ; "Edited 15-Apr-88 14:41 by bvm")
|
||||
(DECLARE (USEDFREE DIFFERENCES COMPARESTREAM))
|
||||
(LET (YTHING XTHING PRED DIFS TMP)
|
||||
(SETQ BODYX (CL:REMOVE-IF (FUNCTION EDITDATE?)
|
||||
BODYX)) (* ;
|
||||
"We don't care about editdate comments")
|
||||
(SETQ BODYY (CL:REMOVE-IF (FUNCTION EDITDATE?)
|
||||
BODYY))
|
||||
(SETQ BODYX (\CS.FIXFNS BODYX))
|
||||
(SETQ BODYY (\CS.FIXFNS BODYY))
|
||||
(CL:WHEN (AND (SETQ XTHING (ASSOC 'DEFINE-FILE-INFO BODYX))
|
||||
(SETQ YTHING (ASSOC 'DEFINE-FILE-INFO BODYY))
|
||||
(\CS.COMPARE.DEFINE-FILE-INFO XTHING YTHING))
|
||||
(SETQ BODYX (REMOVE XTHING BODYX))
|
||||
(SETQ BODYY (REMOVE YTHING BODYY)))
|
||||
|
||||
(* ;; "These are for commonlispy definers")
|
||||
|
||||
[for TYPE DEFFERS in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE)
|
||||
(SETQ DEFFERS (GET TYPE :DEFINED-BY)))
|
||||
do
|
||||
(* ;; "handle definer based things")
|
||||
|
||||
(* ;; "handle definer based things")
|
||||
(for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
(SETQ YTHING (for X in BODYY collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
|
||||
(for DEFFER in DEFFERS
|
||||
do (SETQ XTHING (for X in BODYX collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
(SETQ YTHING (for X in BODYY collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING))
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING
|
||||
(CONCAT (OR (CL:DOCUMENTATION TYPE 'DEFINE-TYPES)
|
||||
TYPE)
|
||||
" defined by " DEFFER)
|
||||
NIL
|
||||
(GET DEFFER :DEFINITION-NAME)
|
||||
LISTSTREAM))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
[for TYPE in COMPARESOURCETYPES
|
||||
do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE))
|
||||
(SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X)))
|
||||
(SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X)))
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING))
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING
|
||||
(OR (fetch (CSTYPE TITLE) of TYPE)
|
||||
(L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE)
|
||||
of TYPE))
|
||||
T))
|
||||
(fetch (CSTYPE COMPAREFN) of TYPE)
|
||||
(OR (fetch (CSTYPE IDFN) of TYPE)
|
||||
(FUNCTION CADR))
|
||||
LISTSTREAM))
|
||||
(SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
[SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX
|
||||
(SETQ BODYX (LDIFFERENCE BODYX BODYY)))]
|
||||
(* ;; "Take out all of the THINGS we are about to do. ")
|
||||
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES
|
||||
XTHING YTHING
|
||||
(CONCAT (OR (CL:DOCUMENTATION TYPE
|
||||
'DEFINE-TYPES)
|
||||
TYPE)
|
||||
" defined by " DEFFER)
|
||||
NIL
|
||||
(GET DEFFER :DEFINITION-NAME)))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
|
||||
(* ;; "These are for other filepkage types, as registered in COMPARESOURCETYPES")
|
||||
|
||||
[for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE))
|
||||
(SETQ XTHING (for X in BODYX collect X
|
||||
when (CL:FUNCALL PRED X)))
|
||||
(SETQ YTHING (for X in BODYY collect X
|
||||
when (CL:FUNCALL PRED X)))
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
([SETQ DIFS (\CS.COMPARE.TYPES
|
||||
XTHING YTHING
|
||||
(OR (fetch (CSTYPE TITLE) of TYPE)
|
||||
(MKSTRING (fetch (CSTYPE FPKGTYPE)
|
||||
of TYPE)))
|
||||
(fetch (CSTYPE COMPAREFN) of TYPE)
|
||||
(OR (fetch (CSTYPE IDFN) of TYPE)
|
||||
(FUNCTION CADR]
|
||||
(SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY (PROG1 BODYX
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE
|
||||
BODYX BODYY :TEST
|
||||
(FUNCTION EQUALALL))))
|
||||
:TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
((OR BODYX BODYY)
|
||||
(printout LISTSTREAM T "---Expressions:" T)
|
||||
(printout CONTEXTSTREAM T "---Expressions:" T)
|
||||
(LET ((COMMENTX 0)
|
||||
(COMMENTY 0)
|
||||
EXTRAS) (* ; "Remove comments")
|
||||
[SETQ BODYX (for X in BODYX collect X
|
||||
unless (COND
|
||||
((EQ (CAR X)
|
||||
COMMENTFLG)
|
||||
(add COMMENTX 1)
|
||||
T]
|
||||
[SETQ BODYY (for Y in BODYY collect Y
|
||||
unless (COND
|
||||
((EQ (CAR Y)
|
||||
COMMENTFLG)
|
||||
(add COMMENTY 1)
|
||||
T]
|
||||
(COMMENTY 0)) (* ; "Remove comments")
|
||||
[SETQ BODYX (for X in BODYX collect X unless (COND
|
||||
((EQ (CAR X)
|
||||
COMMENTFLG)
|
||||
(add COMMENTX 1)
|
||||
T]
|
||||
[SETQ BODYY (for Y in BODYY collect Y unless (COND
|
||||
((EQ (CAR Y)
|
||||
COMMENTFLG)
|
||||
(add COMMENTY 1)
|
||||
T]
|
||||
(COND
|
||||
((OR (NEQ COMMENTX 0)
|
||||
(NEQ COMMENTY 0))
|
||||
(printout LISTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments." T T
|
||||
)))
|
||||
(printout CONTEXTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments."
|
||||
T T)))
|
||||
[COND
|
||||
((SETQ EXTRAS (COND
|
||||
(BODYX (COND
|
||||
(BODYY (COMPARELISTS BODYX BODYY LISTSTREAM)
|
||||
NIL)
|
||||
(T (printout LISTSTREAM "These are not on " FILEY)
|
||||
BODYX)))
|
||||
(BODYY (printout LISTSTREAM "These are not on " FILEX)
|
||||
BODYY)))
|
||||
(printout LISTSTREAM ":" T)
|
||||
(for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3]
|
||||
[COND
|
||||
((AND (OR BODYX BODYY)
|
||||
(OR (EQ EXAMINE T)
|
||||
(EQMEMB 'MISC EXAMINE)))
|
||||
(IF (EQMEMB 2WINDOWS EXAMINE)
|
||||
THEN (EDITE BODYX)
|
||||
(EDITE BODYY)
|
||||
ELSE (EDITE (LIST BODYX BODYY]
|
||||
[BODYX (COND
|
||||
(BODYY (COMPARELISTS BODYX BODYY COMPARESTREAM)
|
||||
(\CS.EXAMINE BODYX BODYY))
|
||||
(T (printout COMPARESTREAM "These are not on File 2:" T)
|
||||
(FOR X IN BODYX DO (LVLPRINT X COMPARESTREAM 2 3)
|
||||
(\CS.EXAMINE X NIL T]
|
||||
(BODYY (printout COMPARESTREAM "These are not on File 1:" T)
|
||||
(FOR Y IN BODYY DO (LVLPRINT Y COMPARESTREAM 2 3)
|
||||
(\CS.EXAMINE NIL Y T]
|
||||
(OR (ASSOC 'Other DIFFERENCES)
|
||||
(push DIFFERENCES (LIST 'Other '--])
|
||||
|
||||
(\CS.COMPARE.TYPES
|
||||
(LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN. Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT))))
|
||||
)
|
||||
[LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN) (* ; "Edited 9-Dec-2021 23:19 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 23:25 by rmk:")
|
||||
(* ; "Edited 30-Nov-2021 23:07 by rmk:")
|
||||
(* ; "Edited 27-Nov-2021 12:32 by rmk:")
|
||||
(* ; "Edited 25-Nov-2021 13:29 by rmk:")
|
||||
(* ; "Edited 29-Dec-86 11:49 by jds")
|
||||
|
||||
(* ;;; "Compare things using COMPAREFN. Deltas -> COMPARESTREAM. Anything that passes the WHEN predicate has a difference somewhere, will produce some output. ")
|
||||
|
||||
(DECLARE (USEDFREE CONTEXTSTREAM COMPARESTREAM))
|
||||
(LET (X Y RESULT NAME)
|
||||
(CL:WHEN (AND (OR XTHING YTHING)
|
||||
(PROGN (SETQ XTHING (CL:SET-DIFFERENCE XTHING
|
||||
(PROG1 YTHING
|
||||
(SETQ YTHING (CL:SET-DIFFERENCE
|
||||
YTHING XTHING :TEST
|
||||
(FUNCTION EQUALALL))))
|
||||
:TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(OR XTHING YTHING)))
|
||||
DF
|
||||
|
||||
(* ;; "We know we are going to have some output. Strings can go directly onto theCONTEXTSTREAM, and objects may then be inserted.")
|
||||
|
||||
(AND TITLE (printout CONTEXTSTREAM T "---" TITLE ":" T T))
|
||||
(for TAIL on XTHING
|
||||
do [SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL]
|
||||
[COND
|
||||
([NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y)
|
||||
NAME]
|
||||
(printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT
|
||||
" is not on File 2" T T)
|
||||
(\CS.EXAMINE X NIL T NAME))
|
||||
(T (printout COMPARESTREAM .FONT BOLDFONT .P2 NAME ":" .FONT DEFAULTFONT T)
|
||||
(COND
|
||||
(COMPAREFN (CL:FUNCALL COMPAREFN X Y COMPARESTREAM))
|
||||
(T (COMPARELISTS X Y COMPARESTREAM)))
|
||||
(\CS.EXAMINE X Y NIL NAME)
|
||||
(RPLACA (FMEMB Y YTHING]
|
||||
(RPLACA TAIL)
|
||||
(push RESULT NAME))
|
||||
(for Y in (CL:SET-DIFFERENCE YTHING XTHING :TEST (FUNCTION EQUALALL))
|
||||
do (SETQ NAME (CL:FUNCALL IDFN Y))
|
||||
(printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT
|
||||
" is not on File 1" T T)
|
||||
(\CS.EXAMINE Y NIL T NAME)
|
||||
(push RESULT NAME))
|
||||
RESULT)])
|
||||
|
||||
(\CS.EXAMINE
|
||||
[LAMBDA (X Y ONLYONE NAME TYPE) (* ; "Edited 24-Dec-2021 22:48 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 22:46 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 23:23 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 16:43 by rmk")
|
||||
(* ; "Edited 2-Dec-2021 15:23 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 20:37 by rmk:")
|
||||
(* ; "Edited 27-Nov-2021 11:21 by rmk:")
|
||||
(DECLARE (USEDFREE EXAMINE INSERTOBJECTS COMPARESTREAM CONTEXTSTREAM OBJECTS))
|
||||
|
||||
(* ;; "ONLYONE as a flag, because we don't want to test X or Y for NIL, that could be the contrasting value.")
|
||||
|
||||
(* ;; "I don't understand MISC: changed but otherwise unclassified. Does that mean just an unknown type?")
|
||||
|
||||
(* ;; "The only call seemed to be from \CS.COMPARE.MASTERS, where EXTRAS is set to either BODYX or BODYY if the other one is NIL. It may be that that call only happens in the MISC case.")
|
||||
|
||||
(CL:UNLESS NAME (SETQ NAME "from File"))
|
||||
|
||||
(* ;; "Context gets printed to the CONTEXTSTREAM, diffs go to the COMPARESTREAM. If we aren't doing objects, those are the same streams, and the output gets printed in the right order. Nothing to do here.")
|
||||
|
||||
(IF INSERTOBJECTS
|
||||
THEN (SELECTQ INSERTOBJECTS
|
||||
(OBJECTWINDOW [LET (STRING)
|
||||
|
||||
(* ;; "Take out last EOL, let SEPDIST space things out.")
|
||||
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING CONTEXTSTREAM))
|
||||
(CL:WHEN (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING)))
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR COMPARESTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING COMPARESTREAM))
|
||||
|
||||
(* ;; "Don't know why, but SEPTDIST doesn't work if there if there isn't at least one EOL. Magically, this gets the right appearance and behavior.")
|
||||
|
||||
(CL:WHEN (AND (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -2)))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING
|
||||
(LIST NAME TYPE X Y LABEL1 LABEL2)
|
||||
ONLYONE)))])
|
||||
(TEDIT (HELP "TEDIT NOT IMPLEMENTED"))
|
||||
NIL)
|
||||
ELSEIF (OR (LISTP X)
|
||||
(LISTP Y))
|
||||
THEN (* ;
|
||||
"No point in bringing up an editor on a non-list")
|
||||
(IF ONLYONE
|
||||
THEN (IF (OR (EQMEMB T EXAMINE)
|
||||
(EQMEMB 'NEW EXAMINE))
|
||||
THEN (EDITE (OR X Y)))
|
||||
ELSEIF (OR (EQMEMB T EXAMINE)
|
||||
(EQMEMB 'OLD EXAMINE)
|
||||
(EQMEMB 'MISCC))
|
||||
THEN (IF (EQMEMB '2WINDOWS EXAMINE)
|
||||
THEN (EXAMINEDEFS X Y NAME TYPE)
|
||||
ELSE (EDITE (LIST X Y])
|
||||
|
||||
(\CS.FIXFNS
|
||||
[LAMBDA (BODY DW?) (* ; "Edited 29-Nov-2021 20:42 by rmk:")
|
||||
(* ; "Edited 26-Nov-2021 13:34 by rmk:")
|
||||
|
||||
(* ;; "RMK: Functions are special in that they are grouped under DEFINEQ and they may need dwimifying. We don't want to deal with these idiosyncracies below, so our strategy is to split each multi-fn defineq into a sequence of single-fn defineqs , one for each function, then let it fall through. After dwimifying, things should be standard.")
|
||||
|
||||
(LET (DEFINEQS FNS (NOSPELLFLG T))
|
||||
(DECLARE (SPECVARS NOSPELLFLG))
|
||||
[SETQ DEFINEQS (for EXPR in BODY collect EXPR when (EQ (CAR EXPR)
|
||||
'DEFINEQ]
|
||||
(SETQ BODY (CL:SET-DIFFERENCE BODY DEFINEQS)) (* ;
|
||||
"Remove all the multiple function defineqs, so we can pack on the exploded forms")
|
||||
[SETQ FNS (for DFQ in DEFINEQS join (FOR FN IN (CDR DFQ)
|
||||
COLLECT
|
||||
|
||||
(* ;; "FN is a single (NAME DEF) pair")
|
||||
|
||||
`(DEFINEQ (,@FN]
|
||||
(CL:WHEN DW?
|
||||
(FOR FN IN FNS DO (DWIMIFY (CADADR FN)
|
||||
T)))
|
||||
(SETQ BODY (APPEND FNS BODY])
|
||||
|
||||
(\CS.SORT.DECLARES
|
||||
(LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT))
|
||||
@@ -240,6 +408,24 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\CS.ISFNFORM
|
||||
[LAMBDA (X) (* ; "Edited 29-Nov-2021 20:34 by rmk:")
|
||||
(* ; "Edited 26-Nov-2021 13:19 by rmk:")
|
||||
(EQ 'DEFINEQ (CAR (LISTP X])
|
||||
|
||||
(\CS.COMPARE.FNS
|
||||
[LAMBDA (DQX DQY STREAM) (* ; "Edited 29-Nov-2021 20:51 by rmk:")
|
||||
|
||||
(* ;; "CADADR is the body")
|
||||
|
||||
(COMPARELISTS (CADADR DQX)
|
||||
(CADADR DQY)
|
||||
STREAM])
|
||||
|
||||
(\CS.FNSID
|
||||
[LAMBDA (DQX) (* ; "Edited 29-Nov-2021 20:50 by rmk:")
|
||||
(CAR (CADR DQX])
|
||||
|
||||
(\CS.ISVARFORM
|
||||
(LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL)))
|
||||
|
||||
@@ -290,10 +476,144 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(\CS.COMPARE.FPKGCOMS
|
||||
(LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM))
|
||||
)
|
||||
|
||||
(\CS.COMPARE.DEFINE-FILE-INFO
|
||||
[LAMBDA (DFI1 DFI2) (* ; "Edited 19-Dec-2021 21:02 by rmk")
|
||||
(AND (EQUAL (LISTGET :READTABLE DFI1)
|
||||
(LISTGET :READTABLE DFI2))
|
||||
(EQUAL (LISTGET :PACKAGE DFI1)
|
||||
(LISTGET :PACKAGE DFI2))
|
||||
(EQ (OR (LISTGET :BASE DFI1)
|
||||
10)
|
||||
(OR (LISTGET :BASE DFI2)
|
||||
10))
|
||||
(EQ (OR (LISTGET :FORMAT DFI1)
|
||||
*DEFAULT-EXTERNALFORMAT*)
|
||||
(OR (LISTGET :FORMAT DFI2)
|
||||
*DEFAULT-EXTERNALFORMAT*])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CSOBJ.CREATE
|
||||
[LAMBDA (STRING COMPAREDATA ONLYONE) (* ; "Edited 4-Dec-2021 09:57 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 13:26 by rmk:")
|
||||
(LET ((OBJ (IMAGEOBJCREATE STRING COMPARESOURCES-IMAGEFNS)))
|
||||
(IMAGEOBJPROP OBJ 'COMPAREDATA COMPAREDATA)
|
||||
(IMAGEOBJPROP OBJ 'ONLYONE ONLYONE)
|
||||
OBJ])
|
||||
|
||||
(CSOBJ.DISPLAYFN
|
||||
[LAMBDA (OBJ WINDOW) (* ; "Edited 4-Dec-2021 08:24 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 14:18 by rmk:")
|
||||
(DSPFONT DEFAULTFONT WINDOW)
|
||||
(FOR I C (FONTARRAY _ (FONTMAPARRAY))
|
||||
(STRING _ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) FROM 1
|
||||
DO (SELCHARQ (SETQ C (NTHCHARCODE STRING I))
|
||||
(EOL (TERPRI WINDOW))
|
||||
(NIL (RETURN))
|
||||
(IF (EQ C (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
|
||||
THEN (DSPFONT (ELT FONTARRAY (NTHCHARCODE STRING (ADD I 1)))
|
||||
WINDOW)
|
||||
ELSE (PRINTCCODE C WINDOW])
|
||||
|
||||
(CSOBJ.IMAGEBOXFN
|
||||
[LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 9-Dec-2021 23:02 by rmk")
|
||||
(* ; "Edited 7-Dec-2021 10:50 by rmk")
|
||||
(* ; "Edited 5-Dec-2021 23:52 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 08:24 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 13:27 by rmk:")
|
||||
|
||||
(* ;; "Calculate the height of each line, and the width of the widest line.")
|
||||
|
||||
(* ;;
|
||||
"Probably ought to compute the max height per line, at every font change, add it at each EOL.")
|
||||
|
||||
(SETQ IMAGESTREAM (GETSTREAM IMAGESTREAM 'OUTPUT))
|
||||
(FOR I C (STRING _ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
|
||||
(FONT _ (FONTCREATE DEFAULTFONT NIL NIL NIL IMAGESTREAM))
|
||||
(HEIGHT _ 0)
|
||||
(LINELENGTH _ 0)
|
||||
(MAXLINELENGTH _ 0)
|
||||
(FONTARRAY _ (FONTMAPARRAY)) FROM 1
|
||||
DO (SELCHARQ (SETQ C (NTHCHARCODE STRING I))
|
||||
(EOL (ADD HEIGHT (FONTPROP FONT 'HEIGHT))
|
||||
(CL:WHEN (IGREATERP LINELENGTH MAXLINELENGTH)
|
||||
(SETQ MAXLINELENGTH LINELENGTH))
|
||||
(SETQ LINELENGTH 0))
|
||||
(NIL (* ; "end of string")
|
||||
(CL:WHEN (IGREATERP LINELENGTH MAXLINELENGTH)
|
||||
(SETQ MAXLINELENGTH LINELENGTH))
|
||||
(RETURN (CREATE IMAGEBOX
|
||||
XSIZE _ MAXLINELENGTH
|
||||
YSIZE _ HEIGHT
|
||||
YDESC _ (DIFFERENCE HEIGHT (FONTPROP FONT 'HEIGHT))
|
||||
XKERN _ 0)))
|
||||
(IF (EQ C (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
|
||||
THEN (SETQ FONT (FONTCREATE (ELT FONTARRAY (NTHCHARCODE STRING (ADD I 1)))
|
||||
NIL NIL NIL IMAGESTREAM))
|
||||
ELSE (ADD LINELENGTH (CHARWIDTH C FONT])
|
||||
|
||||
(CSOBJ.BUTTONEVENTINFN
|
||||
[LAMBDA (OBJ WINDOW) (* ; "Edited 25-Jan-2022 16:04 by rmk")
|
||||
(* ; "Edited 23-Jan-2022 18:11 by rmk")
|
||||
(LET
|
||||
[(COMPAREDATA (IMAGEOBJPROP OBJ 'COMPAREDATA]
|
||||
(CL:WHEN (AND COMPAREDATA (MOUSESTATE LEFT)
|
||||
(UNTILMOUSESTATE (NOT LEFT)))
|
||||
(LET
|
||||
((NAME (POP COMPAREDATA))
|
||||
(TYPE (POP COMPAREDATA))
|
||||
(DEF1 (POP COMPAREDATA))
|
||||
(DEF2 (POP COMPAREDATA))
|
||||
(TITLE1 (POP COMPAREDATA))
|
||||
(TITLE2 (CAR COMPAREDATA)))
|
||||
|
||||
(* ;; "Move the cursor to just slightly below the current object, so that the edit windows are well aligned. We have to figure out the bottom of the current object, in screen coordinates.")
|
||||
|
||||
[LET ((OBJREGION (OBJ.FIND.REGION WINDOW OBJ)))
|
||||
(\CURSORPOSITION (IPLUS 20 LASTMOUSEX)
|
||||
(IPLUS (IDIFFERENCE (FETCH (REGION BOTTOM) OF OBJREGION)
|
||||
(FETCH (REGION HEIGHT) OF OBJREGION))
|
||||
(FETCH (REGION TOP) OF (WINDOWREGION WINDOW]
|
||||
(LET
|
||||
[EWINDOW (RELPOS (RELCREATEPOSITION `(,WINDOW 0.5)
|
||||
`(,WINDOW 0 -2]
|
||||
(CL:WHEN [WINDOWP (SETQ EWINDOW (WINDOWPROP WINDOW 'EXAMINEWINDOW]
|
||||
(CLOSEW EWINDOW))
|
||||
(SETQ EWINDOW
|
||||
(IF (IMAGEOBJPROP OBJ 'ONLYONE)
|
||||
THEN
|
||||
[SEDIT:GET-WINDOW
|
||||
(SEDIT:SEDIT (OR DEF1 DEF2)
|
||||
`(:REGION ,(RELCREATEREGION 600 (CL:IF (ILESSP (COUNT (OR DEF1 DEF2))
|
||||
100)
|
||||
150
|
||||
400)
|
||||
(CL:IF DEF1
|
||||
'RIGHT
|
||||
'LEFT)
|
||||
'TOP RELPOS NIL T]
|
||||
ELSE (* ; "Spread the arguments")
|
||||
(EXAMINEDEFS NAME TYPE DEF1 DEF2 TITLE1 TITLE2 RELPOS)))
|
||||
(WINDOWPROP WINDOW 'EXAMINEWINDOW EWINDOW)
|
||||
(WINDOWADDPROP WINDOW 'CLOSEFN [FUNCTION (LAMBDA (W)
|
||||
(CLOSEW (WINDOWPROP W 'EXAMINEWINDOW]
|
||||
T)
|
||||
EWINDOW)))])
|
||||
|
||||
(CSOBJ.COPYBUTTONEVENTINFN
|
||||
[LAMBDA (OBJ WINDOW REGION) (* ; "Edited 3-Jan-2022 08:36 by rmk")
|
||||
(CL:WHEN (CAR (IMAGEOBJPROP OBJ 'COMPAREDATA))
|
||||
[COPYINSERT (CAR (IMAGEOBJPROP OBJ 'COMPAREDATA])])
|
||||
)
|
||||
|
||||
(RPAQ? COMPARESOURCES-IMAGEFNS (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN NIL NIL NIL
|
||||
'CSOBJ.BUTTONEVENTINFN
|
||||
'CSOBJ.COPYBUTTONEVENTINFN))
|
||||
|
||||
(RPAQQ COMPARESOURCETYPES
|
||||
((VARS \CS.ISVARFORM \CS.COMPARE.VARS)
|
||||
((FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID "FNS defined by DEFINEQ")
|
||||
(VARS \CS.ISVARFORM \CS.COMPARE.VARS)
|
||||
(MACROS \CS.ISMACROFORM)
|
||||
(RECORDS \CS.ISRECFORM)
|
||||
(PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties")
|
||||
@@ -303,6 +623,60 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR)))
|
||||
|
||||
(RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST))
|
||||
(DEFINEQ
|
||||
|
||||
(CSBROWSER
|
||||
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION)
|
||||
|
||||
(* ;; "Edited 24-Jan-2022 23:11 by rmk: EXAMINE is non-NIL, we run the compare twice. Once to get the TEDIT up as a kind of table of contents, and the second time to run through all of the SEDIT windows.")
|
||||
|
||||
(* ;; "If EXAMINE is non-NIL, we run the compare twice. Once to get the TEDIT up as a kind of table of contents, and the second time to run through all of the SEDIT windows.")
|
||||
|
||||
(* ;; "Returns browser window")
|
||||
|
||||
(* ;; "Don't use the INFILEP value, because that might screw with capitalization that the caller prefers. If the file can be found that way, then lower functions will find it.")
|
||||
|
||||
(DECLARE (SPECVARS LABEL1 LABEL2))
|
||||
(OR (INFILEP FILEX)
|
||||
(SETQ FILEX (FINDFILE FILEX NIL DIRECTORIES))
|
||||
(ERROR "FILE NOT FOUND" FILEX))
|
||||
(OR (INFILEP FILEY)
|
||||
(SETQ FILEY (FINDFILE FILEY NIL DIRECTORIES))
|
||||
(ERROR "FILE NOT FOUND" FILEY))
|
||||
(CL:UNLESS (LISPSOURCEFILEP FILEX)
|
||||
(ERROR FILEX " is not a Medley source file"))
|
||||
(CL:UNLESS (LISPSOURCEFILEP FILEY)
|
||||
(ERROR FILEX " is not a Medley source file"))
|
||||
(LET [(TITLE (CONCAT "COMPARESOURCES of " (OR LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL
|
||||
'BODY FILEX))
|
||||
" and "
|
||||
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY]
|
||||
(SELECTQ COMPARESOURCES-BROWSER-TYPE
|
||||
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T
|
||||
(FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
|
||||
(GETPROMPTWINDOW WINDOW T)
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
|
||||
(COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
|
||||
DW? WINDOW)
|
||||
(OPENW WINDOW)
|
||||
WINDOW))
|
||||
(TEDIT (LET ((TSTREAM (OPENTEXTSTREAM)))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(COMPARESOURCES FILEX FILEY EXAMINE DW? TSTREAM)
|
||||
[TEDIT TSTREAM REGION NIL `(READONLY T WINDOWTYPE COMPARESOURCES-TEDIT TITLE
|
||||
,TITLE]
|
||||
(CL:WHEN NIL
|
||||
EXAMINE
|
||||
(COMPARESOURCES FILEX FILEY EXAMINE DW? (OPENSTREAM '{NULL} 'OUTPUT)))
|
||||
(WFROMDS TSTREAM)))
|
||||
(HELP])
|
||||
)
|
||||
|
||||
(RPAQ? COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW)
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
OBJECTWINDOW EXAMINEDEFS REGIONMANAGER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -314,14 +688,18 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)
|
||||
)
|
||||
)
|
||||
(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020))
|
||||
(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1166 16557 (COMPARESOURCES 1176 . 5134) (\CS.COMPARE.MASTERS 5136 . 13057) (
|
||||
\CS.COMPARE.TYPES 13059 . 14308) (\CS.SORT.DECLARES 14310 . 14653) (\CS.SORT.DECLARE1 14655 . 16075) (
|
||||
\CS.FILTER.GARBAGE 16077 . 16555)) (16558 19286 (\CS.ISVARFORM 16568 . 16673) (\CS.COMPARE.VARS 16675
|
||||
. 17337) (\CS.ISMACROFORM 17339 . 17477) (\CS.ISRECFORM 17479 . 17572) (\CS.ISCOURIERFORM 17574 .
|
||||
17674) (\CS.ISTEMPLATEFORM 17676 . 17774) (\CS.COMPARE.TEMPLATES 17776 . 18141) (\CS.ISPROPFORM 18143
|
||||
. 18298) (\CS.PROP.NAME 18300 . 18445) (\CS.COMPARE.PROPS 18447 . 18604) (\CS.ISADDVARFORM 18606 .
|
||||
18699) (\CS.COMPARE.ADDVARS 18701 . 18866) (\CS.ISFPKGCOMFORM 18868 . 19075) (\CS.COMPARE.FPKGCOMS
|
||||
19077 . 19284)))))
|
||||
(FILEMAP (NIL (1768 27559 (COMPARESOURCES 1778 . 8291) (\CS.COMPARE.MASTERS 8293 . 16437) (
|
||||
\CS.COMPARE.TYPES 16439 . 19577) (\CS.EXAMINE 19579 . 23806) (\CS.FIXFNS 23808 . 25310) (
|
||||
\CS.SORT.DECLARES 25312 . 25655) (\CS.SORT.DECLARE1 25657 . 27077) (\CS.FILTER.GARBAGE 27079 . 27557))
|
||||
(27560 31540 (\CS.ISFNFORM 27570 . 27838) (\CS.COMPARE.FNS 27840 . 28082) (\CS.FNSID 28084 . 28228) (
|
||||
\CS.ISVARFORM 28230 . 28335) (\CS.COMPARE.VARS 28337 . 28999) (\CS.ISMACROFORM 29001 . 29139) (
|
||||
\CS.ISRECFORM 29141 . 29234) (\CS.ISCOURIERFORM 29236 . 29336) (\CS.ISTEMPLATEFORM 29338 . 29436) (
|
||||
\CS.COMPARE.TEMPLATES 29438 . 29803) (\CS.ISPROPFORM 29805 . 29960) (\CS.PROP.NAME 29962 . 30107) (
|
||||
\CS.COMPARE.PROPS 30109 . 30266) (\CS.ISADDVARFORM 30268 . 30361) (\CS.COMPARE.ADDVARS 30363 . 30528)
|
||||
(\CS.ISFPKGCOMFORM 30530 . 30737) (\CS.COMPARE.FPKGCOMS 30739 . 30946) (\CS.COMPARE.DEFINE-FILE-INFO
|
||||
30948 . 31538)) (31541 37731 (CSOBJ.CREATE 31551 . 31964) (CSOBJ.DISPLAYFN 31966 . 32719) (
|
||||
CSOBJ.IMAGEBOXFN 32721 . 34882) (CSOBJ.BUTTONEVENTINFN 34884 . 37481) (CSOBJ.COPYBUTTONEVENTINFN 37483
|
||||
. 37729)) (38595 41299 (CSBROWSER 38605 . 41297)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -1,22 +1,29 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "20-Dec-2021 11:06:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;7 6367
|
||||
(FILECREATED "25-Jan-2022 10:20:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;31 11252
|
||||
|
||||
:CHANGES-TO (FNS EXAMINEDEFS)
|
||||
:CHANGES-TO (FNS EXAMINEFILES)
|
||||
|
||||
:PREVIOUS-DATE "19-Dec-2021 22:45:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;5)
|
||||
:PREVIOUS-DATE "23-Jan-2022 17:41:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;30)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
|
||||
|
||||
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEDEFS-REGION)
|
||||
(INITVARS (EXAMINEDEFS-PROCESS-LIST))))
|
||||
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEFILES TEDITDEF)
|
||||
(INITVARS (EXAMINEDEFS-PROCESS-LIST)
|
||||
(EXAMINEWITH 'COMPARETEXT))
|
||||
(FILES (SYSLOAD)
|
||||
COMPARETEXT)))
|
||||
(DEFINEQ
|
||||
|
||||
(EXAMINEDEFS
|
||||
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 20-Dec-2021 11:06 by rmk")
|
||||
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 23-Jan-2022 17:40 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 22:40 by rmk")
|
||||
(* ; "Edited 12-Jan-2022 17:29 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 22:39 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 11:06 by rmk")
|
||||
|
||||
(* ;; "This provides for side-by-side examination of separate but presumably related expressions. The (LISTP) expressions can be provided directly as SOURCE1 and SOURCE2 or, if NAME is given the copies of the definitions of NAME as TYPE on the two sources are examined.")
|
||||
|
||||
@@ -29,6 +36,8 @@
|
||||
(ERROR SOURCE1 " cannot be examined"))
|
||||
(CL:UNLESS (LISTP SOURCE2)
|
||||
(ERROR SOURCE2 " cannot be examined")))
|
||||
(CL:UNLESS TYPE
|
||||
(SETQ TYPE 'FNS))
|
||||
|
||||
(* ;; "TITLE1 and TITLE2 are optional strings that will be used to construct the titles of the SEDIT windows. We would like to know where GETDEF got the definition so we can use that, but there isn't an interface that provides that information (extended WHEREIS?)")
|
||||
|
||||
@@ -45,9 +54,11 @@
|
||||
ELSEIF (GETDEF NAME TYPE SOURCE2)
|
||||
ELSE (ERROR NAME " not found on " SOURCE2)))
|
||||
(CL:UNLESS TITLE1
|
||||
(SETQ TITLE1 (OR SOURCE1 "File 1")))
|
||||
(SETQ TITLE1 (OR (AND SOURCE1 (LITATOM SOURCE1))
|
||||
"File 1")))
|
||||
(CL:UNLESS TITLE2
|
||||
(SETQ TITLE2 (OR SOURCE2 "File 2")))
|
||||
(SETQ TITLE2 (OR (AND SOURCE2 (LITATOM SOURCE2))
|
||||
"File 2")))
|
||||
(SELECTQ (EDITMODE)
|
||||
(SEDIT:SEDIT
|
||||
(* ;;
|
||||
@@ -65,56 +76,124 @@
|
||||
(* ;;
|
||||
"Crude suggestions for height, width, position. Suggest shorter window for smaller structures")
|
||||
|
||||
(CL:UNLESS (REGIONP REGION)
|
||||
(SETQ REGION (GETREGION)))
|
||||
(LET (W1 W2 HALFWIDTH)
|
||||
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH) OF REGION)
|
||||
2))
|
||||
[SETQ W1
|
||||
(SEDIT:GET-WINDOW (SEDIT:SEDIT DEF1
|
||||
`(:NAME ,(CONCAT NAME " from " TITLE1)
|
||||
:REGION
|
||||
,(CREATE REGION
|
||||
USING REGION WIDTH _ HALFWIDTH)
|
||||
:DONT-KEEP-WINDOW-REGION T]
|
||||
[SETQ W2
|
||||
(SEDIT:GET-WINDOW
|
||||
(SEDIT:SEDIT DEF2
|
||||
`(:NAME ,(CONCAT NAME " from " TITLE2)
|
||||
:REGION
|
||||
,(CREATE REGION USING REGION LEFT _
|
||||
(IPLUS (FETCH (REGION LEFT)
|
||||
OF REGION)
|
||||
HALFWIDTH)
|
||||
WIDTH _ HALFWIDTH)
|
||||
:DONT-KEEP-WINDOW-REGION T]
|
||||
(SELECTQ EXAMINEWITH
|
||||
(SEDIT (CL:UNLESS (REGIONP REGION)
|
||||
(SETQ REGION (GETREGION)))
|
||||
[LET (R1 R2 HALFWIDTH W1 W2)
|
||||
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH)
|
||||
OF REGION)
|
||||
2))
|
||||
(SETQ R1 (CREATE REGION USING REGION WIDTH _ HALFWIDTH))
|
||||
(SETQ R2 (CREATE REGION USING REGION LEFT _
|
||||
(IPLUS (FETCH (REGION LEFT)
|
||||
OF REGION)
|
||||
HALFWIDTH)
|
||||
WIDTH _ HALFWIDTH))
|
||||
[SETQ W1
|
||||
(SEDIT:GET-WINDOW (SEDIT:SEDIT
|
||||
DEF1
|
||||
`(:NAME ,(CONCAT NAME " from " TITLE1)
|
||||
:REGION
|
||||
,(CREATE REGION
|
||||
USING REGION WIDTH _
|
||||
HALFWIDTH)
|
||||
R1 :DONT-KEEP-WINDOW-REGION T]
|
||||
[SETQ W2
|
||||
(SEDIT:GET-WINDOW (SEDIT:SEDIT
|
||||
DEF2
|
||||
`(:NAME ,(CONCAT NAME " from " TITLE2)
|
||||
:REGION
|
||||
,R2 :DONT-KEEP-WINDOW-REGION T]
|
||||
(ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
|
||||
(MODERNWINDOW W2)
|
||||
|
||||
(* ;;
|
||||
(* ;;
|
||||
"So we can kill the processes on the next call, if they still exist after the windows are closed.")
|
||||
|
||||
[PUSH EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP W1 'PROCESS))
|
||||
(CONS W2 (WINDOWPROP W2 'PROCESS]
|
||||
(ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
|
||||
(MODERNWINDOW W2)))
|
||||
(PUSH EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP
|
||||
W1
|
||||
'PROCESS))
|
||||
(CONS W2 (WINDOWPROP W2 'PROCESS])
|
||||
(COMPARETEXT [LET (COMPARETEXT.ALLCHUNKS CTWINDOW
|
||||
(KEY (LIST NAME TYPE SOURCE1 SOURCE2 TITLE1
|
||||
TITLE2)))
|
||||
(DECLARE (SPECVARS COMPARETEXT.ALLCHUNKS))
|
||||
(* ; "Reuse an existing CT graph window")
|
||||
(OR [FIND W IN (OPENWINDOWS)
|
||||
SUCHTHAT (EQUAL KEY (WINDOWPROP W
|
||||
'EXAMINEDEFS]
|
||||
(PROG1 (SETQ CTWINDOW
|
||||
(COMPARETEXT (TEDITDEF NAME DEF1 TYPE)
|
||||
(TEDITDEF NAME DEF2 TYPE)
|
||||
'LINE REGION (LIST TITLE1 TITLE2)
|
||||
(CONCAT "Compare sources of " NAME
|
||||
" as " TYPE)))
|
||||
(WINDOWPROP CTWINDOW 'EXAMINEDEFS
|
||||
(LIST NAME TYPE SOURCE1 SOURCE2 TITLE1
|
||||
TITLE2)))])
|
||||
(SHOULDNT)))
|
||||
(PROGN (EDITE DEF1)
|
||||
(EDITE DEF2])
|
||||
|
||||
(EXAMINEDEFS-REGION
|
||||
[LAMBDA (WIDTH HEIGHT) (* ; "Edited 10-Dec-2021 10:15 by rmk")
|
||||
(EXAMINEFILES
|
||||
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 25-Jan-2022 10:08 by rmk")
|
||||
(* ; "Edited 2-Jan-2022 23:15 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 21:49 by rmk")
|
||||
|
||||
(* ;; "Prompts for a WIDTH-HEIGHT region with the top-left corner positioned at the initial cursor but the cursor then moved to the bottom-right for size adjustments. Thus the default behavior is that the upper left corner is fixed.")
|
||||
(* ;; "We get a region, then split it in half. Should we attach or at least co-move and co-close the 2 windows?")
|
||||
|
||||
(GETMOUSESTATE)
|
||||
(LET* ((LEFT LASTMOUSEX)
|
||||
(RIGHT (IPLUS LEFT WIDTH))
|
||||
(TOP LASTMOUSEY)
|
||||
(BOTTOM (IDIFFERENCE TOP HEIGHT)))
|
||||
(\CURSORPOSITION RIGHT BOTTOM)
|
||||
(GETREGION NIL NIL (CREATEREGION LEFT BOTTOM WIDTH HEIGHT)
|
||||
NIL NIL (LIST LEFT TOP RIGHT BOTTOM])
|
||||
(CL:UNLESS REGION
|
||||
(SETQ REGION (GETREGION)))
|
||||
(LIST (TEDIT-SEE FILE1 (RELCREATEREGION `(,REGION 0.5 -1)
|
||||
REGION
|
||||
'RIGHT
|
||||
'TOP
|
||||
`(,REGION 0.5)
|
||||
(FETCH (REGION TOP) OF REGION))
|
||||
NIL TITLE1)
|
||||
(TEDIT-SEE FILE2 (RELCREATEREGION `(,REGION 0.5 1)
|
||||
REGION
|
||||
'LEFT
|
||||
'TOP
|
||||
`(,REGION 0.5)
|
||||
(FETCH (REGION TOP) OF REGION))
|
||||
NIL TITLE2])
|
||||
|
||||
(TEDITDEF
|
||||
[LAMBDA (NAME DEF TYPE READERENVIRONMENT) (* ; "Edited 12-Jan-2022 17:27 by rmk")
|
||||
(LET ((TSTREAM (OPENTEXTSTREAM)))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(CL:WHEN (EQ (CAR DEF)
|
||||
'DEFINEQ)
|
||||
(SETQ DEF (CADR DEF)))
|
||||
(IF (EQ NAME (CAR DEF))
|
||||
THEN (DSPFONT BOLDFONT TSTREAM)
|
||||
(PRINT NAME TSTREAM)
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(SETQ DEF (CADR DEF))
|
||||
(PRINTDEF DEF 3 T NIL NIL TSTREAM)
|
||||
ELSEIF (EQ NAME (CADR DEF))
|
||||
THEN
|
||||
(* ;; "Presumably a DEFUN. Print the CAR, boldface the cadr")
|
||||
|
||||
(PRINTOUT TSTREAM "(" .P2 (CAR DEF)
|
||||
" " .FONT BOLDFONT .P2 (CADR DEF)
|
||||
.FONT DEFAULTFONT " " .P2 (CADDR DEF)
|
||||
T 3)
|
||||
(PRINTDEF (CDDDR DEF)
|
||||
3 T T NIL TSTREAM)
|
||||
(PRIN3 ")" TSTREAM)
|
||||
ELSE (PRINTDEF DEF 3 NIL NIL NIL TSTREAM))
|
||||
TSTREAM])
|
||||
)
|
||||
|
||||
(RPAQ? EXAMINEDEFS-PROCESS-LIST )
|
||||
|
||||
(RPAQ? EXAMINEWITH 'COMPARETEXT)
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
COMPARETEXT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (513 6305 (EXAMINEDEFS 523 . 5601) (EXAMINEDEFS-REGION 5603 . 6303)))))
|
||||
(FILEMAP (NIL (662 11110 (EXAMINEDEFS 672 . 8791) (EXAMINEFILES 8793 . 9988) (TEDITDEF 9990 . 11108)))
|
||||
))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
1143
lispusers/GITFNS
Normal file
1143
lispusers/GITFNS
Normal file
File diff suppressed because it is too large
Load Diff
BIN
lispusers/GITFNS.LCOM
Normal file
BIN
lispusers/GITFNS.LCOM
Normal file
Binary file not shown.
BIN
lispusers/GITFNS.TEDIT
Normal file
BIN
lispusers/GITFNS.TEDIT
Normal file
Binary file not shown.
@@ -1,21 +1,21 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "26-Sep-91 14:35:23" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>IDLEHAX.;2| 22593
|
||||
|
||||
changes to%: (FNS CONNECTPOLYS RANDOMPT KAL.ORAND)
|
||||
(VARS IDLEHAXCOMS)
|
||||
(RECORDS KALFIXP)
|
||||
(FILECREATED "15-Jan-2022 15:31:21" {DSK}<home>larry>medley>lispusers>IDLEHAX.;2 22517
|
||||
|
||||
previous date%: "10-Jun-88 17:50:01" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>IDLEHAX.;1|)
|
||||
:CHANGES-TO (FNS CONNECTPOLYS)
|
||||
(VARS IDLEHAXCOMS)
|
||||
|
||||
:PREVIOUS-DATE "26-Sep-91 14:35:23" {DSK}<home>larry>medley>lispusers>IDLEHAX.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1985-1988, 1991 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT IDLEHAXCOMS)
|
||||
|
||||
(RPAQQ IDLEHAXCOMS
|
||||
([COMS [ADDVARS (IDLE.FUNCTIONS (Lines 'LINES)
|
||||
((COMS [ADDVARS (IDLE.FUNCTIONS (Lines 'LINES)
|
||||
(Warp-Out 'WARP)
|
||||
(Radar 'WALKINGSPOKE)
|
||||
[Triangles (FUNCTION (LAMBDA (W)
|
||||
@@ -28,7 +28,8 @@ Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights res
|
||||
(Bubbles 'BUBBLES)
|
||||
(Kaleidoscope 'KALDEMO)
|
||||
(Windows 'IDLE-WINDOWS]
|
||||
(VARS (IDLE.DEFAULTFN 'LINES]
|
||||
(VARS (IDLE.DEFAULTFN 'LINES)
|
||||
(POLYGONWAIT3 250)))
|
||||
(COMS (* ; "for drawing polygons")
|
||||
(FNS POLYGONSDEMO POLYGONS CONNECTPOLYS DRAWPOLY1 RANDOMPT)
|
||||
(INITVARS (POLYGONSWINDOW))
|
||||
@@ -74,6 +75,8 @@ Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights res
|
||||
|
||||
(RPAQQ IDLE.DEFAULTFN LINES)
|
||||
|
||||
(RPAQQ POLYGONWAIT3 250)
|
||||
|
||||
|
||||
|
||||
(* ; "for drawing polygons")
|
||||
@@ -89,39 +92,39 @@ Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights res
|
||||
)
|
||||
|
||||
(CONNECTPOLYS
|
||||
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* lmm "30-Jul-85 17:19")
|
||||
[LAMBDA (FROMS TOS NSTEPS W OPERATION) (* ; "Edited 12-Jan-2022 15:22 by larry")
|
||||
(* lmm "30-Jul-85 17:19")
|
||||
(PROG (DIFFS)
|
||||
(CLEARW W)
|
||||
(LINES2 FROMS 3 W OPERATION)
|
||||
(SETQ DIFFS (for FPT in FROMS as TPT in TOS bind DX DY
|
||||
collect (SETQ DX (IQUOTIENT (IDIFFERENCE (fetch XC of TPT)
|
||||
(fetch XC of FPT))
|
||||
POLYGONSTEPS))
|
||||
(fetch XC of FPT))
|
||||
POLYGONSTEPS))
|
||||
(SETQ DY (IQUOTIENT (IDIFFERENCE (fetch YC of TPT)
|
||||
(fetch YC of FPT))
|
||||
POLYGONSTEPS))
|
||||
(replace XC of TPT with (IPLUS (fetch XC of FPT)
|
||||
(ITIMES POLYGONSTEPS DX)))
|
||||
(ITIMES POLYGONSTEPS DX)))
|
||||
(replace YC of TPT with (IPLUS (fetch YC of FPT)
|
||||
(ITIMES POLYGONSTEPS DY)))
|
||||
(ITIMES POLYGONSTEPS DY)))
|
||||
(CONS DX DY)))
|
||||
(LINES2 TOS 3 W OPERATION)
|
||||
(for FPT in FROMS as TPT in TOS do (DRAWLINE (fetch XC of
|
||||
FPT)
|
||||
(fetch YC of FPT)
|
||||
(fetch XC of TPT)
|
||||
(fetch YC of TPT)
|
||||
1 OPERATION W))
|
||||
(for FPT in FROMS as TPT in TOS do (DRAWLINE (fetch XC of FPT)
|
||||
(fetch YC of FPT)
|
||||
(fetch XC of TPT)
|
||||
(fetch YC of TPT)
|
||||
1 OPERATION W))
|
||||
(DISMISS POLYGONWAIT2)
|
||||
(CLEARW W)
|
||||
(for I from 1 to POLYGONSTEPS
|
||||
do (BLOCK)
|
||||
(LINES2 FROMS 1 W OPERATION)
|
||||
(for PT in FROMS as DIF in DIFFS
|
||||
do (add (fetch XC of PT)
|
||||
(CAR DIF))
|
||||
(add (fetch YC of PT)
|
||||
(CDR DIF))) finally (LINES2 FROMS 1 W OPERATION])
|
||||
(for I from 1 to POLYGONSTEPS do (DISMISS POLYGONWAIT3)
|
||||
(LINES2 FROMS 1 W OPERATION)
|
||||
(for PT in FROMS as DIF in DIFFS
|
||||
do (add (fetch XC of PT)
|
||||
(CAR DIF))
|
||||
(add (fetch YC of PT)
|
||||
(CDR DIF)))
|
||||
finally (LINES2 FROMS 1 W OPERATION])
|
||||
|
||||
(DRAWPOLY1
|
||||
(LAMBDA (PTLIST WIDTH OPERATION W NOBLOCK) (* edited%: "19-AUG-83 04:14") (* draws a closed polygon of the points given If OPERATION is not given, use the one from the default DS.) (COND (PTLIST (OR OPERATION (SETQ OPERATION (DSPOPERATION NIL W))) (PROG ((PTS PTLIST)) (while (CDR PTS) do (DRAWLINE (fetch XC of (CAR PTS)) (fetch YC of (CAR PTS)) (fetch XC of (CADR PTS)) (fetch YC of (CADR PTS)) WIDTH OPERATION W) (pop PTS) finally (DRAWLINE (fetch XC of (CAR PTS)) (fetch YC of (CAR PTS)) (fetch XC of (CAR PTLIST)) (fetch YC of (CAR PTLIST)) WIDTH OPERATION W))))) (COND (NOBLOCK (ALLOW.BUTTON.EVENTS)) (T (BLOCK))))
|
||||
@@ -151,7 +154,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights res
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE NPOINT ((XC XPOINTER)
|
||||
(YC XPOINTER)))
|
||||
(YC XPOINTER)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'NPOINT '(XPOINTER XPOINTER)
|
||||
@@ -363,7 +366,7 @@ Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights res
|
||||
(RPAQQ MELT-BLOCK-SIZE 32)
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Melt screen" 'IDLE-MELT)
|
||||
("Slide screen" 'IDLE-SLIDE))
|
||||
("Slide screen" 'IDLE-SLIDE))
|
||||
|
||||
|
||||
|
||||
@@ -382,18 +385,17 @@ Copyright (c) 1985, 1986, 1987, 1988, 1991 by Xerox Corporation. All rights res
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PERIODIC.BLOCK MACRO [(TIMER)
|
||||
(if (TIMEREXPIRED? TIMER 'TICKS)
|
||||
then (BLOCK)
|
||||
(SETQ TIMER (SETUPTIMER 100 TIMER 'TICKS
|
||||
'MILLISECONDS])
|
||||
(if (TIMEREXPIRED? TIMER 'TICKS)
|
||||
then (BLOCK)
|
||||
(SETQ TIMER (SETUPTIMER 100 TIMER 'TICKS 'MILLISECONDS])
|
||||
)
|
||||
(PUTPROPS IDLEHAX COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1991))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3587 7576 (POLYGONSDEMO 3597 . 3767) (POLYGONS 3769 . 4133) (CONNECTPOLYS 4135 . 6482)
|
||||
(DRAWPOLY1 6484 . 7121) (RANDOMPT 7123 . 7574)) (8217 11199 (KALDEMO 8227 . 9638) (KAL.ADVANCE 9640 .
|
||||
10041) (KAL.SPOTS 10043 . 10384) (KAL.BMS 10386 . 10873) (KAL.ORAND 10875 . 11197)) (11236 12722 (
|
||||
BUBBLES 11246 . 12352) (BUBBLE.CREATE 12354 . 12720)) (12749 13734 (IDLE-WINDOWS 12759 . 13732)) (
|
||||
13769 16040 (LINES 13779 . 14838) (LINES1 14840 . 15250) (LINES2 15252 . 15563) (LINES3 15565 . 16038)
|
||||
) (16100 17313 (WALKINGSPOKE 16110 . 16891) (WARP 16893 . 17311)) (17338 21621 (IDLE-MELT 17348 .
|
||||
19864) (IDLE-SLIDE 19866 . 21619)) (21796 22042 (DEMOWINDOW 21806 . 22040)))))
|
||||
(FILEMAP (NIL (3562 7602 (POLYGONSDEMO 3572 . 3742) (POLYGONS 3744 . 4108) (CONNECTPOLYS 4110 . 6508)
|
||||
(DRAWPOLY1 6510 . 7147) (RANDOMPT 7149 . 7600)) (8239 11221 (KALDEMO 8249 . 9660) (KAL.ADVANCE 9662 .
|
||||
10063) (KAL.SPOTS 10065 . 10406) (KAL.BMS 10408 . 10895) (KAL.ORAND 10897 . 11219)) (11258 12744 (
|
||||
BUBBLES 11268 . 12374) (BUBBLE.CREATE 12376 . 12742)) (12771 13756 (IDLE-WINDOWS 12781 . 13754)) (
|
||||
13791 16062 (LINES 13801 . 14860) (LINES1 14862 . 15272) (LINES2 15274 . 15585) (LINES3 15587 . 16060)
|
||||
) (16122 17335 (WALKINGSPOKE 16132 . 16913) (WARP 16915 . 17333)) (17360 21643 (IDLE-MELT 17370 .
|
||||
19886) (IDLE-SLIDE 19888 . 21641)) (21814 22060 (DEMOWINDOW 21824 . 22058)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Oct-2021 15:42:11"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;41 30305
|
||||
(FILECREATED "25-Dec-2021 22:27:41"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MODERNIZE.;39 30532
|
||||
|
||||
changes to%: (FNS MODERNIZED.TB.BUTTONEVENTFN)
|
||||
:CHANGES-TO (FNS MODERN-MENUBUTTONFN)
|
||||
|
||||
previous date%: "16-Oct-2021 15:29:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;40)
|
||||
:PREVIOUS-DATE "25-Dec-2021 22:20:10"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MODERNIZE.;38)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MODERNIZECOMS)
|
||||
@@ -216,8 +216,9 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MODERNWINDOW.BUTTONEVENTFN
|
||||
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION CORNERREGION TOPMARGIN)
|
||||
(* ; "Edited 16-Oct-2021 15:25 by rmk:")
|
||||
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION CORNERREGION TOPMARGIN)
|
||||
(* ; "Edited 25-Dec-2021 22:19 by rmk")
|
||||
(* ; "Edited 16-Oct-2021 15:25 by rmk:")
|
||||
|
||||
(* ;; "WINDOW is the window that received the click and that should be passed through to the original function, if we don't pick it off here.")
|
||||
|
||||
@@ -232,81 +233,78 @@
|
||||
(LET (CORNER ATTACHEDREGION)
|
||||
(IF CORNERREGION
|
||||
THEN
|
||||
(* ;; "Caller tells us whether the corner window has a title.")
|
||||
|
||||
(* ;; "Caller tells us whether the corner window has a title.")
|
||||
|
||||
(CL:UNLESS (FIXP TOPMARGIN)
|
||||
(SETQ TOPMARGIN (if TOPMARGIN
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
(CL:UNLESS (FIXP TOPMARGIN)
|
||||
(SETQ TOPMARGIN (if TOPMARGIN
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
ELSE (SETQ CORNERREGION (WINDOWPROP WINDOW 'REGION))
|
||||
(* ; "WINDOW is the corner window")
|
||||
(SETQ TOPMARGIN (if (WINDOWPROP WINDOW 'TOPMARGIN)
|
||||
elseif (WINDOWPROP WINDOW 'TITLE)
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
(SETQ TOPMARGIN (if (WINDOWPROP WINDOW 'TOPMARGIN)
|
||||
elseif (WINDOWPROP WINDOW 'TITLE)
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
(if (AND (MOUSESTATE (ONLY LEFT))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(INSIDE? CORNERREGION LASTMOUSEX LASTMOUSEY))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(INSIDE? CORNERREGION LASTMOUSEX LASTMOUSEY))
|
||||
then
|
||||
(* ;; "INSIDE? check because we may be called by a click in WINDOW that is outside the corner region, we just pass it through.")
|
||||
|
||||
(* ;; "INSIDE? check because we may be called by a click in WINDOW that is outside the corner region, we just pass it through.")
|
||||
(TOTOPW WINDOW)
|
||||
(SETQ ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW)))
|
||||
|
||||
(TOTOPW WINDOW)
|
||||
(SETQ ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW)))
|
||||
(* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.")
|
||||
|
||||
(* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.")
|
||||
(* ;; "This is particularly the case of FILEBROWSER windows, where the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")
|
||||
|
||||
(* ;; "This is particularly the case of FILEBROWSER windows, where the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")
|
||||
(SETQ CORNER (INCORNER.REGION CORNERREGION TOPMARGIN))
|
||||
(if [AND CORNER (NOT (MEMB 'SHAPEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS]
|
||||
then
|
||||
(* ;;
|
||||
"The upper corners may be in the title bar, near the side, so test corners before titlebar.")
|
||||
|
||||
(SETQ CORNER (INCORNER.REGION CORNERREGION TOPMARGIN))
|
||||
(if CORNER
|
||||
then
|
||||
(* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")
|
||||
|
||||
(* ;;
|
||||
"The upper corners may be in the title bar, near the side, so test corners before titlebar.")
|
||||
(* ;; "WINDOWREGION includes the attached windows")
|
||||
|
||||
(* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")
|
||||
(LET ((LEFT (fetch (REGION LEFT) of ATTACHEDREGION))
|
||||
(RIGHT (fetch (REGION RIGHT) of ATTACHEDREGION))
|
||||
(TOP (fetch (REGION TOP) of ATTACHEDREGION))
|
||||
(BOTTOM (fetch (REGION BOTTOM) of ATTACHEDREGION))
|
||||
STARTINGREGION)
|
||||
|
||||
(* ;; "WINDOWREGION includes the attached windows")
|
||||
(* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")
|
||||
|
||||
(LET ((LEFT (fetch (REGION LEFT) of ATTACHEDREGION))
|
||||
(RIGHT (fetch (REGION RIGHT) of ATTACHEDREGION))
|
||||
(TOP (fetch (REGION TOP) of ATTACHEDREGION))
|
||||
(BOTTOM (fetch (REGION BOTTOM) of ATTACHEDREGION))
|
||||
STARTINGREGION)
|
||||
|
||||
(* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")
|
||||
|
||||
(CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
|
||||
[SETQ STARTINGREGION
|
||||
(GETREGION NIL NIL NIL NIL NIL
|
||||
(SELECTQ CORNER
|
||||
(RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT TOP RIGHT BOTTOM))
|
||||
(LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST RIGHT TOP LEFT BOTTOM))
|
||||
(RIGHTTOP (\CURSORPOSITION RIGHT TOP)
|
||||
(CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
|
||||
[SETQ STARTINGREGION
|
||||
(GETREGION NIL NIL NIL NIL NIL
|
||||
(SELECTQ CORNER
|
||||
(RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT TOP RIGHT BOTTOM))
|
||||
(LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT BOTTOM RIGHT TOP))
|
||||
(LEFTTOP (\CURSORPOSITION LEFT TOP)
|
||||
(GETMOUSESTATE)
|
||||
(LIST RIGHT BOTTOM LEFT TOP))
|
||||
(SHOULDNT])
|
||||
(SHAPEW (CENTRALWINDOW WINDOW)
|
||||
STARTINGREGION))
|
||||
T
|
||||
elseif (OR ANYWHERE (NEARTOP CORNERREGION TOPMARGIN TITLEPROPORTION))
|
||||
then (NEARESTCORNER ATTACHEDREGION)
|
||||
(MOVEW (CENTRALWINDOW WINDOW))
|
||||
T
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
|
||||
'PREMODERN-BUTTONEVENTFN]
|
||||
then (APPLY* ORIGFUNCTION WINDOW))
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
|
||||
'PREMODERN-BUTTONEVENTFN]
|
||||
(LIST RIGHT TOP LEFT BOTTOM))
|
||||
(RIGHTTOP (\CURSORPOSITION RIGHT TOP)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT BOTTOM RIGHT TOP))
|
||||
(LEFTTOP (\CURSORPOSITION LEFT TOP)
|
||||
(GETMOUSESTATE)
|
||||
(LIST RIGHT BOTTOM LEFT TOP))
|
||||
(SHOULDNT])
|
||||
(SHAPEW (CENTRALWINDOW WINDOW)
|
||||
STARTINGREGION))
|
||||
T
|
||||
elseif (AND [NOT (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS]
|
||||
(OR ANYWHERE (NEARTOP CORNERREGION TOPMARGIN TITLEPROPORTION)))
|
||||
then (NEARESTCORNER ATTACHEDREGION)
|
||||
(MOVEW (CENTRALWINDOW WINDOW))
|
||||
T
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
|
||||
'PREMODERN-BUTTONEVENTFN]
|
||||
then (APPLY* ORIGFUNCTION WINDOW))
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN]
|
||||
then (APPLY* ORIGFUNCTION WINDOW])
|
||||
|
||||
(NEARTOP
|
||||
@@ -406,19 +404,21 @@
|
||||
(MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))])
|
||||
|
||||
(MODERN-MENUBUTTONFN
|
||||
[LAMBDA (WINDOW) (* ; "Edited 23-May-2021 20:37 by rmk:")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 25-Dec-2021 22:26 by rmk")
|
||||
(* ; "Edited 23-May-2021 20:37 by rmk:")
|
||||
|
||||
(* ;; "Replaces the button fn for a Menu window, allowing title clicks to do the move. Sometimes the title isn't in the window, it's in the menu.")
|
||||
(* ;; "Replaces the button fn for a Menu window, allowing title clicks to do the move. Sometimes the title isn't in the window, it's in the menu.")
|
||||
|
||||
(LET (MENU)
|
||||
(IF [AND (MOUSESTATE (ONLY LEFT))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(OR (WINDOWPROP WINDOW 'TITLE)
|
||||
(AND [NULL (CDR (SETQ MENU (MKLIST (WINDOWPROP WINDOW 'MENU]
|
||||
(TYPE? MENU (SETQ MENU (CAR MENU)))
|
||||
(FETCH (MENU TITLE) OF MENU)))
|
||||
(NEARTOP (WINDOWPROP WINDOW 'REGION)
|
||||
(FONTPROP WindowTitleDisplayStream 'HEIGHT]
|
||||
(IF [AND [NOT (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS]
|
||||
(MOUSESTATE (ONLY LEFT))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(OR (WINDOWPROP WINDOW 'TITLE)
|
||||
(AND [NULL (CDR (SETQ MENU (MKLIST (WINDOWPROP WINDOW 'MENU]
|
||||
(TYPE? MENU (SETQ MENU (CAR MENU)))
|
||||
(FETCH (MENU TITLE) OF MENU)))
|
||||
(NEARTOP (WINDOWPROP WINDOW 'REGION)
|
||||
(FONTPROP WindowTitleDisplayStream 'HEIGHT]
|
||||
THEN (MOVEW WINDOW)
|
||||
ELSE (MODERN-ORIG-MENUBUTTONFN WINDOW])
|
||||
)
|
||||
@@ -532,7 +532,7 @@
|
||||
|
||||
|
||||
(* (MODERNWINDOW.SETUP
|
||||
(QUOTE ONEDINSPECT.BUTTONEVENTFN)))
|
||||
(QUOTE ONEDINSPECT.BUTTONEVENTFN)))
|
||||
|
||||
(MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
|
||||
|
||||
@@ -571,7 +571,7 @@
|
||||
|
||||
|
||||
(MODERNWINDOW (PROCESSPROP (TTY.PROCESS)
|
||||
'WINDOW))
|
||||
'WINDOW))
|
||||
|
||||
|
||||
(* ;; "Table browser and filebrowser)")
|
||||
@@ -612,12 +612,12 @@
|
||||
(ADDTOVAR LAMA MODERN-ADD-EXEC)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5135 11412 (MODERNWINDOW 5145 . 6600) (MODERNWINDOW.SETUP 6602 . 9551) (UNMODERNWINDOW
|
||||
9553 . 9947) (MODERNWINDOW.UNSETUP 9949 . 10761) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10763 . 11410)) (
|
||||
11477 21412 (MODERNWINDOW.BUTTONEVENTFN 11487 . 18287) (NEARTOP 18289 . 19217) (NEARESTCORNER 19219 .
|
||||
20098) (INCORNER.REGION 20100 . 21410)) (21470 23792 (MODERN-ADD-EXEC 21480 . 21911) (MODERN-SNAPW
|
||||
21913 . 22456) (TOTOPW.MODERNIZE 22458 . 22886) (MODERN-MENUBUTTONFN 22888 . 23790)) (23793 26222 (
|
||||
\MODERNIZED.FREEMENU.BUTTONEVENTFN 23803 . 24450) (MODERNIZED.TB.BUTTONEVENTFN 24452 . 26220)) (26263
|
||||
28542 (TEDIT.MODERNIZE 26273 . 27087) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27089 . 28211) (TEDIT.SELECTALL
|
||||
28213 . 28540)))))
|
||||
(FILEMAP (NIL (5122 11399 (MODERNWINDOW 5132 . 6587) (MODERNWINDOW.SETUP 6589 . 9538) (UNMODERNWINDOW
|
||||
9540 . 9934) (MODERNWINDOW.UNSETUP 9936 . 10748) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10750 . 11397)) (
|
||||
11464 21491 (MODERNWINDOW.BUTTONEVENTFN 11474 . 18366) (NEARTOP 18368 . 19296) (NEARESTCORNER 19298 .
|
||||
20177) (INCORNER.REGION 20179 . 21489)) (21549 24021 (MODERN-ADD-EXEC 21559 . 21990) (MODERN-SNAPW
|
||||
21992 . 22535) (TOTOPW.MODERNIZE 22537 . 22965) (MODERN-MENUBUTTONFN 22967 . 24019)) (24022 26451 (
|
||||
\MODERNIZED.FREEMENU.BUTTONEVENTFN 24032 . 24679) (MODERNIZED.TB.BUTTONEVENTFN 24681 . 26449)) (26492
|
||||
28771 (TEDIT.MODERNIZE 26502 . 27316) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27318 . 28440) (TEDIT.SELECTALL
|
||||
28442 . 28769)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "21-Dec-2021 18:20:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>OBJECTWINDOW.;4 94660
|
||||
(FILECREATED "26-Dec-2021 18:59:24"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>OBJECTWINDOW.;5 94928
|
||||
|
||||
:CHANGES-TO (FNS OBJ.CREATEW OBJ.ADDMANYTOW OBJ.INSERTOBJECTS)
|
||||
:CHANGES-TO (FNS OBJ.CREATEW)
|
||||
|
||||
:PREVIOUS-DATE "16-Dec-2021 23:33:24"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>OBJECTWINDOW.;3)
|
||||
:PREVIOUS-DATE "21-Dec-2021 18:20:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>OBJECTWINDOW.;4)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT OBJECTWINDOWCOMS)
|
||||
@@ -174,15 +174,20 @@
|
||||
WINDOW])
|
||||
|
||||
(OBJ.CREATEW
|
||||
[LAMBDA (WINDOWTYPE REGION TITLE BORDERSIZE NOOPENFLG SEPDIST BOXFN DISPLAYFN BUTTONINFN HARDCOPYFN
|
||||
HCPYHEADING) (* ; "Edited 21-Dec-2021 17:19 by rmk")
|
||||
[LAMBDA (WINDOWTYPE REGION/WINDOW TITLE BORDERSIZE NOOPENFLG SEPDIST BOXFN DISPLAYFN BUTTONINFN
|
||||
HARDCOPYFN HCPYHEADING) (* ; "Edited 26-Dec-2021 18:48 by rmk")
|
||||
(* ; "Edited 21-Dec-2021 17:19 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 23:32 by rmk")
|
||||
(* ; "Edited 26-Nov-96 14:31 by rmk:")
|
||||
(* bbb " 9-May-86 16:59")
|
||||
(CL:UNLESS (MEMB WINDOWTYPE '(HORIZONTAL VERTICAL))
|
||||
(\ILLEGAL.ARG WINDOWTYPE))
|
||||
(LET (WINDOW)
|
||||
(SETQ WINDOW (CREATEW REGION TITLE BORDERSIZE NOOPENFLG))
|
||||
(IF (WINDOWP REGION/WINDOW)
|
||||
THEN (SETQ WINDOW REGION/WINDOW)
|
||||
(CL:WHEN TITLE
|
||||
(WINDOWPROP WINDOW 'TITLE TITLE))
|
||||
ELSE (SETQ WINDOW (CREATEW REGION/WINDOW TITLE BORDERSIZE NOOPENFLG)))
|
||||
(WINDOWPROP WINDOW 'WINDOWTYPE WINDOWTYPE)
|
||||
(OBJ.CLEARW WINDOW)
|
||||
(WINDOWPROP WINDOW 'SCROLLFN (FUNCTION OBJ.SCROLLFN))
|
||||
@@ -1479,18 +1484,18 @@
|
||||
(AND (GETD 'MODERNWINDOW.SETUP)
|
||||
(MODERNWINDOW.SETUP (FUNCTION OBJ.BUTTONEVENTINFN)))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1959 19677 (OBJ.ADDMANYTOW 1969 . 2461) (OBJ.ADDTOW 2463 . 8184) (OBJ.CLEARW 8186 .
|
||||
9312) (OBJ.CREATEW 9314 . 11231) (OBJ.DELFROMW 11233 . 11645) (OBJ.FIND.REGION 11647 . 12112) (
|
||||
OBJ.INSERTOBJECTS 12114 . 17722) (OBJ.MAP.OBJECTS 17724 . 18381) (OBJ.OBJECTS 18383 . 18655) (
|
||||
OBJ.REPLACE 18657 . 19236) (OBJWINDOWP 19238 . 19675)) (19729 94546 (OBJ.APPLY.USER.FN 19739 . 22971)
|
||||
(OBJ.BUTTONEVENTFN 22973 . 23135) (OBJ.BUTTONEVENTINFN 23137 . 25477) (OBJ.CLEAR.EXTENT 25479 . 25775)
|
||||
(OBJ.COMPUTE.IMAGEBOX 25777 . 28122) (OBJ.COMPUTE.REGION 28124 . 28615) (OBJ.COPYBUTTONEVENTFN 28617
|
||||
. 32412) (OBJ.DELFROMW.HORIZONTAL 32414 . 39179) (OBJ.DELFROMW.VERTICAL 39181 . 45808) (
|
||||
OBJ.DRAW.OBJECT 45810 . 47241) (OBJ.END.OF.OBJECT 47243 . 48444) (OBJ.FIND.OBJECT 48446 . 50323) (
|
||||
OBJ.FIND.REGION.HORIZONTAL 50325 . 52166) (OBJ.FIND.REGION.VERTICAL 52168 . 54130) (OBJ.FLIP.OBJECT
|
||||
54132 . 54628) (OBJ.HARDCOPYFN 54630 . 56745) (OBJ.INDEX.OBJECT 56747 . 58275) (OBJ.INSTANTIATE 58277
|
||||
. 59582) (OBJ.MOVETO.LAST.INSTANTIATED.OBJECT 59584 . 60270) (OBJ.RECOMPUTE.EXTENT 60272 . 69818) (
|
||||
OBJ.REPAINTFN 69820 . 72780) (OBJ.REPLACE.HORIZONTAL 72782 . 79298) (OBJ.REPLACE.VERTICAL 79300 .
|
||||
85926) (OBJ.RESHAPEFN 85928 . 86467) (OBJ.SCROLLFN 86469 . 87004) (OBJ.SCROLLFN.HORIZONTAL 87006 .
|
||||
90166) (OBJ.SCROLLFN.VERTICAL 90168 . 94544)))))
|
||||
(FILEMAP (NIL (1926 19945 (OBJ.ADDMANYTOW 1936 . 2428) (OBJ.ADDTOW 2430 . 8151) (OBJ.CLEARW 8153 .
|
||||
9279) (OBJ.CREATEW 9281 . 11499) (OBJ.DELFROMW 11501 . 11913) (OBJ.FIND.REGION 11915 . 12380) (
|
||||
OBJ.INSERTOBJECTS 12382 . 17990) (OBJ.MAP.OBJECTS 17992 . 18649) (OBJ.OBJECTS 18651 . 18923) (
|
||||
OBJ.REPLACE 18925 . 19504) (OBJWINDOWP 19506 . 19943)) (19997 94814 (OBJ.APPLY.USER.FN 20007 . 23239)
|
||||
(OBJ.BUTTONEVENTFN 23241 . 23403) (OBJ.BUTTONEVENTINFN 23405 . 25745) (OBJ.CLEAR.EXTENT 25747 . 26043)
|
||||
(OBJ.COMPUTE.IMAGEBOX 26045 . 28390) (OBJ.COMPUTE.REGION 28392 . 28883) (OBJ.COPYBUTTONEVENTFN 28885
|
||||
. 32680) (OBJ.DELFROMW.HORIZONTAL 32682 . 39447) (OBJ.DELFROMW.VERTICAL 39449 . 46076) (
|
||||
OBJ.DRAW.OBJECT 46078 . 47509) (OBJ.END.OF.OBJECT 47511 . 48712) (OBJ.FIND.OBJECT 48714 . 50591) (
|
||||
OBJ.FIND.REGION.HORIZONTAL 50593 . 52434) (OBJ.FIND.REGION.VERTICAL 52436 . 54398) (OBJ.FLIP.OBJECT
|
||||
54400 . 54896) (OBJ.HARDCOPYFN 54898 . 57013) (OBJ.INDEX.OBJECT 57015 . 58543) (OBJ.INSTANTIATE 58545
|
||||
. 59850) (OBJ.MOVETO.LAST.INSTANTIATED.OBJECT 59852 . 60538) (OBJ.RECOMPUTE.EXTENT 60540 . 70086) (
|
||||
OBJ.REPAINTFN 70088 . 73048) (OBJ.REPLACE.HORIZONTAL 73050 . 79566) (OBJ.REPLACE.VERTICAL 79568 .
|
||||
86194) (OBJ.RESHAPEFN 86196 . 86735) (OBJ.SCROLLFN 86737 . 87272) (OBJ.SCROLLFN.HORIZONTAL 87274 .
|
||||
90434) (OBJ.SCROLLFN.VERTICAL 90436 . 94812)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
438
lispusers/PSEUDOHOSTS
Normal file
438
lispusers/PSEUDOHOSTS
Normal file
@@ -0,0 +1,438 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Jan-2022 12:35:16"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;119 22617
|
||||
|
||||
:CHANGES-TO (VARS PSEUDOHOSTSCOMS)
|
||||
|
||||
:PREVIOUS-DATE "26-Jan-2022 23:33:17"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>PSEUDOHOSTS.;118)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT PSEUDOHOSTSCOMS)
|
||||
|
||||
(RPAQQ PSEUDOHOSTSCOMS
|
||||
[
|
||||
(* ;; "Public entries")
|
||||
|
||||
(FNS PSEUDOHOST PSEUDOHOSTP PSEUDOHOSTS TARGETHOST TRUEFILENAME)
|
||||
|
||||
(* ;; "Internals")
|
||||
|
||||
(FNS EXPAND.PH CONTRACT.PH SLASHIT UNSLASHIT)
|
||||
(FNS OPENFILE.PH GETFILENAME.PH DIRECTORYNAMEP.PH CLOSEFILE.PH REOPENFILE.PH DELETEFILE.PH
|
||||
OPENP.PH UNREGISTERFILE.PH REGISTERFILE.PH GENERATEFILES.PH GETFILEINFO.PH
|
||||
SETFILEINFO.PH NEXTFILEFN.PH FILEINFOFN.PH RENAMEFILE.PH)
|
||||
(P (PSEUDOHOST 'LI LOGINHOST/DIR))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PHDEVICE PHGENFILESTATE)
|
||||
(MACROS PSEUDOHOST.NAME PSEUDOHOST.TARGETVAL)
|
||||
(P (CL:UNLESS (GETP 'EXPORTS.ALL 'FILE)
|
||||
(LOAD 'EXPORTS.ALL))])
|
||||
|
||||
|
||||
|
||||
(* ;; "Public entries")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(PSEUDOHOST
|
||||
[LAMBDA (HOST PREFIX) (* ; "Edited 25-Jan-2022 09:58 by rmk")
|
||||
(* ; "Edited 23-Jan-2022 20:43 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 13:08 by rmk")
|
||||
(CL:WHEN (AND (LISTP HOST)
|
||||
(NULL PREFIX))
|
||||
(SETQ PREFIX (CADR HOST))
|
||||
(SETQ HOST (CAR HOST)))
|
||||
(SETQ HOST (U-CASE (MKATOM HOST)))
|
||||
(IF PREFIX
|
||||
THEN (CL:UNLESS (FILENAMEFIELD PREFIX 'HOST)
|
||||
(SETQ PREFIX (UNSLASHIT (PACKFILENAME 'HOST 'DSK 'BODY PREFIX))))
|
||||
(CL:UNLESS (MEMB (NTHCHARCODE PREFIX -1)
|
||||
(CHARCODE (> / <)))
|
||||
(SETQ PREFIX (CONCAT PREFIX (IF (STRPOS "/" PREFIX)
|
||||
THEN "/"
|
||||
ELSE ">"))))
|
||||
[LET (PREVIOUS TARGETHOST TARGETDEVICE)
|
||||
(CL:WHEN (SETQ PREVIOUS (PSEUDOHOSTP HOST))(* ;
|
||||
"Redefining: first clear out the previous one")
|
||||
(PSEUDOHOST HOST NIL))
|
||||
[SETQ TARGETHOST (U-CASE (FILENAMEFIELD PREFIX 'HOST]
|
||||
|
||||
(* ;; "We know about the directory separators for these particular devices. Maybe there should be separate list of slash-hosts somewhere that we can use.")
|
||||
|
||||
(SELECTQ TARGETHOST
|
||||
((DSK CORE)
|
||||
(SETQ PREFIX (UNSLASHIT PREFIX)))
|
||||
(UNIX (SETQ PREFIX (SLASHIT PREFIX)))
|
||||
NIL)
|
||||
(SETQ TARGETDEVICE (OR (\GETDEVICEFROMHOSTNAME TARGETHOST)
|
||||
(ERROR "UNKNOWN TARGET HOST" TARGETHOST)))
|
||||
|
||||
(* ;; "Save the last directory marker to pack on if needed.")
|
||||
|
||||
(\DEFINEDEVICE HOST (CREATE FDEV
|
||||
USING TARGETDEVICE DEVICENAME _ HOST FDEV1 _ TARGETDEVICE
|
||||
FDEV2 _ (CONS PREFIX (CL:IF (EQ (CHARCODE /)
|
||||
(NTHCHARCODE PREFIX -1
|
||||
))
|
||||
'/
|
||||
'<))
|
||||
OPENFILE _ (FUNCTION OPENFILE.PH)
|
||||
GETFILENAME _ (FUNCTION GETFILENAME.PH)
|
||||
DIRECTORYNAMEP _ (FUNCTION DIRECTORYNAMEP.PH)
|
||||
CLOSEFILE _ (FUNCTION CLOSEFILE.PH)
|
||||
REOPENFILE _ (FUNCTION REOPENFILE.PH)
|
||||
DELETEFILE _ (FUNCTION DELETEFILE.PH)
|
||||
OPENP _ (FUNCTION OPENP.PH)
|
||||
UNREGISTERFILE _ (FUNCTION UNREGISTERFILE.PH)
|
||||
REGISTERFILE _ (FUNCTION REGISTERFILE.PH)
|
||||
GENERATEFILES _ (FUNCTION GENERATEFILES.PH)
|
||||
GETFILEINFO _ (FUNCTION GETFILEINFO.PH)
|
||||
SETFILEINFO _ (FUNCTION SETFILEINFO.PH)
|
||||
RENAMEFILE _ (FUNCTION RENAMEFILE.PH]
|
||||
ELSEIF (PSEUDOHOSTP HOST)
|
||||
THEN (UNINTERRUPTABLY
|
||||
|
||||
(* ;; "\DEFINEDEVICE removes the name-mapping but doesn't remove the device. Maybe that's on purpose for other devices, but not here.")
|
||||
|
||||
(SETQ \FILEDEVICES (DREMOVE (\GETDEVICEFROMNAME HOST \FILEDEVICES)
|
||||
\FILEDEVICES))
|
||||
(\DEFINEDEVICE HOST NIL))
|
||||
ELSE (ERROR HOST "is not a pseudohost"))
|
||||
HOST])
|
||||
|
||||
(PSEUDOHOSTP
|
||||
[LAMBDA (HOST) (* ; "Edited 18-Jan-2022 11:29 by rmk")
|
||||
(LET ((DEV (\GETDEVICEFROMNAME HOST T T)))
|
||||
(CL:WHEN (AND DEV (TYPE? FDEV (FETCH (PHDEVICE TARGETDEV) OF DEV)))
|
||||
(LIST HOST (FETCH (PHDEVICE PREFIX)
|
||||
DEV)))])
|
||||
|
||||
(PSEUDOHOSTS
|
||||
[LAMBDA NIL (* ; "Edited 17-Jan-2022 18:15 by rmk")
|
||||
(FOR DEV IN \FILEDEVICES WHEN (TYPE? FDEV (FETCH (PHDEVICE TARGETDEV) OF DEV))
|
||||
COLLECT (LIST (FETCH (FDEV DEVICENAME) OF DEV)
|
||||
(FETCH (PHDEVICE PREFIX) OF DEV])
|
||||
|
||||
(TARGETHOST
|
||||
[LAMBDA (HOST) (* ; "Edited 22-Jan-2022 09:00 by rmk")
|
||||
(CL:WHEN (PSEUDOHOSTP HOST)
|
||||
(FETCH (FDEV DEVICENAME) OF (FETCH (PHDEVICE TARGETDEV) OF (\GETDEVICEFROMNAME HOST))))])
|
||||
|
||||
(TRUEFILENAME
|
||||
[LAMBDA (FILE) (* ; "Edited 26-Jan-2022 23:33 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 08:47 by rmk")
|
||||
(LET (FILENAME DEVICE)
|
||||
(IF (STREAMP FILE)
|
||||
THEN (SETQ FILENAME (FETCH (STREAM FULLFILENAME) OF FILE))
|
||||
(SETQ DEVICE (FETCH (STREAM DEVICE) OF FILE))
|
||||
ELSE (SETQ FILENAME (\ADD.CONNECTED.DIR FILE))
|
||||
(SETQ DEVICE (\GETDEVICEFROMNAME FILENAME)))
|
||||
(CL:IF (TYPE? PHDEVICE DEVICE)
|
||||
(EXPAND.PH FILENAME DEVICE)
|
||||
FILENAME)])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Internals")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(EXPAND.PH
|
||||
[LAMBDA (FILENAME PHDEV)
|
||||
|
||||
(* ;; "Edited 26-Jan-2022 11:06 by rmk: that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
|
||||
|
||||
(* ;; "Assumes that FILENAME contains }, because HOST was identified in it. If FILENAME is a stream, expand its full name")
|
||||
|
||||
(IF (TYPE? STREAM FILENAME)
|
||||
THEN (CL:UNLESS PHDEV
|
||||
(SETQ PHDEV (FETCH (STREAM DEVICE) OF FILENAME)))
|
||||
(SETQ FILENAME (FETCH (STREAM FULLNAME) OF FILENAME))
|
||||
ELSEIF (NOT (TYPE? FDEV PHDEV))
|
||||
THEN (SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
|
||||
(LET (SUFFIX SUFFIXPOS)
|
||||
(CL:WHEN (SETQ SUFFIXPOS (STRPOS "}" FILENAME))
|
||||
(SETQ SUFFIX (SUBSTRING FILENAME (ADD1 SUFFIXPOS)))
|
||||
(CL:WHEN (FMEMB (CHCON1 SUFFIX)
|
||||
(CHARCODE (< > /)))
|
||||
(SETQ SUFFIX (SUBSTRING SUFFIX 2)))
|
||||
(CONCAT (FETCH (PHDEVICE PREFIX) OF PHDEV)
|
||||
SUFFIX))])
|
||||
|
||||
(CONTRACT.PH
|
||||
[LAMBDA (NAME PHDEV) (* ; "Edited 25-Jan-2022 09:44 by rmk")
|
||||
(* ; "Edited 20-Jan-2022 20:04 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 22:54 by rmk")
|
||||
(* ; "Edited 16-Jan-2022 19:57 by rmk")
|
||||
(* ; "Edited 14-Jan-2022 00:03 by rmk")
|
||||
(CL:UNLESS (TYPE? FDEV PHDEV)
|
||||
(SETQ PHDEV (\GETDEVICEFROMNAME PHDEV)))
|
||||
(CL:WHEN NAME
|
||||
(LET* [(PREFIX (FETCH (PHDEVICE PREFIX) OF PHDEV))
|
||||
(CONNECTOR (FETCH (PHDEVICE CONNECTOR) OF PHDEV))
|
||||
(SUFFIX (SUBSTRING NAME (ADD1 (NCHARS PREFIX]
|
||||
(IF (STRPOS PREFIX NAME 1 NIL T NIL FILEDIRCASEARRAY)
|
||||
THEN (CL:WHEN (STRPOS ">" SUFFIX 1 NIL NIL NIL FILEDIRCASEARRAY)
|
||||
|
||||
(* ;; "Must be a subdirectory. (CDR INFO) tells us whether to use / or > depending on what the prefix has")
|
||||
|
||||
[SETQ SUFFIX (CONCAT CONNECTOR (IF (EQ CONNECTOR '/)
|
||||
THEN (SLASHIT SUFFIX)
|
||||
ELSE (UNSLASHIT SUFFIX])
|
||||
(PACK* '{ (FETCH (FDEV DEVICENAME) OF PHDEV)
|
||||
"}"
|
||||
(OR SUFFIX ""))
|
||||
ELSE
|
||||
(* ;; "If the target's NAME didn't begin with the prefix, then the caller must have jumped outside the pseudo root. So just return the NAME")
|
||||
|
||||
NAME)))])
|
||||
|
||||
(SLASHIT
|
||||
[LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:08 by rmk")
|
||||
(* ; "Edited 3-Jan-2022 11:44 by rmk")
|
||||
(* ; "Edited 22-Dec-2021 20:18 by rmk")
|
||||
(* ; "Edited 2-Nov-2021 22:54 by rmk:")
|
||||
(LET [LASTDIRPOS SLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
|
||||
0]
|
||||
[SETQ SLASHED (CONCATCODES (FOR I C FROM DIRPOS WHILE (SETQ C (NTHCHARCODE X I))
|
||||
COLLECT (SELCHARQ C
|
||||
((< >)
|
||||
(SETQ LASTDIRPOS I)
|
||||
(CHARCODE /))
|
||||
(/ (SETQ LASTDIRPOS I)
|
||||
C)
|
||||
C]
|
||||
(CL:WHEN (AND LCASEDIRS LASTDIRPOS)
|
||||
(SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
|
||||
(SETQ SLASHED (CONCAT (L-CASE (SUBSTRING SLASHED 1 LASTDIRPOS))
|
||||
(OR (SUBSTRING SLASHED (ADD1 LASTDIRPOS))
|
||||
""))))
|
||||
(CL:IF (EQ DIRPOS 1)
|
||||
SLASHED
|
||||
(CONCAT (SUBSTRING X 1 (SUB1 DIRPOS))
|
||||
SLASHED))])
|
||||
|
||||
(UNSLASHIT
|
||||
[LAMBDA (X LCASEDIRS) (* ; "Edited 26-Jan-2022 15:09 by rmk")
|
||||
(* ; "Edited 22-Dec-2021 20:18 by rmk")
|
||||
(* ; "Edited 21-Nov-2021 23:00 by rmk:")
|
||||
|
||||
(* ;; "Tricky to get the first one right.")
|
||||
|
||||
(LET [LASTDIRPOS UNSLASHED (DIRPOS (ADD1 (OR (STRPOS "}" X)
|
||||
0]
|
||||
[SETQ UNSLASHED
|
||||
(CONCATCODES (FOR I C LASTC FROM DIRPOS WHILE (SETQ C (NTHCHARCODE X I))
|
||||
COLLECT (PROG1 (SELCHARQ C
|
||||
(/ (SETQ LASTDIRPOS I)
|
||||
(IF (AND LASTC (NEQ LASTC (CHARCODE })))
|
||||
THEN (CHARCODE >)
|
||||
ELSE (CHARCODE <)))
|
||||
((< >)
|
||||
(SETQ LASTDIRPOS I)
|
||||
C)
|
||||
C)
|
||||
(SETQ LASTC C]
|
||||
(CL:WHEN (AND LCASEDIRS LASTDIRPOS)
|
||||
(SETQ LASTDIRPOS (ADD1 (IDIFFERENCE LASTDIRPOS DIRPOS)))
|
||||
(SETQ UNSLASHED (CONCAT (L-CASE (SUBSTRING UNSLASHED 1 LASTDIRPOS))
|
||||
(OR (SUBSTRING UNSLASHED (ADD1 LASTDIRPOS))
|
||||
""))))
|
||||
(CL:IF (EQ DIRPOS 1)
|
||||
UNSLASHED
|
||||
(CONCAT (SUBSTRING X 1 (SUB1 DIRPOS))
|
||||
UNSLASHED))])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(OPENFILE.PH
|
||||
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING) (* ; "Edited 25-Jan-2022 08:45 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 10:29 by rmk")
|
||||
(LET ((STREAM (PSEUDOHOST.TARGETVAL OPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTRING)
|
||||
FDEV)))
|
||||
(CHANGE (FETCH (STREAM FULLFILENAME) OF STREAM)
|
||||
(CONTRACT.PH DATUM FDEV))
|
||||
(REPLACE (STREAM DEVICE) OF STREAM WITH FDEV)
|
||||
STREAM])
|
||||
|
||||
(GETFILENAME.PH
|
||||
[LAMBDA (NAME RECOG FDEV) (* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
(* ; "Edited 16-Jan-2022 20:27 by rmk")
|
||||
(PSEUDOHOST.NAME GETFILENAME (NAME RECOG FDEV])
|
||||
|
||||
(DIRECTORYNAMEP.PH
|
||||
[LAMBDA (DIRSPEC DEV CREATE?) (* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 11:32 by rmk")
|
||||
|
||||
(* ;; "{FOO} by itself is always a legitimate directory--you should be able to connect to it when you are starting up")
|
||||
(* ; "Edited 16-Jan-2022 20:35 by rmk")
|
||||
(OR (EQ (CHARCODE })
|
||||
(NTHCHARCODE DIRSPEC -1))
|
||||
(PSEUDOHOST.NAME DIRECTORYNAMEP (DIRSPEC DEV CREATE?)
|
||||
DEV])
|
||||
|
||||
(CLOSEFILE.PH
|
||||
[LAMBDA (STREAM ABORTFLG) (* ; "Edited 16-Jan-2022 15:38 by rmk")
|
||||
(APPLY* (FETCH (FDEV CLOSEFILE) OF (FETCH (PHDEVICE TARGETDEV) OF (FETCH (STREAM DEVICE)
|
||||
OF STREAM)))
|
||||
STREAM ABORTFLG])
|
||||
|
||||
(REOPENFILE.PH
|
||||
[LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 25-Jan-2022 12:50 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 11:41 by rmk")
|
||||
(LET ((STREAM (PSEUDOHOST.TARGETVAL REOPENFILE (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)
|
||||
FDEV)))
|
||||
(CHANGE (FETCH (STREAM FULLFILENAME) OF STREAM)
|
||||
(CONTRACT.PH DATUM FDEV))
|
||||
(REPLACE (STREAM DEVICE) OF STREAM WITH FDEV)
|
||||
STREAM])
|
||||
|
||||
(DELETEFILE.PH
|
||||
[LAMBDA (FILENAME DEV) (* ; "Edited 25-Jan-2022 22:56 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 10:23 by rmk")
|
||||
(PSEUDOHOST.NAME DELETEFILE (FILENAME DEV])
|
||||
|
||||
(OPENP.PH
|
||||
[LAMBDA (FILENAME ACCESS DEVICE) (* ; "Edited 18-Jan-2022 10:29 by rmk")
|
||||
(PSEUDOHOST.TARGETVAL OPENP (FILENAME ACCESS DEVICE])
|
||||
|
||||
(UNREGISTERFILE.PH
|
||||
[LAMBDA (DEVICE STREAM) (* ; "Edited 16-Jan-2022 16:47 by rmk")
|
||||
(APPLY* (FETCH (FDEV UNREGISTERFILE) OF (FETCH (PHDEVICE TARGETDEV) OF DEVICE))
|
||||
(FETCH (PHDEVICE TARGETDEV) OF DEVICE)
|
||||
STREAM])
|
||||
|
||||
(REGISTERFILE.PH
|
||||
[LAMBDA (DEVICE STREAM) (* ; "Edited 16-Jan-2022 16:46 by rmk")
|
||||
(APPLY* (FETCH (FDEV REGISTERFILE) OF (FETCH (PHDEVICE TARGETDEV) OF DEVICE))
|
||||
(FETCH (PHDEVICE TARGETDEV) OF DEVICE)
|
||||
STREAM])
|
||||
|
||||
(GENERATEFILES.PH
|
||||
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 17-Jan-2022 20:46 by rmk")
|
||||
|
||||
(* ;; "FDEV is the pseudohost. We will generate from the target directory using its GENFILESTATE, but fiddle the output so that it looks like it is coming from the pseudo host.")
|
||||
|
||||
(LET ((TARGETGENOBJ (APPLY* (FETCH (FDEV GENERATEFILES) OF (FETCH (PHDEVICE TARGETDEV)
|
||||
OF FDEV))
|
||||
(FETCH (PHDEVICE TARGETDEV) OF FDEV)
|
||||
(EXPAND.PH PATTERN FDEV)
|
||||
DESIREDPROPS OPTIONS)))
|
||||
|
||||
(* ;; "The TARGETGENOBJ contains the targets functions as well as its GENFILESTATE. We need the ph FDEV to contract the generated names")
|
||||
|
||||
(CREATE FILEGENOBJ
|
||||
NEXTFILEFN _ (FUNCTION NEXTFILEFN.PH)
|
||||
FILEINFOFN _ (FUNCTION FILEINFOFN.PH)
|
||||
GENFILESTATE _ (LIST FDEV TARGETGENOBJ])
|
||||
|
||||
(GETFILEINFO.PH
|
||||
[LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 25-Jan-2022 12:43 by rmk")
|
||||
(* ; "Edited 17-Jan-2022 18:21 by rmk")
|
||||
(PSEUDOHOST.TARGETVAL GETFILEINFO (STREAM ATTRIBUTE DEVICE])
|
||||
|
||||
(SETFILEINFO.PH
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 25-Jan-2022 12:37 by rmk")
|
||||
(PSEUDOHOST.TARGETVAL SETFILEINFO (STREAM ATTRIBUTE VALUE DEVICE])
|
||||
|
||||
(NEXTFILEFN.PH
|
||||
[LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 17-Jan-2022 21:27 by rmk")
|
||||
(LET* ((TARGETGENOBJ (CADR GENFILESTATE))
|
||||
(TARGETGENFILESTATE (FETCH GENFILESTATE OF TARGETGENOBJ))
|
||||
(FILENAME (APPLY* (FETCH NEXTFILEFN OF TARGETGENOBJ)
|
||||
TARGETGENFILESTATE NAMEONLY)))
|
||||
(CL:WHEN FILENAME
|
||||
(CL:UNLESS NAMEONLY
|
||||
(SETQ FILENAME (CONTRACT.PH FILENAME (CAR GENFILESTATE)))))
|
||||
FILENAME])
|
||||
|
||||
(FILEINFOFN.PH
|
||||
[LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 17-Jan-2022 20:52 by rmk")
|
||||
(APPLY* (FETCH FILEINFOFN OF (CADR GENFILESTATE))
|
||||
(FETCH GENFILESTATE OF (CADR GENFILESTATE))
|
||||
ATTRIBUTE])
|
||||
|
||||
(RENAMEFILE.PH
|
||||
[LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 18-Jan-2022 09:52 by rmk")
|
||||
(LET ((OLDTARGETDEV (FETCH (PHDEVICE TARGETDEV) OF OLD-DEVICE))
|
||||
(NEWTARGETDEV (FETCH (PHDEVICE TARGETDEV) OF NEW-DEVICE))
|
||||
(NEWTARGETNAME NEW-NAME)
|
||||
RESULT)
|
||||
(CL:WHEN (TYPE? FDEV NEWTARGETDEV) (* ; "NEW-DEVICE is a pseudo host")
|
||||
(SETQ NEWTARGETNAME (EXPAND.PH NEW-NAME NEW-DEVICE)))
|
||||
(SETQ RESULT (APPLY* (FETCH (FDEV RENAMEFILE) OF OLDTARGETDEV)
|
||||
OLDTARGETDEV
|
||||
(EXPAND.PH OLD-NAME OLD-DEVICE)
|
||||
(OR NEWTARGETDEV NEW-DEVICE)
|
||||
NEWTARGETNAME))
|
||||
(CL:WHEN (AND RESULT (NEQ NEWTARGETDEV NEW-DEVICE))
|
||||
(SETQ RESULT (CONTRACT.PH RESULT NEW-DEVICE)))
|
||||
RESULT])
|
||||
)
|
||||
|
||||
(PSEUDOHOST 'LI LOGINHOST/DIR)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS PHDEVICE [(PREFIX (CAR (FETCH (FDEV FDEV2) OF DATUM)))
|
||||
(TARGETDEV (FETCH (FDEV FDEV1) OF DATUM)
|
||||
(REPLACE (FDEV FDEV1) OF DATUM WITH NEWVALUE))
|
||||
(CONNECTOR (CDR (FETCH (FDEV FDEV2) OF DATUM]
|
||||
(TYPE? (FETCH (PHDEVICE PREFIX) OF DATUM)))
|
||||
|
||||
(RECORD PHGENFILESTATE (PHDEVICE . TARGETGENFILESTATE))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PSEUDOHOST.NAME MACRO
|
||||
[TAIL (LET [(OPNAME (CAR TAIL))
|
||||
(ARGS (CADR TAIL))
|
||||
(DEV (OR (CADDR TAIL)
|
||||
(CAR (LAST (CADR TAIL]
|
||||
|
||||
(* ;;
|
||||
"Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately")
|
||||
|
||||
`(CONTRACT.PH [APPLY* (FETCH (FDEV ,OPNAME) OF (FETCH (PHDEVICE TARGETDEV)
|
||||
OF ,DEV))
|
||||
(EXPAND.PH ,(CAR ARGS)
|
||||
,DEV)
|
||||
,@(SUBST `(FETCH (PHDEVICE TARGETDEV) OF ,DEV)
|
||||
DEV
|
||||
(CDR ARGS]
|
||||
,DEV])
|
||||
|
||||
(PUTPROPS PSEUDOHOST.TARGETVAL MACRO
|
||||
[TAIL (LET [(OPNAME (CAR TAIL))
|
||||
(ARGS (CADR TAIL))
|
||||
(DEV (OR (CADDR TAIL)
|
||||
(CAR (LAST (CADR TAIL]
|
||||
|
||||
(* ;; "Assumes that the name is (CAR ARGS), the device is the last or args if not specified separately. Unlike PSEUDOHOST.OP, this returns the target value, doesn't assume it is a name to be contracted.")
|
||||
|
||||
`(APPLY* (FETCH (FDEV ,OPNAME) OF (FETCH (PHDEVICE TARGETDEV)
|
||||
OF ,DEV))
|
||||
(EXPAND.PH ,(CAR ARGS)
|
||||
,DEV)
|
||||
,@(SUBST `(FETCH (PHDEVICE TARGETDEV) OF ,DEV)
|
||||
DEV
|
||||
(CDR ARGS])
|
||||
)
|
||||
|
||||
|
||||
(CL:UNLESS (GETP 'EXPORTS.ALL 'FILE)
|
||||
(LOAD 'EXPORTS.ALL))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1205 7096 (PSEUDOHOST 1215 . 5418) (PSEUDOHOSTP 5420 . 5770) (PSEUDOHOSTS 5772 . 6129)
|
||||
(TARGETHOST 6131 . 6405) (TRUEFILENAME 6407 . 7094)) (7124 13330 (EXPAND.PH 7134 . 8189) (CONTRACT.PH
|
||||
8191 . 10010) (SLASHIT 10012 . 11580) (UNSLASHIT 11582 . 13328)) (13331 20121 (OPENFILE.PH 13341 .
|
||||
13902) (GETFILENAME.PH 13904 . 14193) (DIRECTORYNAMEP.PH 14195 . 14819) (CLOSEFILE.PH 14821 . 15175) (
|
||||
REOPENFILE.PH 15177 . 15742) (DELETEFILE.PH 15744 . 16028) (OPENP.PH 16030 . 16206) (UNREGISTERFILE.PH
|
||||
16208 . 16513) (REGISTERFILE.PH 16515 . 16816) (GENERATEFILES.PH 16818 . 17858) (GETFILEINFO.PH 17860
|
||||
. 18162) (SETFILEINFO.PH 18164 . 18363) (NEXTFILEFN.PH 18365 . 18907) (FILEINFOFN.PH 18909 . 19180) (
|
||||
RENAMEFILE.PH 19182 . 20119)))))
|
||||
STOP
|
||||
BIN
lispusers/PSEUDOHOSTS.LCOM
Normal file
BIN
lispusers/PSEUDOHOSTS.LCOM
Normal file
Binary file not shown.
BIN
lispusers/PSEUDOHOSTS.TEDIT
Normal file
BIN
lispusers/PSEUDOHOSTS.TEDIT
Normal file
Binary file not shown.
634
lispusers/REGIONMANAGER
Normal file
634
lispusers/REGIONMANAGER
Normal file
@@ -0,0 +1,634 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Jan-2022 13:24:29"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;106 34264
|
||||
|
||||
:CHANGES-TO (FNS RELCREATEREGION \RELCREATEREGION.SIZE RELGETREGION)
|
||||
|
||||
:PREVIOUS-DATE "25-Jan-2022 15:38:10"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;105)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT REGIONMANAGERCOMS)
|
||||
|
||||
(RPAQQ REGIONMANAGERCOMS
|
||||
[
|
||||
(* ;; "Typed regions")
|
||||
|
||||
[COMS (FNS SET-TYPED-REGIONS)
|
||||
(FNS RM-CREATEW RM-CLOSEW RM-GETREGION CLOSE-TYPED-W)
|
||||
(INITVARS (TYPED-REGIONS))
|
||||
(GLOBALVARS TYPED-REGIONS)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TYPED-REGION REGION-SOURCE))
|
||||
(INITRECORDS TYPED-REGION REGION-SOURCE)
|
||||
(P (MOVD? 'CREATEW 'CREATEW.ORIG)
|
||||
(MOVD? 'CLOSEW 'CLOSEW.ORIG)
|
||||
(MOVD? 'GETREGION 'GETREGION.ORIG)
|
||||
(MOVD 'RM-CREATEW 'CREATEW)
|
||||
(MOVD 'RM-CLOSEW 'CLOSEW)
|
||||
(MOVD 'RM-GETREGION 'GETREGION]
|
||||
|
||||
(* ;; "Relative regions")
|
||||
|
||||
(COMS (FNS RELCREATEREGION RELGETREGION RELCREATEPOSITION)
|
||||
(FNS \RELCREATEREGION.REF \RELCREATEREGION.SIZE))
|
||||
|
||||
(* ;; "Composite application construction")
|
||||
|
||||
(COMS (FNS RM-ATTACHWINDOW)
|
||||
(P (MOVD? 'ATTACHWINDOW 'ATTACHWINDOW.ORIG)
|
||||
(MOVD 'RM-ATTACHWINDOW 'ATTACHWINDOW))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS RFIELDDIFF])
|
||||
|
||||
|
||||
|
||||
(* ;; "Typed regions")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(SET-TYPED-REGIONS
|
||||
[LAMBDA (TYPELISTS REPLACE) (* ; "Edited 2-Jan-2022 16:01 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 16:17 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 12:59 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 08:55 by rmk:")
|
||||
(* ; "Edited 26-Oct-2021 18:04 by rmk:")
|
||||
|
||||
(* ;; "User can pre-initialize a sequence of regions for a given type. Generally, TYPELISTS is a list of the form")
|
||||
|
||||
(* ;; " ((TYPEATOM1 . REGIONS)...(TYPEATOMn . REGIONS). Copies of the regions of TYPELIST are added in front of any regions that might already be present for that type. The regions have haslinks to its type and an inuse status indicator.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Convenience cases:")
|
||||
|
||||
(* ;;
|
||||
" TYPEATOM: Interpreted as ((TYPEATOM)): No region specified, but regions can accumulate")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " (TYPEATOM .REGIONS): Interpreted as ((TYPEATOM . REGIONS).")
|
||||
|
||||
(if (LITATOM TYPELISTS)
|
||||
then (SETQ TYPELISTS (CONS (CONS TYPELISTS)))
|
||||
elseif (LITATOM (LISTP TYPELISTS))
|
||||
then (SETQ TYPELISTS (CONS TYPELISTS)))
|
||||
(for TL TYPE REGIONS PREV in TYPELISTS
|
||||
do (SETQ TYPE (CAR TL))
|
||||
(SETQ REGIONS (CDR TL))
|
||||
(CL:UNLESS (AND TYPE (LITATOM TYPE)
|
||||
(for R in REGIONS always (REGIONP R)))
|
||||
(ERROR "Not a TYPED-REGIONS specification" REGIONS))
|
||||
(SETQ REGIONS (COPY REGIONS)) (* ;
|
||||
"Not to be confused with any other equal regions.")
|
||||
(if (SETQ PREV (ASSOC TYPE TYPED-REGIONS))
|
||||
then [RPLACD PREV (CL:IF REPLACE
|
||||
REGIONS
|
||||
(NCONC REGIONS (CDR PREV)))]
|
||||
else (push TYPED-REGIONS (CONS TYPE REGIONS])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(RM-CREATEW
|
||||
[LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 1-Jan-2022 23:12 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 19:25 by rmk")
|
||||
|
||||
(* ;; "Generic CREATEW function for managed regions. If REGIONTYPE is specified (as REGION or in PROPS), then we try to find a previous region for that type that is currently unused, create one if needed.")
|
||||
|
||||
(* ;; "We have to bracket the original window creation because the we have to mark that the window uses that region, to put it back in the pool when the window is closed.")
|
||||
|
||||
(LET (WINDOW REGIONTYPE TYPEDREGION TYPELIST)
|
||||
[SETQ REGIONTYPE (if (AND REGION (LITATOM REGION))
|
||||
then (PROG1 REGION (SETQ REGION NIL))
|
||||
else (LISTGET PROPS 'REGION-TYPE]
|
||||
(SETQ TYPELIST (ASSOC REGIONTYPE TYPED-REGIONS))
|
||||
|
||||
(* ;; "We have REGIONTYPE, but maybe also a region that already has a source. Maybe we should make sure that the source is of that type?")
|
||||
|
||||
(* ;; "Note: REGION can also be a screenregion, that falls through.")
|
||||
|
||||
(IF (REGIONP REGION)
|
||||
THEN (SETQ TYPEDREGION (FETCH REGION-SOURCE OF REGION))
|
||||
ELSEIF TYPELIST
|
||||
THEN
|
||||
(* ;;
|
||||
"If we don't find an unused region, CREATEW will create one in the ordinary way. We type it below.")
|
||||
|
||||
[SETQ TYPEDREGION (FIND R FOUND in (CDR TYPELIST)
|
||||
SUCHTHAT (NOT (fetch REGION-INUSE of R]
|
||||
(SETQ REGION TYPEDREGION))
|
||||
(SETQ WINDOW (CREATEW.ORIG REGION TITLE BORDERSIZE NOOPENFLG PROPS))
|
||||
|
||||
(* ;; "CREATEW doesn't call the user-entry GETREGION, so we have to trap and install its return region here.")
|
||||
|
||||
(CL:WHEN (AND TYPELIST (NULL TYPEDREGION)) (* ;
|
||||
"If not, we don't record this even if typed.")
|
||||
(SETQ TYPEDREGION (OR (FETCH REGION-SOURCE OF (SETQ REGION (WINDOWREGION WINDOW)))
|
||||
(COPY REGION)))
|
||||
(NCONC1 TYPELIST TYPEDREGION))
|
||||
(CL:WHEN TYPEDREGION
|
||||
(replace REGION-INUSE of TYPEDREGION with T)
|
||||
(WINDOWPROP WINDOW 'TYPED-REGION TYPEDREGION)
|
||||
(WINDOWPROP WINDOW 'REGION-TYPE REGIONTYPE))
|
||||
WINDOW])
|
||||
|
||||
(RM-CLOSEW
|
||||
[LAMBDA (WINDOW) (* ; "Edited 29-Dec-2021 15:44 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 11:02 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 10:00 by rmk:")
|
||||
(* ; "Edited 26-Oct-2021 21:54 by rmk:")
|
||||
(* ;
|
||||
"Edited 25-Apr-94 10:08 by sybalsky")
|
||||
(* ; "")
|
||||
|
||||
(* ;;
|
||||
"Makes the window's typed region available for reuse, if the window is marked with a TYPEDREGION.")
|
||||
|
||||
(* ;; "It's possible that the window exists and can be reopened after it has been closed. The glitch in that case is that we may have decided to make the window's region available to another window, and if this window is opened again it will come on top of that other one (if it hasn't moved). Oh well.")
|
||||
|
||||
(LET [(TYPEDREGION (WINDOWPROP WINDOW 'TYPED-REGION]
|
||||
(CL:WHEN (AND (CLOSEW.ORIG WINDOW)
|
||||
TYPEDREGION)
|
||||
(REPLACE REGION-INUSE OF TYPEDREGION WITH NIL)
|
||||
(WINDOWPROP WINDOW 'TYPED-REGION NIL)
|
||||
T)])
|
||||
|
||||
(RM-GETREGION
|
||||
[LAMBDA (MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS)
|
||||
(* ; "Edited 1-Jan-2022 21:49 by rmk")
|
||||
|
||||
(* ;; "If INITREGION is a type atom and a region of that type is available, then use it as the INITREGION. Otherwise, add a copy of the new region to the available list, and assert that the new region has the copy as its source.")
|
||||
|
||||
(* ;; "We don't know what will happen to the new region, but if it ends up as a region for CREATEW, the source information enables us to mark its source as inuse.")
|
||||
|
||||
(* ;; "This allows for the possibility that the application is actually asking the user for a constellation region that will be shrunk in anticipation of future satellite attachments. A future retrieval will return the original size and position, and it will then presumably be shrunk in the same way.")
|
||||
|
||||
(LET (REGION (TYPELIST (ASSOC (CL:WHEN (AND INITREGION (LITATOM INITREGION))
|
||||
INITREGION)
|
||||
TYPED-REGIONS)))
|
||||
(FOR R in (CDR TYPELIST) UNLESS (fetch REGION-INUSE of R)
|
||||
WHEN [AND (OR (NULL MINWIDTH)
|
||||
(ILEQ MINWIDTH (FETCH WIDTH OF R)))
|
||||
(OR (NULL MINHEIGHT)
|
||||
(ILEQ MINHEIGHT (FETCH HEIGHT OF R]
|
||||
DO
|
||||
(* ;; "Copy so the caller can update the region without affecting the recyclable source, but remember what it is based on. We don't mark it as used here, maybe a window won't be built around it and it will fade away. However, there is the risk that another GETREGION will find the same source before it is given to a window, in which case 2 windows might open up in the same place.")
|
||||
|
||||
(SETQ REGION (COPY R))
|
||||
(REPLACE REGION-SOURCE OF REGION WITH R)
|
||||
(RETURN))
|
||||
|
||||
(* ;; "If we found a good one, we're done. Otherwise, run the normal code, but save the new region if it is typed.")
|
||||
|
||||
(CL:UNLESS REGION
|
||||
(SETQ REGION (GETREGION.ORIG MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG
|
||||
INITCORNERS))
|
||||
(CL:WHEN TYPELIST
|
||||
|
||||
(* ;;
|
||||
"The new region is based on a typed region. The saved source is a copy of what we return.")
|
||||
|
||||
(NCONC1 TYPELIST (REPLACE REGION-SOURCE OF REGION WITH (COPY REGION)))))
|
||||
REGION])
|
||||
|
||||
(CLOSE-TYPED-W
|
||||
[LAMBDA (TYPE) (* ; "Edited 29-Dec-2021 15:58 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 11:50 by rmk:")
|
||||
|
||||
(* ;; "Closes all windows of REGIONTYPE inside TYPE")
|
||||
|
||||
(CL:WHEN TYPE
|
||||
(for W R in (OPENWINDOWS) when (AND (SETQ WT (WINDOWPROP W 'REGION-TYPE))
|
||||
(EQMEMB WT TYPE)) do (CLOSEW W)))])
|
||||
)
|
||||
|
||||
(RPAQ? TYPED-REGIONS )
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS TYPED-REGIONS)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(HASHLINK TYPED-REGION (REGION-INUSE REGION-INUSE-HASH))
|
||||
|
||||
(HASHLINK REGION-SOURCE (REGION-SOURCE REGION-SOURCE-HASH))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-INUSE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-INUSE-HASH NIL)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-SOURCE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-SOURCE-HASH NIL)
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-INUSE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-INUSE-HASH NIL)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-SOURCE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-SOURCE-HASH NIL)
|
||||
|
||||
(MOVD? 'CREATEW 'CREATEW.ORIG)
|
||||
|
||||
(MOVD? 'CLOSEW 'CLOSEW.ORIG)
|
||||
|
||||
(MOVD? 'GETREGION 'GETREGION.ORIG)
|
||||
|
||||
(MOVD 'RM-CREATEW 'CREATEW)
|
||||
|
||||
(MOVD 'RM-CLOSEW 'CLOSEW)
|
||||
|
||||
(MOVD 'RM-GETREGION 'GETREGION)
|
||||
|
||||
|
||||
|
||||
(* ;; "Relative regions")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(RELCREATEREGION
|
||||
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) (* ; "Edited 27-Jan-2022 13:23 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 15:29 by rmk")
|
||||
(* ; "Edited 23-Jan-2022 21:18 by rmk")
|
||||
(* ; "Edited 12-Jan-2022 17:50 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 20:54 by rmk")
|
||||
(* ; "Edited 27-Dec-2021 15:54 by rmk")
|
||||
|
||||
(* ;; "The region is oriented so that he REFX and REFY are at the corner named by CORNERX/Y. ")
|
||||
|
||||
(* ;; "Creates a WIDTH-HEIGHT region relative to the CORNER and REF parameters.")
|
||||
|
||||
(* ;; "CORNERX and CORNERY default to LEFT and BOTTOM. ")
|
||||
|
||||
(* ;; "REFX and REFY default to the current cursor screen coordinates. Otherwise, ")
|
||||
|
||||
(* ;; " REFX is a position and REFY is NIL: REFX and REFY are extracted from the position")
|
||||
|
||||
(* ;; " Positive integers: absolute screen coordinates")
|
||||
|
||||
(* ;;
|
||||
" (region spec) or (window spec) pairs: coordinates relative to the region or the window's region")
|
||||
|
||||
(* ;; " Spec can name the X/Y endpoints (e.g. LEFT/0 or RIGHT/1) or a floating point proportion of the distance on the relevant dimension (e.g. .5= the midpoint.")
|
||||
|
||||
(* ;; "If ONSCREEN, the width or height is adjusted so that the corner opposite to the fixed corner is always visible.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "The arguments can be given as a list to be spread out, so that region relative region specifications can be passed through intermediate functions. The test here is not very tight, if it is incorrect the recursive call will fail.")
|
||||
|
||||
(IF (AND (LISTP WIDTH)
|
||||
(NOT (REGIONP WIDTH))
|
||||
(NULL HEIGHT)
|
||||
(IGREATERP (LENGTH WIDTH)
|
||||
3))
|
||||
THEN
|
||||
(* ;; "If less than 3, presumably a relative width")
|
||||
|
||||
(APPLY (FUNCTION RELCREATEREGION)
|
||||
WIDTH)
|
||||
ELSE
|
||||
(* ;; "Resolve the width and height, if based on a region or window ")
|
||||
|
||||
(SETQ WIDTH (\RELCREATEREGION.SIZE WIDTH 'X))
|
||||
(SETQ HEIGHT (\RELCREATEREGION.SIZE HEIGHT 'Y))
|
||||
|
||||
(* ;; "Resolve the corner")
|
||||
|
||||
(CL:UNLESS CORNERX
|
||||
(SETQ CORNERX 'LEFT))
|
||||
(CL:UNLESS CORNERY
|
||||
(SETQ CORNERY 'BOTTOM))
|
||||
(CL:WHEN (AND (LISTP CORNERX)
|
||||
(NULL CORNERY))
|
||||
(SETQ CORNERY (CADR CORNERX))
|
||||
(SETQ CORNERX (CAR CORNERX)))
|
||||
|
||||
(* ;; "Resolve the reference point")
|
||||
|
||||
[IF (AND (POSITIONP REFX)
|
||||
(NULL REFY))
|
||||
THEN (SETQ REFY (FETCH (POSITION YCOORD) OF REFX))
|
||||
(SETQ REFX (FETCH (POSITION XCOORD) OF REFX))
|
||||
ELSE (GETMOUSESTATE)
|
||||
(SETQ REFX (\RELCREATEREGION.REF REFX 'X))
|
||||
(SETQ REFY (\RELCREATEREGION.REF REFY 'Y]
|
||||
|
||||
(* ;; "Align the new-region corner with the reference point")
|
||||
|
||||
(LET* ((LEFT REFX)
|
||||
(BOTTOM REFY)
|
||||
(RIGHT (IPLUS LEFT WIDTH))
|
||||
(TOP (IPLUS BOTTOM HEIGHT)))
|
||||
(CL:WHEN (EQ 'RIGHT CORNERX)
|
||||
(SETQ RIGHT LEFT)
|
||||
(SETQ LEFT (IDIFFERENCE LEFT WIDTH)))
|
||||
(CL:WHEN (EQ 'TOP CORNERY)
|
||||
(SETQ TOP BOTTOM)
|
||||
(SETQ BOTTOM (IDIFFERENCE BOTTOM HEIGHT)))
|
||||
(CL:WHEN ONSCREEN (* ; "Keep the region on the screen. Not clear whether we should keep the width and height and just move the left and bottom. Here we allow some shrinkage")
|
||||
(CL:WHEN (ILESSP LEFT 0)
|
||||
(ADD WIDTH (IMIN 100 LEFT))
|
||||
(SETQ LEFT 0))
|
||||
(CL:WHEN (ILESSP BOTTOM 0)
|
||||
(ADD HEIGHT (IMIN 100 BOTTOM))
|
||||
(SETQ BOTTOM 0))
|
||||
(CL:WHEN (IGREATERP RIGHT SCREENWIDTH)
|
||||
(ADD WIDTH (IDIFFERENCE SCREENWIDTH RIGHT)))
|
||||
(CL:WHEN (IGREATERP TOP SCREENHEIGHT)
|
||||
(ADD HEIGHT (IDIFFERENCE SCREENHEIGHT TOP))))
|
||||
(CREATEREGION LEFT BOTTOM WIDTH HEIGHT])
|
||||
|
||||
(RELGETREGION
|
||||
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY MINSIZE) (* ; "Edited 27-Jan-2022 13:24 by rmk")
|
||||
(* ; "Edited 25-Jan-2022 15:30 by rmk")
|
||||
(* ; "Edited 23-Jan-2022 21:20 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 23:13 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 10:15 by rmk")
|
||||
|
||||
(* ;; "Prompts for a relative region as created by RELCREATEREGION. Initially the anchored corner is fixed and the cursor is moved to the diagonally opposite corner. If MINSIZE, the WIDTH and HEIGHT are taken to be the minimums that are acceptable, modulo the fact that the opposite corner is guaranteed to be visibleand, the size of the ghost region can only grow. If not MINSIZE, we also allow the user to shrink the ghost region.")
|
||||
|
||||
(COND
|
||||
((AND (LISTP WIDTH)
|
||||
(NOT (REGIONP WIDTH))
|
||||
(NULL HEIGHT)
|
||||
(IGREATERP (LENGTH WIDTH)
|
||||
3))
|
||||
(APPLY (FUNCTION RELGETREGION)
|
||||
WIDTH))
|
||||
(T (CL:WHEN (AND (LISTP CORNERX)
|
||||
(NULL CORNERY))
|
||||
(SETQ CORNERY (CADR CORNERX))
|
||||
(SETQ CORNERX (CAR CORNERX)))
|
||||
(CL:UNLESS CORNERX
|
||||
(SETQ CORNERX 'LEFT))
|
||||
(CL:UNLESS CORNERY
|
||||
(SETQ CORNERY 'BOTTOM))
|
||||
(LET* ((REGION (OR (REGIONP WIDTH)
|
||||
(RELCREATEREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY T)))
|
||||
(BASEX (FETCH (REGION LEFT) OF REGION))
|
||||
(BASEY (FETCH (REGION BOTTOM) OF REGION))
|
||||
(RWIDTH (FETCH (REGION WIDTH) OF REGION))
|
||||
(RHEIGHT (FETCH (REGION HEIGHT) OF REGION))
|
||||
(OPPX (IPLUS BASEX RWIDTH))
|
||||
(OPPY (IPLUS BASEY RHEIGHT)))
|
||||
|
||||
(* ;; "Default parameters assume the anchor is (LEFT BOTTOM)")
|
||||
|
||||
(CL:WHEN (EQ 'RIGHT CORNERX)
|
||||
(SWAP BASEX OPPX))
|
||||
(CL:WHEN (EQ 'TOP CORNERY)
|
||||
(SWAP BASEY OPPY))
|
||||
(\CURSORPOSITION OPPX OPPY)
|
||||
(CL:UNLESS MINSIZE (* ; "No minimum size constraint")
|
||||
(SETQ RWIDTH NIL)
|
||||
(SETQ RHEIGHT NIL))
|
||||
(GETREGION RWIDTH RHEIGHT REGION NIL NIL (LIST BASEX BASEY OPPX OPPY])
|
||||
|
||||
(RELCREATEPOSITION
|
||||
[LAMBDA (REFX REFY) (* ; "Edited 23-Jan-2022 17:08 by rmk")
|
||||
(CREATEPOSITION (\RELCREATEREGION.REF REFX 'X)
|
||||
(\RELCREATEREGION.REF REFY 'Y])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\RELCREATEREGION.REF
|
||||
[LAMBDA (REF WHICH) (* ; "Edited 23-Jan-2022 20:20 by rmk")
|
||||
(* ; "Edited 2-Jan-2022 11:01 by rmk")
|
||||
|
||||
(* ;; "REF can be NIL, an absolute screen position, the atom SCREEN, or a list of (anchor fraction adjustment) where anchor can be a region, window, or the atom SCREEN, fraction can be a number or atoms LEFT/RIGHT/BOTTOM/TOP as apropriate.")
|
||||
(* ; "Edited 30-Dec-2021 17:49 by rmk")
|
||||
(LET (ANCHOR VAL SIZE FRACTION SPEC (BASE 0))
|
||||
|
||||
(* ;; "Would be nice if the screen had a region")
|
||||
|
||||
(IF (NULL REF)
|
||||
THEN (CL:IF (EQ WHICH 'X)
|
||||
LASTMOUSEX
|
||||
LASTMOUSEY)
|
||||
ELSEIF (AND (FIXP REF)
|
||||
(NOT (MINUSP REF)))
|
||||
THEN REF
|
||||
ELSEIF (EQ REF 'SCREEN)
|
||||
THEN
|
||||
(* ;; "LEFT and BOTTOM are 0")
|
||||
|
||||
0
|
||||
ELSEIF [AND (LISTP REF)
|
||||
(SETQ ANCHOR (OR (REGIONP (CAR REF))
|
||||
(AND (WINDOWP (CAR REF))
|
||||
(WINDOWPROP (CAR REF)
|
||||
'REGION))
|
||||
(AND (EQ (CAR REF)
|
||||
'SCREEN)
|
||||
'SCREEN]
|
||||
THEN (SETQ SPEC (CDR REF))
|
||||
[IF (EQ WHICH 'X)
|
||||
THEN (IF (EQ ANCHOR 'SCREEN)
|
||||
THEN (SETQ SIZE SCREENWIDTH)
|
||||
ELSE (SETQ BASE (FETCH (REGION LEFT) OF ANCHOR))
|
||||
(SETQ SIZE (FETCH (REGION WIDTH) OF ANCHOR)))
|
||||
(SETQ FRACTION (SELECTQ (CAR SPEC)
|
||||
((NIL LEFT)
|
||||
0)
|
||||
(RIGHT 1)
|
||||
(CAR SPEC)))
|
||||
ELSE (IF (EQ ANCHOR 'SCREEN)
|
||||
THEN (SETQ SIZE SCREENHEIGHT)
|
||||
ELSE (SETQ BASE (FETCH (REGION BOTTOM) OF ANCHOR))
|
||||
(SETQ SIZE (FETCH (REGION HEIGHT) OF ANCHOR)))
|
||||
(SETQ FRACTION (SELECTQ (CAR SPEC)
|
||||
((NIL BOTTOM)
|
||||
0)
|
||||
(TOP 1)
|
||||
(CAR SPEC]
|
||||
[SETQ VAL (IPLUS BASE (ROUND (TIMES FRACTION SIZE]
|
||||
(CL:WHEN (CADR SPEC)
|
||||
(ADD VAL (CADR SPEC)))
|
||||
VAL
|
||||
ELSE (\ILLEGAL.ARG REF])
|
||||
|
||||
(\RELCREATEREGION.SIZE
|
||||
[LAMBDA (PARAM WHICH) (* ; "Edited 2-Jan-2022 11:00 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 17:51 by rmk")
|
||||
|
||||
(* ;;
|
||||
"PARAM can be FIXP or (region anchor adjustment) which determine size relative to the region.")
|
||||
|
||||
(LET (VAL ANCHOR SPEC)
|
||||
(IF (FIXP PARAM)
|
||||
ELSEIF [SETQ ANCHOR (OR (REGIONP PARAM)
|
||||
(AND (WINDOWP PARAM)
|
||||
(WINDOWREGION PARAM]
|
||||
THEN (CL:IF (EQ WHICH 'X)
|
||||
(FETCH WIDTH OF ANCHOR)
|
||||
(FETCH HEIGHT OF ANCHOR))
|
||||
ELSEIF (LISTP PARAM)
|
||||
THEN (IF (SETQ ANCHOR (OR (REGIONP (CAR PARAM))
|
||||
(AND (WINDOWP (CAR PARAM))
|
||||
(WINDOWREGION (CAR PARAM)))
|
||||
(AND (EQ (CAR PARAM)
|
||||
'SCREEN)
|
||||
'SCREEN)
|
||||
(\ILLEGAL.ARG PARAM)))
|
||||
THEN [SETQ VAL (CL:IF (EQ WHICH 'X)
|
||||
(CL:IF (EQ ANCHOR 'SCREEN)
|
||||
SCREENWIDTH
|
||||
(FETCH WIDTH OF ANCHOR))
|
||||
(CL:IF (EQ ANCHOR 'SCREEN)
|
||||
SCREENHEIGHT
|
||||
(FETCH HEIGHT OF ANCHOR)))]
|
||||
(SETQ SPEC (CDR PARAM))
|
||||
(CL:WHEN (CAR SPEC)
|
||||
(SETQ VAL (ROUND (TIMES (CAR SPEC)
|
||||
VAL))))
|
||||
(CL:WHEN (CADR SPEC)
|
||||
(ADD VAL (CADR SPEC)))
|
||||
VAL)
|
||||
ELSEIF (EQ PARAM 'SCREEN)
|
||||
THEN (CL:IF (EQ WHICH 'X)
|
||||
SCREENWIDTH
|
||||
SCREENHEIGHT)
|
||||
ELSE (\ILLEGAL.ARG PARAM])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Composite application construction")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(RM-ATTACHWINDOW
|
||||
[LAMBDA (WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION TAKEFROMCENTRAL)
|
||||
(* ; "Edited 29-Dec-2021 09:36 by rmk")
|
||||
(* ; "Edited 28-Nov-2021 16:10 by rmk:")
|
||||
|
||||
(* ;; "MAINWINDOW may not be the central window, could be attached to an attachment.")
|
||||
|
||||
(* ;; "If the central window is under construction, we shrink it down so that the new attachment fits within the original footprint of the central window and all of its previous attachments.")
|
||||
|
||||
(* ;; "This addresses the common situation where the user provides a region for the central window and the constellation of windows that will surround it, and the whole constellation is supposed to stay within that original bounding box, even as new attachments (promptwindows, menus...) are tacked on.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "A second extension: If WINDOWCOMACTION is a list, smash it into the PASSTOMAINCOMS. ATTACHWINDOW.ORIG only allows a few atomic-value options.")
|
||||
|
||||
(LET (MIN (CENTRALWINDOW (CENTRALWINDOW MAINWINDOW))
|
||||
CENTRALREGION NEWALLREGION ORIGALLREGION NEWCENTRALREGION VAL)
|
||||
(CL:WHEN (OR TAKEFROMCENTRAL (WINDOWPROP CENTRALWINDOW 'UNDERCONSTRUCTION))
|
||||
(SETQ ORIGALLREGION (ATTACHEDWINDOWREGION CENTRALWINDOW))
|
||||
(SETQ CENTRALREGION (WINDOWREGION CENTRALWINDOW)))
|
||||
(SETQ VAL (ATTACHWINDOW.ORIG WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION))
|
||||
(CL:WHEN ORIGALLREGION
|
||||
(SETQ NEWALLREGION (ATTACHEDWINDOWREGION CENTRALWINDOW))
|
||||
(CL:UNLESS (EQUAL ORIGALLREGION NEWALLREGION)
|
||||
|
||||
(* ;; "Something changed, presumably the total region expanded, so something has to shrink to stay within the original region. We want to shrink the main window only, keeping everything else as it was. Hopefully, previously attached windows that wanted a fixed size on the relevant dimension have a MINSIZE that won't let them shrink. And hopefully the central window does allow shrinking, otherwise nothing happens.")
|
||||
|
||||
(* ;; "It also could be that the region hasn't changed, if the new window hides in the shadow of a previously attached one.")
|
||||
|
||||
(SETQ NEWCENTRALREGION (SELECTQ EDGE
|
||||
(LEFT (CREATE REGION USING CENTRALREGION LEFT _
|
||||
(PLUS (FETCH (REGION LEFT)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF LEFT
|
||||
ORIGALLREGION
|
||||
NEWALLREGION))
|
||||
WIDTH _
|
||||
(DIFFERENCE
|
||||
(FETCH (REGION WIDTH)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF WIDTH
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(RIGHT (CREATE REGION USING CENTRALREGION WIDTH _
|
||||
(DIFFERENCE
|
||||
(FETCH (REGION WIDTH)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF WIDTH
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(TOP (CREATE REGION USING CENTRALREGION HEIGHT _
|
||||
(DIFFERENCE (FETCH (REGION
|
||||
HEIGHT)
|
||||
OF CENTRALREGION
|
||||
)
|
||||
(RFIELDDIFF HEIGHT
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(BOTTOM (CREATE REGION
|
||||
USING CENTRALREGION BOTTOM _
|
||||
(PLUS (FETCH (REGION BOTTOM)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF BOTTOM ORIGALLREGION
|
||||
NEWALLREGION))
|
||||
HEIGHT _ (DIFFERENCE (FETCH (REGION
|
||||
HEIGHT)
|
||||
OF CENTRALREGION
|
||||
)
|
||||
(RFIELDDIFF HEIGHT
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(SHOULDNT)))
|
||||
|
||||
(* ;; "We want to reshape only the central window. We detach the new (just attached) window, do the shrinking, then reattach. If other attached windows get reshaped, that's par for the course. Presumably they are specified as fixed on the relevant dimension, or the user doesn't care.")
|
||||
|
||||
(* ;; "Maybe this little wrinkle is solving a non-problem--if the user cares about whether or not the new window will shrink, now or with later reshaping, then he should have specified its own minsize property.")
|
||||
|
||||
(* ;; "On the otherhand, maybe we should remove all of the SHAPEW's (or but in DONT) in the PASSTOMAIN coms of all the windows attached directly or indirectly to the central window, do the reshaping, and then restore.")
|
||||
|
||||
(DETACHWINDOW WINDOWTOATTACH MAINWINDOW)
|
||||
(SHAPEW CENTRALWINDOW NEWCENTRALREGION)
|
||||
|
||||
(* ;; "Now reattach the new window")
|
||||
|
||||
(SETQ VAL (ATTACHWINDOW.ORIG WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE
|
||||
WINDOWCOMACTION))
|
||||
|
||||
(* ;; "This is a little error check for debugging, to catch cases where there might be interactions with other interfering strategies. If the new window turned out to be bigger on the relevant dimension than the original set up, then we simply have to relax.")
|
||||
|
||||
(* ;; "If the new window is bigger than the original region on the other dimenion dimension, then we have to relax our requirement. We use ATTACHEDWINDOWREGION in case the new window is already a conglomerate.")
|
||||
|
||||
(CL:UNLESS (OR (EQUAL ORIGALLREGION (ATTACHEDWINDOWREGION CENTRALWINDOW))
|
||||
(SELECTQ EDGE
|
||||
((TOP BOTTOM)
|
||||
(GEQ (FETCH (REGION WIDTH) OF (ATTACHEDWINDOWREGION
|
||||
WINDOWTOATTACH
|
||||
'REGION))
|
||||
(FETCH (REGION WIDTH) OF ORIGALLREGION)))
|
||||
((LEFT RIGHT)
|
||||
(GEQ (FETCH (REGION HEIGHT) OF (ATTACHEDWINDOWREGION
|
||||
WINDOWTOATTACH
|
||||
'REGION))
|
||||
(FETCH (REGION HEIGHT) OF ORIGALLREGION)))
|
||||
NIL))
|
||||
(HELP ORIGALLREGION (ATTACHEDWINDOWREGION MAINWINDOW)))
|
||||
(CL:WHEN (LISTP WINDOWCOMACTION)
|
||||
|
||||
(* ;; "Maybe this should be done in the ORIG function--an oversight?")
|
||||
|
||||
(WINDOWPROP WINDOWTOATTACH 'PASSTOMAINCOMS WINDOWCOMACTION))))
|
||||
VAL])
|
||||
)
|
||||
|
||||
(MOVD? 'ATTACHWINDOW 'ATTACHWINDOW.ORIG)
|
||||
|
||||
(MOVD 'RM-ATTACHWINDOW 'ATTACHWINDOW)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS RFIELDDIFF MACRO ((FIELD R1 R2)
|
||||
(DIFFERENCE (FETCH (REGION FIELD) OF R1)
|
||||
(FETCH (REGION FIELD) OF R2))))
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1612 3799 (SET-TYPED-REGIONS 1622 . 3797)) (3800 10801 (RM-CREATEW 3810 . 6317) (
|
||||
RM-CLOSEW 6319 . 7720) (RM-GETREGION 7722 . 10308) (CLOSE-TYPED-W 10310 . 10799)) (11717 19196 (
|
||||
RELCREATEREGION 11727 . 16350) (RELGETREGION 16352 . 18959) (RELCREATEPOSITION 18961 . 19194)) (19197
|
||||
24499 (\RELCREATEREGION.REF 19207 . 22239) (\RELCREATEREGION.SIZE 22241 . 24497)) (24552 33894 (
|
||||
RM-ATTACHWINDOW 24562 . 33892)))))
|
||||
STOP
|
||||
BIN
lispusers/REGIONMANAGER.LCOM
Normal file
BIN
lispusers/REGIONMANAGER.LCOM
Normal file
Binary file not shown.
61
lispusers/REGIONMANAGER.TEDIT
Normal file
61
lispusers/REGIONMANAGER.TEDIT
Normal file
@@ -0,0 +1,61 @@
|
||||
Medley REGIONMANAGER2
|
||||
|
||||
4
|
||||
|
||||
1
|
||||
|
||||
REGIONMANAGER
|
||||
1
|
||||
|
||||
4
|
||||
|
||||
By:
|
||||
Ron Kaplan
|
||||
This document created in December 2021.
|
||||
|
||||
Medley comes equipped with a core set of functions for specifying regions and creating the windows that occupy those regions on the screen. But it can be disruptive if not irritating to have to draw out a new ghost region for every invocation of a particular application. Thus the common applications (e.g. TEDIT, SEDIT, DINFO...) implement particular strategies to reduce the number of times that a user has to sweep out a new region. They instead default to regions that were allocated for earlier invocations that are no longer active. TEDIT for example recycles the region of a session that was recently shut down, SEDIT allocates from a list of previous regions, DINFO always uses the same region, but FILEBROWSER always prompts for a new one. Applications that do recycle their regions tend to do so indiscrimately, without regard to the current arrangement of other windows on the screen or the role that those windows may play in higher-level applications.
|
||||
The REGIONMANAGER package provides simple extensions to the core region and window functions. These are aimed at giving users and application implementors more flexible and systematic control over the specification and reuse of screen regions. It introduces three new notions:
|
||||
A "typed region" allows the regions of particular applications to be specified, classified, and recycled according to their types.
|
||||
The size, location, and orientation of a "relative region" is specified with respect to particular screen points and the location of other windows.
|
||||
A "constellation region" encloses the collection of satellite windows (prompts, menus, etc) that surround the central window of an application.
|
||||
REGIONMANAGER is innocuous in that explicit user action is required to change the default behavior of any system components.
|
||||
|
||||
Typed regions
|
||||
REGIONMANAGER adds overlay veneers to the core CREATEW, CLOSEW, and GETREGION functions to make it easier to predict and control how different applications arrange their windows on the screen without always needing to respond to a ghost-region prompt.
|
||||
The REGION/INITREGION arguments may now be region-type atoms in addition to either NIL or particular regions as CREATEW and GETREGION otherwise allow. The type-atom will resolve to a region drawn from a predefined pool of regions associated with that type, if the pool has at least one that is not currently allocated to another window. If the pool has no available regions, then the pool will be enlarged with a region that the user produces from a normal ghost-region prompt, and the type-atom will then resolve to the newly installed region.
|
||||
A typed-region is marked as "inuse" and therefore unavailable when CREATEW assigns it to a window, and the extended CLOSEW marks it as again available when the window is closed.
|
||||
An example of how an application can take advantage of this facility is the TEDIT-PF-SEE package. This provides lightweight alternatives to the PF and SEE commands that print their output to scrollable read-only Tedit windows, specifying PF-TEDIT and SEE-TEDIT as their region types. The user can predefine a preference-ordered sequence of recyclable regions that bring up multiple output windows in a predictable tiled arrangement, without region-prompting for each invocation.
|
||||
The global variable TYPED-REGIONS is an alist that maintains the relationship between atomic type-names and the list of regions that belong to each type. The list is ordered according to preferences set by the user, and a type-atom is always resolved to the first unused region in its list. If the user is asked to sweep out a new region, that region is added at the end, as the least preferable. The function SET-TYPED-REGIONS is provided to add or replace TYPED-REGION entries.
|
||||
(SET-TYPED-REGIONS TYPELISTS REPLACE) [Function]
|
||||
TYPELISTS is an alist of the form
|
||||
((type1 . regions1)(type2 . regions2)...)
|
||||
where each regioni is a possibly empty list of regions. For convenience, if TYPELISTS is just a literal type-atom, it is interpreted as ((type)), and if it is a list (type . regions) begining with an atom, it is interpreted as ((type . regions). The new regions replace preexisting regions if REPLACE, otherwise they are added at the front.
|
||||
Typically, a call to SET-TYPED-REGIONS would be placed in a user's INIT file to set up the preference order for the regions that the user wants to participate in this reallocation scheme. If an application uses a type that is not on TYPED-REGIONS, then that type-atom is treated as NIL and always gives rise to the normal ghost-region prompting. Thus a user will observe no change in system behavior if TYPED-REGIONS is left with its initial value NIL. A type that is added with an empty region list (as opposed to not being on the list at all) will allow new regions to accumulate for recycling.
|
||||
|
||||
Relative regions
|
||||
Two functions are provided to make it easy to create regions relative and oriented with respect to a specified reference point. These may be useful for constructing an application that includes a constellation of windows arranged in a particular relative way.
|
||||
(RELCREATEREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) [Function]
|
||||
RELCREATEREGION creates a region of dimensions WIDTH and HEIGHT. One of its corners is identified by CORNERX and CORNERY and that corner will be aligned with a reference screen-point determined by REFX and REFY. If ONSCREEN, the WIDTH or HEIGHT will be adjusted with respect to that alignment so that the resulting region is entirely within the screen.
|
||||
WIDTH and HEIGHT can be given as absolute (natural) numbers) or specified relative to the WIDTH and HEIGHT of another region or of the screen. The possibilities are interpreted as follows:
|
||||
natural number: the number of screen points
|
||||
list of the form (anchor fraction adjustment), where anchor is a region, window, or the atom SCREEN. The corres-ponding dimension of the anchor is mutiplied by fraction and adjustment is added to the result. For example, specifying (<window> .5 -1) results in a WIDTH that is one point smaller than half the width of window's region. Fraction and adjustment default to 1 and 0 respectively.
|
||||
region/window/SCREEN: equivalent to (region/window/SCREEN 1 0).
|
||||
CORNERX can be LEFT, RIGHT, or NIL=LEFT, CORNERY can be BOTTOM, TOP, or NIL=BOTTOM. If LEFT/TOP are specified, for example, the region will be splayed down and to the right of the reference point. If RIGHT/BOTTOM, then up and to the left.
|
||||
The reference-point arguments REFX and REFY are interpreted as follows:
|
||||
NIL: LASTMOUSEX/LASTMOUSEY
|
||||
natural number: an absolute screen coordinate
|
||||
(anchor fraction adjustment) or just region/window/SCREEN: the quantity determined relative to the size of anchor (as above) is added to the anchors left/bottom produce the REFX/REFY coordinate. In this case, fractions specified as LEFT/BOTTOM/NIL are interpreted as 0 and RIGHT/TOP are interpreted as 1. For example, a specification (<window> .4 -2) for REFY will produce a coordinate 2 points below the level that is 40% of the distance between the bottom and top of the window's region.
|
||||
For convenience, if REFX is a position and REFY is NIL, then the XCOORD and YCOORD of REFX are taken as absolute values for REFX and REFY.
|
||||
Also for convenience, if WIDTH is a potentially a list of RELCREATEREGION arguments, then the elements of that list are spread out in a recursive call.
|
||||
|
||||
(RELGETREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY MINSIZE) [Function]
|
||||
Calls GETREGION with an initial ghost region as created by RELCREATEREGION. CORNERX and CORNERY determine the ghost region's fixed corner, and the cursor starts at the region's diagonally opposite corner. If MINSIZE is true, then WIDTH and HEIGHT are taken as the minimum sizes of the region, except for adjustments that may be needed to ensure that all corners of the ghost region are initially visible on the screen.
|
||||
(RELCREATEPOSITION REFX REFY) [Function]
|
||||
Creates a position with X and Y coordinates specified by REFX and REFY references as above.
|
||||
Constellation regions
|
||||
Applications are often set up as a constellation of windows, a central or primary window surrounded by some number of satellites for menus, headers, prompts, and secondary outputs. The main panel of a file browser, for example, displays the list of files, but above it are carefully arranged windows for the column headers, summary information, and prompts, and off to the side is the menu of file browser commands. FILEBROWSER interprets the screen region that the user sweeps out for a new browser as the region for the whole constellation,the smallest region that will enclose the central window and all of its satellites. Similarly, the screen region given to TEDIT and SEDIT is divided between the prompt window and the central editing window, again so that the whole constellation (a pair in these cases) fit within the provided region.
|
||||
Each of these applications is constructed by anticipating the subregions that the satellite windows will occupy after they are attached, decreasing the constellation region by their estimated (using WIDTHIFWINDOW HEIGHTIFWINDOW) or actual sizes, and then using remainder as the region for the central window.
|
||||
An alternative approach is to construct the central window first, giving it the entire constellation region, and then to have ATTACHWINDOW reshape that window to accomodate the satellite windows as they are attached in sequence. This leads to the same final configuration, but there is no need for separate calculations to pre-adjust the region of the central window.
|
||||
REGIONMANAGER provides an overlay veneer for ATTACHWINDOW that implements this strategy. If the new argument TAKEFROMCENTRAL is true, then the region of the WINDOWTOATTACH will be substracted from the region of the existing central window according to the EDGE parameter of the attachment.
|
||||
(ATTACHWINDOW WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION TAKEFROMCENTRAL) [Function]
|
||||
This behavior is also triggered if the UNDERCONSTRUCTION property of the central window is true. Thus, a constellation can be set up by creating all of the satellites and the central window, marking the central window as under construction, and then doing the sequence of attachments. The property can be reset to NIL when the construction is complete, so the central window does not shrink if other other attachments (e.g. expanded menus) by later user actions. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4 È È 4 È È 4 È È 4 È È . $È . È . È 4 È È . È . Š Š8 . Š Š8 J È È PAGEHEADING RUNNINGHEAD TERMINAL ÿü TERMINAL ÿü
|
||||
@@ -1,143 +1,138 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Oct-2021 19:23:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TEDIT-PF-SEE.;32 7178
|
||||
(FILECREATED "12-Jan-2022 13:16:00"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;110 7695
|
||||
|
||||
changes to%: (FNS CLOSE-TYPED-WINDOW)
|
||||
:CHANGES-TO (FNS PF-TEDIT)
|
||||
|
||||
previous date%: "12-Oct-2021 22:31:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TEDIT-PF-SEE.;31)
|
||||
:PREVIOUS-DATE " 2-Jan-2022 22:03:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-PF-SEECOMS)
|
||||
|
||||
(RPAQQ TEDIT-PF-SEECOMS
|
||||
[(FNS SEE-TEDIT PF-TEDIT)
|
||||
(COMS (FNS GET-TYPED-WINDOW CLOSE-TYPED-WINDOW)
|
||||
(INITVARS (TYPED-WINDOWS)))
|
||||
(COMMANDS ts tpf)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
(RPAQQ TEDIT-PF-SEECOMS [(FNS PF-TEDIT)
|
||||
(COMMANDS ts tf)
|
||||
(FILES (SYSLOAD)
|
||||
REGIONMANAGER)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
|
||||
(NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
(DEFINEQ
|
||||
|
||||
(SEE-TEDIT
|
||||
[LAMBDA (FILE WINDOW FORMAT) (* ; "Edited 11-Oct-2021 08:51 by rmk:")
|
||||
(SETQ FILE (OR (FINDFILE-WITH-EXTENSIONS FILE NIL '(NIL TEDIT TED TXT TEXT TEX))
|
||||
(ERROR "FILE NOT FOUND" FILE)))
|
||||
(TEDIT-SEE FILE (GET-TYPED-WINDOW (OR WINDOW 'SEE-TEDIT)
|
||||
(CONCAT "SEE window for " FILE))
|
||||
FORMAT)
|
||||
FILE])
|
||||
|
||||
(PF-TEDIT
|
||||
[LAMBDA (FN IFILES) (* ; "Edited 12-Oct-2021 15:22 by rmk:")
|
||||
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 12-Jan-2022 13:15 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 23:17 by rmk")
|
||||
|
||||
(* ;; "PF* to a read-only TEDIT window. First argument is the function name, second if given is the input file.")
|
||||
|
||||
(* ;; "This uses PFCOPYBYTES so we see what it looks like on the file. But some functions were not prettyprinted, so they appear as useless garbage.")
|
||||
|
||||
(* ;; "In that case, calling again with REPRINT=T will read and reprint. And, invoking tf again with no arguments at all will also reprint the last function in the same window")
|
||||
|
||||
(SETQ IFILES (MKLIST IFILES))
|
||||
(CL:WHEN (LISTP FN)
|
||||
(SETQ FN (CAR FN)))
|
||||
(IF FN
|
||||
THEN (* ; "FN name specified; use it.")
|
||||
(SETQ LASTWORD FN)
|
||||
ELSE (* ; "Not specified, use LASTWORD")
|
||||
(SETQ FN LASTWORD))
|
||||
(SELECTQ FN
|
||||
((t T NIL)
|
||||
(SETQ REPRINT T)
|
||||
(SETQ FN LASTWORD))
|
||||
(SETQ LASTWORD FN))
|
||||
(CL:UNLESS FN (ERROR "No function to print"))
|
||||
(CL:WHEN (INTERSECTION '(T t)
|
||||
IFILES)
|
||||
(SETQ REPRINT T)
|
||||
[SETQ IFILES (LDIFFERENCE IFILES '(t T])
|
||||
(IF [OR IFILES (SETQ IFILES (APPEND (WHEREIS FN 'FNS T)
|
||||
(WHEREIS FN 'FUNCTIONS T]
|
||||
THEN (* ; "skip compiled files")
|
||||
(FOR IFILE LOC TSTREAM ENV INSIDE IFILES
|
||||
UNLESS (MEMB (FILENAMEFIELD IFILE 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*)
|
||||
DO (SETQ LOC (FINDFNDEF FN IFILE))
|
||||
(IF (LISTP LOC)
|
||||
THEN [CL:WITH-OPEN-FILE (ISTREAM (POP LOC)
|
||||
:DIRECTION :INPUT)
|
||||
(SETQ ENV (LISPSOURCEFILEP ISTREAM))
|
||||
(SETFILEINFO ISTREAM 'FORMAT ENV)
|
||||
(SETQ TSTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(PRINT-READER-ENVIRONMENT ENV TSTREAM)
|
||||
(PFCOPYBYTES ISTREAM TSTREAM (POP LOC)
|
||||
(POP LOC))
|
||||
(TERPRI TSTREAM)
|
||||
(SETQ TSTREAM (TEDIT TSTREAM (GET-TYPED-WINDOW
|
||||
'PF-TEDIT
|
||||
(CONCAT FN " from "
|
||||
(FULLNAME ISTREAM)))
|
||||
NIL
|
||||
'(READONLY T]
|
||||
ELSEIF (EQ LOC 'FILE.NOT.FOUND)
|
||||
THEN (printout T "file " IFILE " not found." T)
|
||||
ELSE (printout T FN " not found on " LOC "." T)))
|
||||
(WHEREIS FN 'FUNCTIONS T]
|
||||
THEN (* ; "skip compiled files")
|
||||
|
||||
(* ;; "Since we are creating readonly Tedits, try to keep the TTY where it is.")
|
||||
|
||||
(FOR IFILE LOC TSTREAM ENV EXPR TFPROP WINDOW INSIDE IFILES
|
||||
UNLESS (MEMB (FILENAMEFIELD IFILE 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*)
|
||||
DO (SETQ LOC (FINDFNDEF FN IFILE))
|
||||
(IF (LISTP LOC)
|
||||
THEN (SETQ TFPROP (LIST FN (CAR LOC)))
|
||||
[SETQ WINDOW (FIND W IN (OPENWINDOWS)
|
||||
SUCHTHAT (AND (EQUAL TFPROP (WINDOWPROP W 'TF))
|
||||
(WINDOWPROP W 'TEXTOBJ]
|
||||
[IF (AND WINDOW (NOT REPRINT))
|
||||
THEN
|
||||
(* ;;
|
||||
"If already an open PF window on this function in this file, just raise it to the top")
|
||||
|
||||
(TOTOPW WINDOW)
|
||||
(RETURN)
|
||||
ELSE (CL:WITH-OPEN-FILE (ISTREAM (POP LOC)
|
||||
:DIRECTION :INPUT)
|
||||
(SETQ ENV (LISPSOURCEFILEP ISTREAM))
|
||||
(SETFILEINFO ISTREAM 'FORMAT ENV)
|
||||
(SETQ TSTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(PRINT-READER-ENVIRONMENT ENV TSTREAM)
|
||||
(IF REPRINT
|
||||
THEN (SETFILEPTR ISTREAM (POP LOC))
|
||||
(SETQ EXPR (WITH-READER-ENVIRONMENT ENV (READ ISTREAM))
|
||||
)
|
||||
(WITH-READER-ENVIRONMENT ENV
|
||||
(IF (EQ FN (CAR EXPR))
|
||||
THEN (DSPFONT BOLDFONT TSTREAM)
|
||||
(PRINT FN TSTREAM)
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(SETQ EXPR (CADR EXPR))
|
||||
(PRINTDEF EXPR 3 T NIL NIL TSTREAM)
|
||||
ELSEIF (EQ FN (CADR EXPR))
|
||||
THEN
|
||||
(* ;;
|
||||
"Presumably a DEFUN. Print the CAR, boldface the cadr")
|
||||
|
||||
(PRINTOUT TSTREAM "(" .P2 (CAR EXPR)
|
||||
" " .FONT BOLDFONT .P2 (CADR EXPR)
|
||||
.FONT DEFAULTFONT " " .P2
|
||||
(CADDR EXPR)
|
||||
T 3)
|
||||
(PRINTDEF (CDDDR EXPR)
|
||||
3 T T NIL TSTREAM)
|
||||
(PRIN3 ")" TSTREAM)
|
||||
ELSE (PRINTDEF EXPR 3 NIL NIL NIL TSTREAM)))
|
||||
ELSE (PFCOPYBYTES ISTREAM TSTREAM (POP LOC)
|
||||
(POP LOC)))
|
||||
(TERPRI TSTREAM)
|
||||
[TEDIT TSTREAM (OR WINDOW 'PF-TEDIT)
|
||||
NIL
|
||||
`(READONLY T LEAVETTY T TITLE ,(CONCAT FN " from "
|
||||
(FULLNAME ISTREAM]
|
||||
|
||||
(* ;; "The windowprop allows for reprinting as a window action, or reprinting from a command that can find and reuse the previous (presumably unprettied) window.")
|
||||
|
||||
(WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TF TFPROP)
|
||||
|
||||
(* ;; "Remove this when TEDIT honors the TITLE property")
|
||||
|
||||
(WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TITLE
|
||||
(CONCAT FN " from " (FULLNAME ISTREAM]
|
||||
ELSEIF (EQ LOC 'FILE.NOT.FOUND)
|
||||
THEN (printout T "file " IFILE " not found." T)
|
||||
ELSE (printout T FN " not found on " LOC "." T)))
|
||||
(SETQ *LAST-DF* FN)
|
||||
ELSE (PRINTOUT T FN " has no function definition" T])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(GET-TYPED-WINDOW
|
||||
[LAMBDA (WINDOWTYPE TITLE NOOPENFLG) (* ; "Edited 11-Oct-2021 10:06 by rmk:")
|
||||
(DEFCOMMAND ts (FILE WINDOW FORMAT)
|
||||
(TEDIT-SEE (OR (FINDFILE-WITH-EXTENSIONS FILE NIL '(NIL TEDIT TED TXT TEXT TEX))
|
||||
(ERROR "FILE NOT FOUND" FILE))
|
||||
(OR WINDOW 'SEE-TEDIT)
|
||||
FORMAT))
|
||||
|
||||
(* ;; "WINDOWTYPE=T means always create a new window. If a WINDOW, then reuse it.")
|
||||
(DEFCOMMAND tf (FN . IFILES) (PF-TEDIT FN IFILES))
|
||||
|
||||
(* ;; "Otherwise, create a window of type WINDOWTYPE, using a previously specified region if one is available.")
|
||||
|
||||
(LET (WINDOW REGION WLIST)
|
||||
[IF (OR (EQ WINDOWTYPE T)
|
||||
(SETQ WINDOW (WINDOWP WINDOWTYPE)))
|
||||
THEN (SETQ WINDOWTYPE NIL)
|
||||
ELSE [SETQ WLIST (OR (ASSOC WINDOWTYPE TYPED-WINDOWS)
|
||||
(CAR (PUSH TYPED-WINDOWS (CONS WINDOWTYPE]
|
||||
(SETQ REGION (FIND X IN (CDR WLIST) SUCHTHAT (TYPE? REGION X]
|
||||
(CL:UNLESS WINDOW
|
||||
|
||||
(* ;; "Make sure we have a titlebar and promptwindow")
|
||||
|
||||
(SETQ WINDOW (CREATEW REGION "" NIL NOOPENFLG))
|
||||
(GETPROMPTWINDOW WINDOW)
|
||||
|
||||
(* ;;
|
||||
"Replace the region on WLIST with the window, so we can maintan a likely preference order.")
|
||||
|
||||
(IF REGION
|
||||
THEN (DSUBST WINDOW REGION WLIST)
|
||||
ELSE (NCONC1 WLIST WINDOW)))
|
||||
(CL:WHEN TITLE
|
||||
(WINDOWPROP WINDOW 'TITLE TITLE))
|
||||
(CL:WHEN WINDOWTYPE
|
||||
(WINDOWPROP WINDOW 'WINDOWTYPE WINDOWTYPE)
|
||||
(WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION CLOSE-TYPED-WINDOW)))
|
||||
WINDOW])
|
||||
|
||||
(CLOSE-TYPED-WINDOW
|
||||
[LAMBDA (WINDOW ALL) (* ; "Edited 16-Oct-2021 19:23 by rmk:")
|
||||
|
||||
(* ;; "Puts the region of WINDOW back on the region list for its type, for later reuse. If ALL, closes all windows of the type of WINDOW (and recursively puts their regions also on the list).")
|
||||
|
||||
(CL:WHEN (OPENWP WINDOW)
|
||||
[LET [(WINDOWTYPE (WINDOWPROP WINDOW 'WINDOWTYPE]
|
||||
(CL:WHEN WINDOWTYPE
|
||||
(IF ALL
|
||||
THEN (FOR W IN (OPENWINDOWS) WHEN (EQ WINDOWTYPE
|
||||
(WINDOWPROP W 'WINDOWTYPE)
|
||||
)
|
||||
UNLESS (EQ W WINDOW) DO (CLOSEW W))
|
||||
ELSE
|
||||
|
||||
(* ;; "This may no longer be needed, now that TEDIT removes the process for READONLY windows just as for ordinary edit windows.")
|
||||
|
||||
(AND NIL (CL:WHEN (TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS))
|
||||
(* ;
|
||||
"Otherwise, the window pops up if you don't click away")
|
||||
(TTY.PROCESS T)))
|
||||
(DSUBST (WINDOWPROP WINDOW 'REGION)
|
||||
WINDOW TYPED-WINDOWS)))])
|
||||
WINDOW])
|
||||
)
|
||||
|
||||
(RPAQ? TYPED-WINDOWS )
|
||||
|
||||
(DEFCOMMAND ts (FILE WINDOW FORMAT) (SEE-TEDIT FILE WINDOW FORMAT))
|
||||
|
||||
(DEFCOMMAND tpf (FN IFILES) (PF-TEDIT FN IFILES))
|
||||
(FILESLOAD (SYSLOAD)
|
||||
REGIONMANAGER)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
@@ -147,6 +142,5 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (843 3913 (SEE-TEDIT 853 . 1263) (PF-TEDIT 1265 . 3911)) (3914 6866 (GET-TYPED-WINDOW
|
||||
3924 . 5397) (CLOSE-TYPED-WINDOW 5399 . 6864)))))
|
||||
(FILEMAP (NIL (947 7216 (PF-TEDIT 957 . 7214)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
BIN
lispusers/TEDIT-PF-SEE.TEDIT
Normal file
BIN
lispusers/TEDIT-PF-SEE.TEDIT
Normal file
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "22-Dec-2021 10:37:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;20 39405
|
||||
(FILECREATED "27-Jan-2022 13:20:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;109 49971
|
||||
|
||||
:CHANGES-TO (FNS IMCOMPARE.COLLECT.HASH.CHUNKS COMPARETEXT)
|
||||
(RECORDS IMCOMPARE.CHUNK)
|
||||
:CHANGES-TO (FNS COMPARETEXT.TEXTOBJ)
|
||||
|
||||
:PREVIOUS-DATE "19-Dec-2021 12:45:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;19)
|
||||
:PREVIOUS-DATE "23-Jan-2022 20:22:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;108)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -17,133 +16,307 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(PRETTYCOMPRINT COMPARETEXTCOMS)
|
||||
|
||||
(RPAQQ COMPARETEXTCOMS
|
||||
((FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH
|
||||
IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE)
|
||||
(P (MOVD 'COMPARETEXT 'IMCOMPARE))
|
||||
(INITVARS (IMCOMPARE.LAST.NODE NIL)
|
||||
(IMCOMPARE.LAST.GRAPH.WINDOW NIL))
|
||||
(RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB)
|
||||
((FNS COMPARETEXT COMPARETEXT.WINDOW COMPARETEXT.TEXTOBJ COMPARETEXT.SETSEL CHUNKNODELABEL
|
||||
IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS IMCOMPARE.DISPLAYGRAPH
|
||||
IMCOMPARE.HASH IMCOMPARE.MERGE.CONNECTED.CHUNKS IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
|
||||
IMCOMPARE.SHOW.DIST IMCOMPARE.UPDATE.SYMBOL.TABLE)
|
||||
(FNS IMCOMPARE.LEFTBUTTONFN IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.COPYBUTTONFN)
|
||||
(FILES (SYSLOAD)
|
||||
GRAPHER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
GRAPHER))))
|
||||
GRAPHER REGIONMANAGER)
|
||||
(FNS TAIL1 TAIL2)
|
||||
(* ; "Debugging")
|
||||
(INITVARS (COMPARETEXT.ALLCHUNKS T)
|
||||
(COMPARETEXT.AUTOTEDIT T))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB)
|
||||
(FILES (LOADCOMP)
|
||||
GRAPHER))))
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARETEXT
|
||||
[LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION FILELABELS)
|
||||
(* ; "Edited 22-Dec-2021 10:35 by rmk")
|
||||
(* ; "Edited 15-Dec-2021 16:23 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 12:21 by rmk")
|
||||
(* ; "Edited 8-Nov-2021 08:44 by rmk:")
|
||||
(* mjs " 8-Jan-84 21:06")
|
||||
[LAMBDA (FILE1 FILE2 HASH.TYPE REGION FILELABELS TITLE) (* ; "Edited 12-Jan-2022 16:32 by rmk")
|
||||
(* ; "Edited 8-Nov-2021 08:44 by rmk")
|
||||
(* ; "Edited 8-Jan-84 21:06 by mjs")
|
||||
|
||||
(* ;; "Compares the two files, and produces a graph showing their corresponding chunks. The courseness of the 'chunking' is determined by HASH.TYPE, which may be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. The file difference graph is displayed at GRAPHREGION. If GRAPH.REGION = NIL, the user is asked to specify a region. If GRAPH.REGION = T, a standard region is used.")
|
||||
(* ;; "Compares the two files, and produces a graph showing their corresponding chunks. The courseness of the 'chunking' is determined by HASH.TYPE, which may be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. The file difference graph is displayed at REGION. If REGION = NIL, the user is asked to specify a region. If REGION = T, a standard region is used.")
|
||||
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA LINE WORD))
|
||||
(NIL (SETQ HASH.TYPE 'PARA))
|
||||
(ERROR (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)))
|
||||
(LET ((NEWFILE (FINDFILE NEWFILENAME T))
|
||||
(OLDFILE (FINDFILE OLDFILENAME T)))
|
||||
(CL:UNLESS (AND OLDFILE NEWFILE)
|
||||
(ERROR "Can't find both files" (LIST NEWFILENAME OLDFILENAME)))
|
||||
(LET [(FULLFILE1 (OR (GETSTREAM FILE1 'INPUT T)
|
||||
(FINDFILE FILE1 T)))
|
||||
(FULLFILE2 (OR (GETSTREAM FILE2 'INPUT T)
|
||||
(FINDFILE FILE2 T]
|
||||
(CL:UNLESS (AND FULLFILE1 FULLFILE2)
|
||||
(ERROR "Can't find both files" (LIST FILE1 FILE2)))
|
||||
(IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK
|
||||
FILENAME _ NEWFILE
|
||||
FILENAME _ FULLFILE1
|
||||
FILEPTR _ 0)
|
||||
(create IMCOMPARE.CHUNK
|
||||
FILENAME _ OLDFILE
|
||||
FILENAME _ FULLFILE2
|
||||
FILEPTR _ 0)
|
||||
HASH.TYPE
|
||||
(if (EQ GRAPH.REGION T)
|
||||
then (create REGION
|
||||
LEFT _ 25
|
||||
BOTTOM _ 25
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif GRAPH.REGION
|
||||
else (CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please specify a window for the file difference graph"
|
||||
T)
|
||||
(GETREGION))
|
||||
FILELABELS])
|
||||
HASH.TYPE REGION FILELABELS TITLE])
|
||||
|
||||
(COMPARETEXT.WINDOW
|
||||
[LAMBDA (GRAPH REGION TITLE) (* ; "Edited 23-Jan-2022 18:18 by rmk")
|
||||
(* ; "Edited 12-Jan-2022 10:06 by rmk")
|
||||
(* ; "Edited 22-Dec-2021 15:51 by rmk")
|
||||
|
||||
(* ;; "Set up the graph WINDOW. If REGION isn't provided we prompt with a region that is wide enough for the graph and high enough for at least an initial segment.")
|
||||
|
||||
(LET [WINDOW GRAPHREGION WIDTH HEIGHT (FILEPREFIX (CAR (GRAPHERPROP GRAPH 'FILELABELS]
|
||||
(SETQ GRAPHREGION (GRAPHREGION GRAPH))
|
||||
(SETQ WIDTH (IPLUS (TIMES 2 WBorder)
|
||||
(FETCH (REGION WIDTH) OF GRAPHREGION)))
|
||||
[SETQ HEIGHT (IMIN 200 (IPLUS (FETCH (REGION HEIGHT) OF GRAPHREGION)
|
||||
(ITIMES 2 (FONTHEIGHT DEFAULTFONT]
|
||||
(SETQ REGION
|
||||
(if (EQ REGION T)
|
||||
then (create REGION
|
||||
LEFT _ 25
|
||||
BOTTOM _ 25
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif (REGIONP REGION)
|
||||
elseif (POSITIONP REGION)
|
||||
THEN
|
||||
(* ;;
|
||||
"This is a reference position providing the horizontal midpoint of the graph region and the top")
|
||||
|
||||
(RELCREATEREGION WIDTH HEIGHT 'LEFT 'TOP (IDIFFERENCE (FETCH (POSITION XCOORD)
|
||||
OF REGION)
|
||||
(IQUOTIENT WIDTH 2))
|
||||
(FETCH (POSITION YCOORD) OF REGION))
|
||||
ELSE (CLEARW (GETPROMPTWINDOW WINDOW))
|
||||
(printout (GETPROMPTWINDOW WINDOW)
|
||||
"Please specify a region for the comparison graph" T)
|
||||
|
||||
(* ;; "I don't know why the graphregion doesn't include the last line")
|
||||
|
||||
(RELCREATEREGION WIDTH HEIGHT 'RIGHT 'TOP REGION)))
|
||||
[SETQ WINDOW (CREATEW REGION (OR TITLE (CONCAT "Compare text" (CL:IF FILEPREFIX
|
||||
(CONCAT " of " FILEPREFIX)
|
||||
"")
|
||||
" showing "
|
||||
(CL:IF (GRAPHERPROP GRAPH 'ALLCHUNKS)
|
||||
"all"
|
||||
"only different")
|
||||
" chunks, hashed by "
|
||||
(SELECTQ (GRAPHERPROP GRAPH 'HASH.TYPE)
|
||||
(PARA "paragraph")
|
||||
(LINE "line")
|
||||
(WORD "word")
|
||||
(SHOULDNT]
|
||||
(GETPROMPTWINDOW WINDOW)
|
||||
(CL:WHEN (EQ WIDTH (FETCH (REGION WIDTH) OF (WINDOWREGION WINDOW)))
|
||||
(WINDOWPROP WINDOW 'MAXSIZE (CONS WIDTH MAX.SMALLP)))
|
||||
(GETPROMPTWINDOW WINDOW)
|
||||
[WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W)
|
||||
(LET (TOBJ TWINDOW)
|
||||
(CL:WHEN (AND (SETQ TOBJ (WINDOWPROP
|
||||
W
|
||||
'COL1TEXTOBJ))
|
||||
(SETQ TWINDOW
|
||||
(WFROMDS (TEXTSTREAM TOBJ)))
|
||||
(OPENWP TWINDOW))
|
||||
(CLOSEW TWINDOW))
|
||||
(CL:WHEN (AND (SETQ TOBJ (WINDOWPROP
|
||||
W
|
||||
'COL2TEXTOBJ))
|
||||
(SETQ TWINDOW
|
||||
(WFROMDS (TEXTSTREAM TOBJ)))
|
||||
(OPENWP TWINDOW))
|
||||
(CLOSEW TWINDOW]
|
||||
WINDOW])
|
||||
|
||||
(COMPARETEXT.TEXTOBJ
|
||||
[LAMBDA (NODE WINDOW INCOL1) (* ; "Edited 27-Jan-2022 13:14 by rmk")
|
||||
(* ; "Edited 23-Jan-2022 16:51 by rmk")
|
||||
(* ; "Edited 20-Jan-2022 22:29 by rmk")
|
||||
(* ; "Edited 19-Jan-2022 08:52 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 21:21 by rmk")
|
||||
(* ; "Edited 27-Dec-2021 15:56 by rmk")
|
||||
|
||||
(* ;; "Returns the text object for the chunk column in the graphwindow WINDOW, on the left if INCOL1. If the windows are automatic, they are lined up under the middle of WINDOW.")
|
||||
|
||||
(DECLARE (USEDFREE COMPARETEXT.AUTOTEDIT))
|
||||
(LET (TEXTOBJ TSTREAM TWINDOW REGION REGIONARGS (NODEID (FETCH (GRAPHNODE NODEID) OF NODE)))
|
||||
(CL:UNLESS [AND [SETQ TEXTOBJ (WINDOWPROP WINDOW (CL:IF INCOL1
|
||||
'COL1TEXTOBJ
|
||||
'COL2TEXTOBJ)]
|
||||
(OPENWP (WFROMDS (TEXTSTREAM TEXTOBJ]
|
||||
(SETQ REGIONARGS (LIST 700 600 (CL:IF INCOL1
|
||||
'RIGHT
|
||||
'LEFT)
|
||||
'TOP
|
||||
`(,WINDOW 0.5 ,(CL:IF INCOL1
|
||||
-1
|
||||
1))
|
||||
`(,WINDOW BOTTOM -2)
|
||||
T))
|
||||
(SETQ REGION (CL:IF COMPARETEXT.AUTOTEDIT
|
||||
(RELCREATEREGION REGIONARGS)
|
||||
(RELGETREGION REGIONARGS)))
|
||||
[SETQ TSTREAM (TEXTSTREAM (TEDIT (CL:IF (FIXP (CAR NODEID))
|
||||
(FETCH (IMCOMPARE.CHUNK FILENAME) of NODEID)
|
||||
NODEID)
|
||||
REGION NIL `(READONLY T LEAVETTY T]
|
||||
(SETQ TWINDOW (WFROMDS TSTREAM))
|
||||
(SETQ TEXTOBJ (TEXTOBJ TSTREAM))
|
||||
(WINDOWPROP WINDOW (CL:IF INCOL1
|
||||
'COL1TEXTOBJ
|
||||
'COL2TEXTOBJ)
|
||||
TEXTOBJ)
|
||||
[WINDOWPROP TWINDOW 'TITLE (CL:IF INCOL1
|
||||
(CADR (GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
|
||||
'FILELABELS))
|
||||
(CADDR (GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
|
||||
'FILELABELS)))]
|
||||
[WINDOWADDPROP WINDOW 'MOVEFN (FUNCTION (LAMBDA (W NEWPOS)
|
||||
(LET ((DELTA (PTDIFFERENCE NEWPOS (
|
||||
WINDOWPOSITION
|
||||
W)))
|
||||
TOBJ TW)
|
||||
(CL:WHEN [AND (SETQ TOBJ
|
||||
(WINDOWPROP W
|
||||
'COL1TEXTOBJ))
|
||||
(SETQ TW
|
||||
(WFROMDS (TEXTSTREAM
|
||||
TOBJ]
|
||||
(MOVEW TW (PTPLUS DELTA (
|
||||
WINDOWPOSITION
|
||||
TW))))
|
||||
(CL:WHEN [AND (SETQ TOBJ
|
||||
(WINDOWPROP W
|
||||
'COL2TEXTOBJ))
|
||||
(SETQ TW
|
||||
(WFROMDS (TEXTSTREAM
|
||||
TOBJ]
|
||||
(MOVEW TW (PTPLUS DELTA (
|
||||
WINDOWPOSITION
|
||||
TW))))
|
||||
NIL])
|
||||
TEXTOBJ])
|
||||
|
||||
(COMPARETEXT.SETSEL
|
||||
[LAMBDA (TEXTOBJ NODE) (* ; "Edited 25-Dec-2021 10:52 by rmk")
|
||||
|
||||
(* ;; "25 so that we normalize with a little bit of context")
|
||||
|
||||
(LET* ((CHUNK (FETCH (GRAPHNODE NODEID) OF NODE))
|
||||
(FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)))
|
||||
(TEDIT.SETSEL TEXTOBJ (IMAX 1 (IDIFFERENCE FILEPTR 25))
|
||||
0
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEXTOBJ)
|
||||
(TEDIT.SETSEL TEXTOBJ FILEPTR (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEXTOBJ)
|
||||
(AND NIL (TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))
|
||||
'PROCESS])
|
||||
|
||||
(CHUNKNODELABEL
|
||||
[LAMBDA (CHUNK MIN.LENGTH EXTENDER) (* ; "Edited 25-Dec-2021 11:56 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 21:18 by rmk")
|
||||
(* mjs "30-Dec-83 15:11")
|
||||
|
||||
(* ;; "Label for CHUNK is at least MIN.LENGTH characters long, by concatenating the first character of EXTENDER (or space, if not given) to the front")
|
||||
|
||||
(LET ((FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(LENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK))
|
||||
X)
|
||||
(SETQ X (CONCAT FILEPTR ":" LENGTH))
|
||||
(AND NIL (IF (ILESSP (NCHARS X)
|
||||
MIN.LENGTH)
|
||||
THEN (CONCAT (ALLOCSTRING (IDIFFERENCE MIN.LENGTH (NCHARS X))
|
||||
(CL:IF EXTENDER
|
||||
(NTHCHAR EXTENDER 1)
|
||||
" "))
|
||||
X)
|
||||
ELSE X))
|
||||
X])
|
||||
|
||||
(IMCOMPARE.BOXNODE
|
||||
[LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40")
|
||||
(if IMCOMPARE.LAST.NODE
|
||||
then (RESET/NODE/BORDER IMCOMPARE.LAST.NODE 'INVERT IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL)
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW NIL))
|
||||
(if NODE
|
||||
then (RESET/NODE/BORDER NODE 'INVERT WINDOW)
|
||||
(SETQ IMCOMPARE.LAST.NODE NODE)
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW])
|
||||
[LAMBDA (WINDOW NODE1 NODE2) (* ; "Edited 25-Dec-2021 12:01 by rmk")
|
||||
(* rmk%: "14-Dec-84 13:40")
|
||||
|
||||
(* ;; "Marks NODE1 and NODE2 as having been selected, removing marks on previous nodes.")
|
||||
|
||||
(LET [(LASTNODES (WINDOWPROP WINDOW 'LASTNODES] (* ; "FLIPNODE ?")
|
||||
(CL:WHEN (CAR LASTNODES)
|
||||
(FLIPNODE (CAR LASTNODES)
|
||||
WINDOW))
|
||||
(CL:WHEN (CADR LASTNODES)
|
||||
(FLIPNODE (CADR LASTNODES)
|
||||
WINDOW))
|
||||
(CL:WHEN NODE1 (FLIPNODE NODE1 WINDOW))
|
||||
(CL:WHEN NODE2 (FLIPNODE NODE2 WINDOW))
|
||||
(WINDOWPROP WINDOW 'LASTNODES (LIST NODE1 NODE2])
|
||||
|
||||
(IMCOMPARE.CHUNKS
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION FILELABELS)
|
||||
(* ; "Edited 18-Dec-2021 13:21 by rmk")
|
||||
(* ; "Edited 15-Dec-2021 16:28 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 12:32 by rmk")
|
||||
(* rmk%: " 8-Sep-84 00:06")
|
||||
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION FILELABELS TITLE) (* ; "Edited 12-Jan-2022 10:06 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 00:02 by rmk")
|
||||
(* ; "Edited 8-Sep-1984 00:06 by rmk")
|
||||
|
||||
(* ;; "This is the main text-comparison function. It compares the text in the two chunks <which may be small pieces of files, or entire files> and produces a graph showing how the sub-chunks of the two main chunks are related. The two main chunks may be in the same file, and the file may actually be an open Tedit textstream. The main chunks are broken down according to HASH.TYPE, which may be PARA <chunk by paragraph>, LINE, WORD, or PARA. The file difference graph is displayed at GRAPH.REGION.")
|
||||
(* ;; "This is the main text-comparison function. It compares the text in the two chunks <which may be small pieces of files, or entire files> and produces a graph showing how the sub-chunks of the two main chunks are related. The two main chunks may be in the same file, and the file may actually be an open Tedit textstream. The main chunks are broken down according to HASH.TYPE, which may be PARA <chunk by paragraph>, LINE, WORD, or PARA. The file difference graph is displayed at REGION.")
|
||||
|
||||
(* ;; "This text comparison algorithm is originally from the article 'A Technique for Isolating Differences Between Files' by Paul Heckel, in CACM, V21, #4, April 1978 --- major difference is that I use lists instead of arrays")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Collect lists of chunks from each of the main chunks, dividing them according to HASH.TYPE. We start with whole-file chunks to provide the interface that the")
|
||||
(* ;; "Collect lists of chunks from each of the main chunks, dividing them according to HASH.TYPE. We start with whole-file chunk. but this works also for a chunk that corresponds to a subsection of a file.")
|
||||
|
||||
(LET ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
|
||||
(NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE))
|
||||
(OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE)))
|
||||
(CHUNKLIST1 (IMCOMPARE.COLLECT.HASH.CHUNKS CHUNK1 HASH.TYPE))
|
||||
(CHUNKLIST2 (IMCOMPARE.COLLECT.HASH.CHUNKS CHUNK2 HASH.TYPE)))
|
||||
|
||||
(* ;; "Update the chunk symbol table. For each hash value, this table records the number of 'new' chunks with that hash value, the number of 'old' chunks with that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD c hunk itself>.")
|
||||
(* ;; "Update the chunk symbol table. For each hash value, this table records the number of file1 chunks with that hash value, the number of file2 chunks with that value, and a pointer to a tail of CHUNKLIST2 (not to a chunk itself).")
|
||||
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE CHUNKLIST1 CHUNK.SYMBOL.TABLE NIL)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE CHUNKLIST2 CHUNK.SYMBOL.TABLE T)
|
||||
|
||||
(* ;; "For every new chunk whose hash value matches EXACTLY ONE old chunk's value, 'connect' it to the old chunk by setting the new chunk's OTHERCHUNK field to point to the appropriate place in the old chunk list <not the old chunk directly>. Also, make sure that OTHERCHUNK of the matching old chunk is non-NIL, so that unconnected old chunks will be merged correctly.")
|
||||
(* ;; "For every file1 chunk whose hash value matches EXACTLY ONE file2 chunk's value, 'connect' it to the file2 chunk by setting the file1 chunk's OTHERCHUNK field to point to the appropriate tail of the file1 chunk list <not the chunk directly>. Also, make sure that OTHERCHUNK of the matching file1 chunk is non-NIL, so that unconnected file1 chunks will be merged correctly.")
|
||||
|
||||
(for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB
|
||||
do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK)
|
||||
CHUNK.SYMBOL.TABLE))
|
||||
(if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB))
|
||||
(EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK with (fetch (
|
||||
IMCOMPARE.SYMB
|
||||
OLDPTR)
|
||||
of SYMB))
|
||||
(replace (IMCOMPARE.CHUNK OTHERCHUNK) of (CAR (fetch (IMCOMPARE.SYMB OLDPTR)
|
||||
of SYMB)) with T)))
|
||||
(for C1 in CHUNKLIST1 bind SYMB do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE)
|
||||
of C1)
|
||||
CHUNK.SYMBOL.TABLE))
|
||||
(if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT)
|
||||
of SYMB))
|
||||
(EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT)
|
||||
of SYMB)))
|
||||
then (replace (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of C1 with (fetch (IMCOMPARE.SYMB OLDPTR)
|
||||
of SYMB))
|
||||
(replace (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of (CAR (fetch (IMCOMPARE.SYMB OLDPTR)
|
||||
of SYMB)) with T)))
|
||||
|
||||
(* ;; "Merge connected chunks forward")
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL)
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS CHUNKLIST1 NIL)
|
||||
|
||||
(* ;; "Merge connected chunks backwards")
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T)
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(SETQ CHUNKLIST1 (DREVERSE CHUNKLIST1))
|
||||
(SETQ CHUNKLIST2 (DREVERSE CHUNKLIST2))
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS CHUNKLIST1 T)
|
||||
(SETQ CHUNKLIST1 (DREVERSE CHUNKLIST1))
|
||||
(SETQ CHUNKLIST2 (DREVERSE CHUNKLIST2))
|
||||
|
||||
(* ;; "Merge unconnected chunks")
|
||||
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS CHUNKLIST1)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS CHUNKLIST2)
|
||||
|
||||
(* ;; "The file comparison is complete. Format and display the file difference graph")
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE
|
||||
GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST FILELABELS])
|
||||
(IMCOMPARE.DISPLAYGRAPH CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS
|
||||
TITLE])
|
||||
|
||||
(IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 22-Dec-2021 10:37 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 16:32 by rmk")
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 20-Jan-2022 23:09 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 22:30 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 16:32 by rmk")
|
||||
(* ; "Edited 23-Dec-98 16:54 by rmk:")
|
||||
(* mjs " 8-Jan-84 20:57")
|
||||
|
||||
@@ -151,159 +324,157 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
|
||||
(* ;; "It is overkill to open raw text streams as TEDIT stream. So we open, test for TEDIT and if so, close and reoopen. TEDIT may not yet honor external formats other than XCCS for rawtext files.")
|
||||
|
||||
(BIND (FILENAME _ (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK))
|
||||
STREAM ENDPOS FIRST (SETQ STREAM (OPENSTREAM FILENAME 'INPUT 'OLD))
|
||||
(CL:WHEN (\TEDIT.FORMATTEDP1 STREAM)
|
||||
(CLOSEF STREAM) (* ;
|
||||
(RESETLST
|
||||
(BIND (FILENAME _ (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK))
|
||||
STREAM ENDPOS FIRST [RESETSAVE (SETQ STREAM (OPENSTREAM FILENAME 'INPUT 'OLD))
|
||||
'(PROGN (CLOSEF? OLDVALUE]
|
||||
(CL:WHEN (\TEDIT.FORMATTEDP1 STREAM)
|
||||
(* ;
|
||||
"The OBJECTCHAR is produced in place of image objects")
|
||||
[SETQ STREAM (OPENTEXTSTREAM FILENAME NIL NIL NIL
|
||||
`(OBJECTBYTE ,(CHARCODE NULL])
|
||||
(SETFILEINFO STREAM 'EOL 'ANY)
|
||||
(CL:UNLESS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)
|
||||
[RESETSAVE [SETQ STREAM
|
||||
(OPENTEXTSTREAM STREAM NIL NIL NIL
|
||||
`(OBJECTBYTE ,(CHARCODE NULL]
|
||||
'(PROGN (CLOSEF? OLDVALUE])
|
||||
(SETFILEINFO STREAM 'EOL 'ANY)
|
||||
(CL:UNLESS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)
|
||||
|
||||
(* ;;
|
||||
(* ;;
|
||||
"For TEDIT files, the character length isn't known until after text-opening")
|
||||
|
||||
(REPLACE (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK
|
||||
WITH (GETFILEINFO STREAM 'LENGTH)))
|
||||
(SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(SETQ ENDPOS (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)))
|
||||
WHILE (SETQ CHUNK (IMCOMPARE.HASH STREAM HASH.TYPE ENDPOS))
|
||||
COLLECT (REPLACE FILENAME OF CHUNK WITH FILENAME)
|
||||
CHUNK FINALLY (CLOSEF STREAM])
|
||||
(REPLACE (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK
|
||||
WITH (GETFILEINFO STREAM 'LENGTH)))
|
||||
(SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(SETQ ENDPOS (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH)
|
||||
of CHUNK)))
|
||||
WHILE (SETQ CHUNK (IMCOMPARE.HASH STREAM HASH.TYPE ENDPOS))
|
||||
COLLECT (REPLACE (IMCOMPARE.CHUNK FILENAME) OF CHUNK WITH FILENAME)
|
||||
CHUNK))])
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST
|
||||
OLDFILE.CHUNK.LIST FILELABELS) (* ; "Edited 18-Dec-2021 13:16 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 10:48 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 12:19 by rmk")
|
||||
(IMCOMPARE.DISPLAYGRAPH
|
||||
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS TITLE)
|
||||
(* ; "Edited 12-Jan-2022 09:58 by rmk")
|
||||
(* ; "Edited 27-Dec-2021 11:58 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 00:14 by rmk")
|
||||
(* mjs "11-Jul-85 09:10")
|
||||
|
||||
(* ;;; "format and display the graph")
|
||||
(* ;; "Format and display the graph")
|
||||
|
||||
(LET ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK))
|
||||
(OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK))
|
||||
NEWFILELABEL OLDFILELABEL (OLD.CHUNK.NODE.FROM.NODES NIL)
|
||||
(BORDERSIZE 1)
|
||||
GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD
|
||||
YCOORD.INCREMENT DIFF.GRAPH)
|
||||
(DECLARE (USEDFREE COMPARETEXT.ALLCHUNKS))
|
||||
(LET ((FULLFILE1 (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK1))
|
||||
(FULLFILE2 (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK2))
|
||||
FILE1LABEL FILE2LABEL FILEPREFIX 2TO1MAP (BORDERSIZE 1)
|
||||
NODES1 NODES2 COL1HEADER COL1X COL2HEADER COL2X YINCREMENT GRAPH TEMP1)
|
||||
|
||||
(* ;;; "set up GRAPH.WINDOW. This is done first so you can get the width and height of strings to be printed in the window.")
|
||||
(* ;; "Create the nodes for the column headers")
|
||||
|
||||
(SETQ NEWFILELABEL (OR (CAR (LISTP FILELABELS))
|
||||
NEWFILENAME))
|
||||
(SETQ OLDFILELABEL (OR (CADR (LISTP FILELABELS))
|
||||
OLDFILENAME))
|
||||
[SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA NIL)
|
||||
"Paragraph")
|
||||
(LINE "Line")
|
||||
(WORD "Word")
|
||||
(SHOULDNT]
|
||||
(WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
|
||||
[WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
|
||||
(if (EQ WINDOW IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
then (SETQ IMCOMPARE.LAST.GRAPH.WINDOW
|
||||
NIL)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL]
|
||||
(SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILELABEL GRAPH.WINDOW)
|
||||
2))
|
||||
[SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
|
||||
(IQUOTIENT (STRINGWIDTH
|
||||
OLDFILELABEL
|
||||
GRAPH.WINDOW)
|
||||
2)
|
||||
20]
|
||||
[SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
|
||||
(fetch (REGION HEIGHT) of (STRINGREGION NEWFILELABEL
|
||||
GRAPH.WINDOW]
|
||||
(SETQ FILE1LABEL (OR (CAR (LISTP FILELABELS))
|
||||
FULLFILE1))
|
||||
(SETQ FILE2LABEL (OR (CADR (LISTP FILELABELS))
|
||||
FULLFILE2))
|
||||
(CL:WHEN (SETQ FILEPREFIX (FB.GREATEST.PREFIX FILE1LABEL FILE2LABEL))
|
||||
[SETQ FILE1LABEL (SUBSTRING FILE1LABEL (ADD1 (NCHARS FILEPREFIX]
|
||||
[SETQ FILE2LABEL (SUBSTRING FILE2LABEL (ADD1 (NCHARS FILEPREFIX])
|
||||
(SETQ COL1X (IQUOTIENT (STRINGWIDTH FILE1LABEL DEFAULTFONT)
|
||||
2))
|
||||
(SETQ COL1HEADER (NODECREATE FULLFILE1 FILE1LABEL (CREATEPOSITION COL1X 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
[SETQ COL2X (IPLUS COL1X (IMAX 100 (IPLUS COL1X 30 (IQUOTIENT (STRINGWIDTH FILE2LABEL
|
||||
DEFAULTFONT)
|
||||
2]
|
||||
(SETQ COL2HEADER (NODECREATE FULLFILE2 FILE2LABEL (CREATEPOSITION COL2X 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
|
||||
(* ;;; "collect new-chunk graph nodes, while accumulating OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks")
|
||||
(* ;; "It would be nice to get corresponding chunks at the same positions in their lists, so that equality lines will be horizontal. Different numbers of inserts above can throw that off, we try to insert NIL spaces to even things up.")
|
||||
|
||||
(SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK
|
||||
collect (SETQ CORRESPONDING.OLD.CHUNK (CAR (fetch (IMCOMPARE.CHUNK
|
||||
OTHERCHUNK)
|
||||
of NEW.CHUNK)))
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (SETQ OLD.CHUNK.NODE.FROM.NODES
|
||||
(CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
|
||||
OLD.CHUNK.NODE.FROM.NODES)))
|
||||
[FOR C1TAIL C1 O1 ON CHUNKLIST1 AS C2TAIL C2 ON CHUNKLIST2
|
||||
EACHTIME (SETQ C1 (CAR C1TAIL))
|
||||
(SETQ C2 (CAR C2TAIL))
|
||||
(SETQ O1 (CAR (FETCH OTHERCHUNK OF C1))) UNLESS (EQ C2 O1)
|
||||
DO (IF (AND O1 (EQ O1 (CADR C2TAIL)))
|
||||
THEN
|
||||
(* ;;
|
||||
"We push NIL into the C1TAIL cell that C1 formerly occupied, move C1 down ")
|
||||
|
||||
(ATTACH NIL C1TAIL)
|
||||
ELSEIF [EQ C2 (CAR (FETCH OTHERCHUNK OF (SETQ C1 (CADR C1TAIL]
|
||||
THEN (ATTACH NIL C2TAIL) (* ;
|
||||
"OTHERCHUNK is the tail that contains C2, so it also has to be updated.")
|
||||
(REPLACE OTHERCHUNK OF C1 WITH (CDR C2TAIL)))
|
||||
|
||||
(* ;; "Make them run out at the same time.")
|
||||
|
||||
(IF (AND (CDR C1TAIL)
|
||||
(NULL (CDR C2TAIL)))
|
||||
THEN (RPLACD C2TAIL (CONS))
|
||||
ELSEIF (AND (CDR C2TAIL)
|
||||
(NULL (CDR C1TAIL)))
|
||||
THEN (RPLACD C1TAIL (CONS]
|
||||
[SETQ YINCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
|
||||
(FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
|
||||
(* ;; "Collect new-chunk graph nodes, while accumulating 2TO1MAP, assoc list from file2 chunks to file1 chunks. We skip the NILs inserted above (although Y increments).")
|
||||
|
||||
[SETQ NODES1 (for C1 C2 in CHUNKLIST1 as Y from YINCREMENT by YINCREMENT
|
||||
collect (CL:WHEN C1
|
||||
(CL:WHEN (SETQ C2 (CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of C1)))
|
||||
(PUSH 2TO1MAP (CONS C2 C1)))
|
||||
(* ;
|
||||
"Start out with 2 point white border, so we can invert it")
|
||||
(NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK FILEPTR
|
||||
) of NEW.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of NEW.CHUNK))
|
||||
12)
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (LIST CORRESPONDING.OLD.CHUNK)
|
||||
else NIL)
|
||||
NIL DEFAULTFONT -2)))
|
||||
(SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK
|
||||
collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK
|
||||
OLD.CHUNK.NODE.FROM.NODES
|
||||
)))
|
||||
(NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK FILEPTR
|
||||
) of OLD.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of OLD.CHUNK))
|
||||
12 "-")
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
NIL
|
||||
(if CORRESPONDING.NEW.CHUNK
|
||||
then (LIST CORRESPONDING.NEW.CHUNK)
|
||||
else NIL)
|
||||
DEFAULTFONT -2)))
|
||||
(SETQ DIFF.GRAPH (create GRAPH
|
||||
DIRECTEDFLG _ T
|
||||
SIDESFLG _ T
|
||||
GRAPHNODES _
|
||||
(NCONC (LIST (NODECREATE NEWFILENAME NEWFILELABEL
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
NEW.CHUNK.NODES
|
||||
(LIST (NODECREATE OLDFILENAME OLDFILELABEL
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
OLD.CHUNK.NODES)))
|
||||
(GRAPHERPROP DIFF.GRAPH 'FILELABELS (LIST NEWFILELABEL OLDFILELABEL))
|
||||
(* ;
|
||||
"So Middle mouse graphs can get the right labels")
|
||||
(GRAPHERPROP DIFF.GRAPH 'HASH.TYPE HASH.TYPE)
|
||||
(SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(NODECREATE C1 (CHUNKNODELABEL C1 10)
|
||||
(CREATEPOSITION COL1X Y)
|
||||
(CL:WHEN C2 (CONS C2))
|
||||
NIL DEFAULTFONT -2))]
|
||||
[SETQ NODES2 (for C2 C1 in CHUNKLIST2 as Y from YINCREMENT by YINCREMENT
|
||||
collect (CL:WHEN C2
|
||||
(SETQ C1 (CDR (ASSOC C2 2TO1MAP)))
|
||||
(NODECREATE C2 (CHUNKNODELABEL C2 10 (AND NIL "-"))
|
||||
(CREATEPOSITION COL2X Y)
|
||||
NIL
|
||||
(CL:WHEN C1 (CONS C1))
|
||||
DEFAULTFONT -2))]
|
||||
|
||||
(* ;; "Now eliminate all the C1/C2 node pairs that are at the same Yposition. Those would just have uninformative horizontal lines representing no differences. Maybe this can be done on the fly--don't construct such pairs--but that will come later. The node")
|
||||
|
||||
(IF COMPARETEXT.ALLCHUNKS
|
||||
THEN (SETQ NODES1 (DREMOVE NIL NODES1))
|
||||
(SETQ NODES2 (DREMOVE NIL NODES2))
|
||||
ELSE
|
||||
(* ;; "The nodes in both lists correspond, with NILs padding where needed. We can simplify the picture if we take out equivalent chunks, otherwise we show all their horizontal lines.")
|
||||
|
||||
(FOR N1 KEPT1 KEPT2 (YPOS _ YINCREMENT) IN NODES1 AS N2 IN NODES2
|
||||
UNLESS [AND N1 N2 (EQ (FETCH NODEID OF N2)
|
||||
(CAR (FETCH OTHERCHUNK OF (FETCH NODEID OF N1]
|
||||
DO (CL:WHEN N1
|
||||
(PUSH KEPT1 N1)
|
||||
(REPLACE YCOORD OF (FETCH NODEPOSITION OF N1) WITH YPOS))
|
||||
(CL:WHEN N2
|
||||
(PUSH KEPT2 N2)
|
||||
(REPLACE YCOORD OF (FETCH NODEPOSITION OF N2) WITH YPOS))
|
||||
(ADD YPOS YINCREMENT) FINALLY (SETQ NODES1 KEPT1)
|
||||
(SETQ NODES2 KEPT2)))
|
||||
|
||||
(* ;;
|
||||
"Keep column xcords so leftbutton can tell a node's column, keep labels for new middle mouse graph ")
|
||||
|
||||
[SETQ GRAPH (create GRAPH
|
||||
DIRECTEDFLG _ T
|
||||
SIDESFLG _ T
|
||||
GRAPHNODES _ (NCONC (LIST COL1HEADER)
|
||||
NODES1
|
||||
(LIST COL2HEADER)
|
||||
NODES2)
|
||||
GRAPH.PROPS _ `(HASH.TYPE ,HASH.TYPE FILELABELS (,FILEPREFIX ,FILE1LABEL
|
||||
,FILE2LABEL)
|
||||
COL1X
|
||||
,COL1X COL2X ,COL2X ALLCHUNKS
|
||||
,COMPARETEXT.ALLCHUNKS]
|
||||
(SHOWGRAPH GRAPH (COMPARETEXT.WINDOW GRAPH REGION TITLE)
|
||||
(FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
|
||||
T NIL])
|
||||
|
||||
(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT
|
||||
[LAMBDA (FILE) (* ; "Edited 16-Dec-2021 08:40 by rmk")
|
||||
(* mjs " 2-Jan-84 16:19")
|
||||
|
||||
(* ;; "returns the Tedit text object of the first Tedit window which is currently looking at FILE, if there is one. Returns NIL if none is found.")
|
||||
|
||||
(for W in (OPENWINDOWS) bind POSS.TOBJ when [AND (SETQ POSS.TOBJ (WINDOWPROP W 'TEXTOBJ))
|
||||
(EQ FILE (FULLNAME (fetch (TEXTOBJ TXTFILE)
|
||||
of POSS.TOBJ]
|
||||
unless (TEDIT.STREAMCHANGEDP POSS.TOBJ) do (RETURN POSS.TOBJ])
|
||||
|
||||
(IMCOMPARE.HASH
|
||||
[LAMBDA (STREAM HASH.TYPE ENDPOS) (* ; "Edited 19-Dec-2021 09:07 by rmk")
|
||||
(* ; "Edited 15-Dec-2021 15:58 by rmk")
|
||||
@@ -370,58 +541,6 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
CHUNKLENGTH _ (IDIFFERENCE (GETFILEPTR STREAM)
|
||||
STARTPOS)))])
|
||||
|
||||
(IMCOMPARE.LEFTBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* ; "Edited 18-Dec-2021 13:02 by rmk")
|
||||
(* mjs " 2-Apr-85 14:21")
|
||||
(if GNODE
|
||||
then (LET ((NODEID (fetch (GRAPHNODE NODEID) of GNODE)))
|
||||
(IF (FIXP (CAR NODEID))
|
||||
THEN (IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
[LET ((FILEPTR 1)
|
||||
(CHUNKLENGTH 0)
|
||||
(TEDIT.TEXT.OBJECT NIL)
|
||||
FILE)
|
||||
(SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID))
|
||||
(SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID))
|
||||
(SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID))
|
||||
(SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE))
|
||||
(if TEDIT.TEXT.OBJECT
|
||||
then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR
|
||||
25))
|
||||
0
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW)
|
||||
of TEDIT.TEXT.OBJECT))
|
||||
'PROCESS))
|
||||
else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH]
|
||||
ELSEIF (AND (LITATOM NODEID)
|
||||
(INFILEP NODEID))
|
||||
THEN
|
||||
(* ;;
|
||||
"A file name as a column header, do TEDIT on the whole file, no selection")
|
||||
|
||||
(TEDIT-SEE NODEID)
|
||||
ELSE (SHOULDNT])
|
||||
|
||||
(IMCOMPARE.LENGTHEN.ATOM
|
||||
[LAMBDA (X MIN.LENGTH EXTENDER) (* ; "Edited 13-Dec-2021 21:18 by rmk")
|
||||
(* mjs "30-Dec-83 15:11")
|
||||
|
||||
(* ;; "makes sure that the atom X is at least MIN.LENGTH characters long, by concatenating the first character of EXTENDER (or space, if not given) to the front")
|
||||
|
||||
(IF (ILESSP (NCHARS X)
|
||||
MIN.LENGTH)
|
||||
THEN (PACK* (ALLOCSTRING (IDIFFERENCE MIN.LENGTH (NCHARS X))
|
||||
(CL:IF EXTENDER
|
||||
(NTHCHAR EXTENDER 1)
|
||||
" "))
|
||||
X)
|
||||
ELSE X])
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
[LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35")
|
||||
(while NEW.CHUNK.LIST bind NEW.CHUNK OLD.CHUNK.PTR
|
||||
@@ -490,46 +609,6 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
list)
|
||||
(RPLACD CHUNK.LST (CDDR CHUNK.LST])
|
||||
|
||||
(IMCOMPARE.MIDDLEBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW)
|
||||
|
||||
(* ;; "Edited 16-Dec-2021 10:55 by rmk: Remove previous HASH.TYPE from the middle mouse menu")
|
||||
(* ; "Edited 16-Dec-2021 10:51 by rmk")
|
||||
(* mjs " 6-Jan-84 11:37")
|
||||
|
||||
(* ;; "This function is called if the MIDDLE mouse button is pressed over a graph node. The selected node is IMCOMPARE-ed with the last node selected <which is boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a pop-up menu. If none of the hashing types is selected, the current node is boxed. The pop-up menu is always located a little above the current cursor position, so a quick double-MIDDLE-click is an easy way to change the current boxed node.")
|
||||
|
||||
(if GNODE
|
||||
then (PROG (INNER.HASH.TYPE)
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please select the type of hashing you wish." T)
|
||||
[SETQ INNER.HASH.TYPE (MENU (create MENU
|
||||
ITEMS _ (REMOVE (GRAPHERPROP
|
||||
(WINDOWPROP WINDOW
|
||||
'GRAPH)
|
||||
'HASH.TYPE)
|
||||
'(PARA LINE WORD))
|
||||
MENUOFFSET _
|
||||
(create POSITION
|
||||
XCOORD _ 20
|
||||
YCOORD _ -20]
|
||||
(if (NULL INNER.HASH.TYPE)
|
||||
then (* ;
|
||||
"if no hash type is selected, just box the current node and return")
|
||||
(IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(RETURN))
|
||||
(if (NULL IMCOMPARE.LAST.NODE)
|
||||
then (CLRPROMPT)
|
||||
(PRIN1 "You must select another graph node first." PROMPTWINDOW)
|
||||
(RETURN))
|
||||
(printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
|
||||
(IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE)
|
||||
(fetch (GRAPHNODE NODEID) of GNODE)
|
||||
INNER.HASH.TYPE
|
||||
(WINDOWPROP WINDOW 'REGION)
|
||||
(GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
|
||||
'FILELABELS])
|
||||
|
||||
(IMCOMPARE.SHOW.DIST
|
||||
[LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13")
|
||||
(PROG ((WINDOW (CREATEW))
|
||||
@@ -570,12 +649,124 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(replace (IMCOMPARE.SYMB NEWCOUNT) of SYMB
|
||||
with (ADD1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(MOVD 'COMPARETEXT 'IMCOMPARE)
|
||||
(IMCOMPARE.LEFTBUTTONFN
|
||||
[LAMBDA (NODE WINDOW) (* ; "Edited 25-Dec-2021 23:29 by rmk")
|
||||
(* ; "Edited 22-Dec-2021 21:41 by rmk")
|
||||
(* ; "Edited 18-Dec-2021 13:02 by rmk")
|
||||
(* mjs " 2-Apr-85 14:21")
|
||||
(CL:WHEN NODE
|
||||
(LET [(INCOL1 (EQ (GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
|
||||
'COL1X)
|
||||
(FETCH (POSITION XCOORD) OF (FETCH (GRAPHNODE NODEPOSITION) OF NODE]
|
||||
(IF (FIXP (CAR (fetch (GRAPHNODE NODEID) of NODE)))
|
||||
THEN (IMCOMPARE.BOXNODE WINDOW NODE (FOR N (YPOS _ (FETCH YCOORD
|
||||
OF (FETCH NODEPOSITION
|
||||
OF NODE)))
|
||||
IN (FETCH GRAPHNODES
|
||||
OF (WINDOWPROP WINDOW 'GRAPH))
|
||||
UNLESS (EQ N NODE)
|
||||
WHEN (EQ YPOS (FETCH YCOORD
|
||||
OF (FETCH NODEPOSITION
|
||||
OF N)))
|
||||
DO
|
||||
(* ;;
|
||||
"We won't match the other label node because it has a unique ypos")
|
||||
|
||||
(RPAQ? IMCOMPARE.LAST.NODE NIL)
|
||||
(COMPARETEXT.SETSEL (COMPARETEXT.TEXTOBJ
|
||||
N WINDOW (NOT INCOL1)
|
||||
)
|
||||
N)
|
||||
(RETURN N)))
|
||||
(COMPARETEXT.SETSEL (COMPARETEXT.TEXTOBJ NODE WINDOW INCOL1)
|
||||
NODE)
|
||||
ELSE
|
||||
(* ;; "The column header, set up the file window with no selection.")
|
||||
|
||||
(RPAQ? IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
(COMPARETEXT.TEXTOBJ NODE WINDOW INCOL1))))])
|
||||
|
||||
(IMCOMPARE.MIDDLEBUTTONFN
|
||||
[LAMBDA (NODE WINDOW) (* ; "Edited 27-Dec-2021 11:59 by rmk")
|
||||
(* ; "Edited 25-Dec-2021 11:51 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 10:42 by rmk")
|
||||
(* ; "Edited 22-Dec-2021 16:08 by rmk")
|
||||
|
||||
(* ;; "Edited 16-Dec-2021 10:55 by rmk: Remove previous HASH.TYPE from the middle mouse menu")
|
||||
(* ; "Edited 16-Dec-2021 10:51 by rmk")
|
||||
(* mjs " 6-Jan-84 11:37")
|
||||
|
||||
(* ;; "This function is called if the MIDDLE mouse button is pressed over a graph node. The selected node is IMCOMPARE-ed with the last node selected <which is boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a pop-up menu. If none of the hashing types is selected, the current node is boxed. The pop-up menu is always located a little above the current cursor position, so a quick double-MIDDLE-click is an easy way to change the current boxed node.")
|
||||
|
||||
(CL:WHEN NODE
|
||||
[PROG (INNER.HASH.TYPE REGION (LASTNODES (WINDOWPROP WINDOW 'LASTNODES))
|
||||
(PWINDOW (GETPROMPTWINDOW WINDOW)))
|
||||
(CLEARW PWINDOW)
|
||||
(CL:UNLESS LASTNODES
|
||||
(PRIN3 "Select nodes to be expanded" PWINDOW)
|
||||
(RETURN))
|
||||
[SETQ INNER.HASH.TYPE (MENU (create MENU
|
||||
TITLE _ "New hash type?"
|
||||
ITEMS _ (REMOVE (GRAPHERPROP (WINDOWPROP
|
||||
WINDOW
|
||||
'GRAPH)
|
||||
'HASH.TYPE)
|
||||
'(PARA LINE WORD))
|
||||
MENUOFFSET _
|
||||
(create POSITION
|
||||
XCOORD _ 20
|
||||
YCOORD _ -20]
|
||||
(printout PWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
|
||||
|
||||
(* ;; "Offset the region a little bit, so that the parent region is visible")
|
||||
|
||||
[SETQ REGION (COPY (WINDOWPROP WINDOW 'REGION]
|
||||
(ADD (FETCH (REGION LEFT) OF REGION)
|
||||
30)
|
||||
(ADD (FETCH (REGION BOTTOM) OF REGION)
|
||||
-30)
|
||||
(IMCOMPARE.CHUNKS (FETCH (GRAPHNODE NODEID) OF (CAR LASTNODES))
|
||||
(FETCH (GRAPHNODE NODEID) OF (CADR LASTNODES))
|
||||
INNER.HASH.TYPE REGION (CDR (GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
|
||||
'FILELABELS])])
|
||||
|
||||
(IMCOMPARE.COPYBUTTONFN
|
||||
[LAMBDA (WINDOW NODE) (* ; "Edited 25-Dec-2021 13:26 by rmk")
|
||||
(* ; "")
|
||||
|
||||
(* ;; "The grapher calls this with the window but not the node. So there must be some internal grapher stuff to find the node from the mouse coordinates. The goal would be to at least do a COPYINSERT of the filename.")
|
||||
|
||||
(HELP])
|
||||
)
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
GRAPHER REGIONMANAGER)
|
||||
(DEFINEQ
|
||||
|
||||
(TAIL1
|
||||
[LAMBDA (ALL) (* ; "Edited 25-Dec-2021 21:54 by rmk")
|
||||
(FOR X IN (CL:IF ALL
|
||||
CHUNKLIST1
|
||||
C1TAIL) COLLECT (LIST (FETCH FILEPTR OF X)
|
||||
(FETCH FILEPTR OF (CAR (FETCH OTHERCHUNK OF X])
|
||||
|
||||
(TAIL2
|
||||
[LAMBDA (ALL) (* ; "Edited 25-Dec-2021 21:29 by rmk")
|
||||
(FOR X IN (CL:IF ALL
|
||||
CHUNKLIST2
|
||||
C2TAIL) COLLECT (LIST (FETCH FILEPTR OF X)
|
||||
(FETCH OTHERCHUNK OF X])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Debugging")
|
||||
|
||||
|
||||
(RPAQ? COMPARETEXT.ALLCHUNKS T)
|
||||
|
||||
(RPAQ? COMPARETEXT.AUTOTEDIT T)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK)
|
||||
@@ -584,20 +775,18 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR))
|
||||
)
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
GRAPHER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
GRAPHER)
|
||||
)
|
||||
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1334 38876 (COMPARETEXT 1344 . 3554) (IMCOMPARE.BOXNODE 3556 . 4072) (IMCOMPARE.CHUNKS
|
||||
4074 . 8592) (IMCOMPARE.COLLECT.HASH.CHUNKS 8594 . 11053) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
|
||||
11055 . 20136) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 20138 . 20912) (IMCOMPARE.HASH 20914 . 25101) (
|
||||
IMCOMPARE.LEFTBUTTONFN 25103 . 27545) (IMCOMPARE.LENGTHEN.ATOM 27547 . 28249) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 28251 . 31747) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 31749 . 33704) (
|
||||
IMCOMPARE.MIDDLEBUTTONFN 33706 . 36541) (IMCOMPARE.SHOW.DIST 36543 . 36989) (
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE 36991 . 38874)))))
|
||||
(FILEMAP (NIL (1345 42591 (COMPARETEXT 1355 . 2855) (COMPARETEXT.WINDOW 2857 . 7675) (
|
||||
COMPARETEXT.TEXTOBJ 7677 . 12786) (COMPARETEXT.SETSEL 12788 . 13578) (CHUNKNODELABEL 13580 . 14701) (
|
||||
IMCOMPARE.BOXNODE 14703 . 15470) (IMCOMPARE.CHUNKS 15472 . 19848) (IMCOMPARE.COLLECT.HASH.CHUNKS 19850
|
||||
. 22767) (IMCOMPARE.DISPLAYGRAPH 22769 . 30612) (IMCOMPARE.HASH 30614 . 34801) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 34803 . 38299) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 38301 . 40256) (
|
||||
IMCOMPARE.SHOW.DIST 40258 . 40704) (IMCOMPARE.UPDATE.SYMBOL.TABLE 40706 . 42589)) (42592 48749 (
|
||||
IMCOMPARE.LEFTBUTTONFN 42602 . 45179) (IMCOMPARE.MIDDLEBUTTONFN 45181 . 48297) (IMCOMPARE.COPYBUTTONFN
|
||||
48299 . 48747)) (48802 49493 (TAIL1 48812 . 49166) (TAIL2 49168 . 49491)))))
|
||||
STOP
|
||||
|
||||
454
sources/ADIR
454
sources/ADIR
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "13-Jun-2021 11:25:58" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ADIR.;9 65815
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS OPENSTREAM)
|
||||
(FILECREATED "26-Jan-2022 10:18:43" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;12 66655
|
||||
|
||||
previous date%: "21-Mar-2021 21:59:07"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ADIR.;8)
|
||||
:CHANGES-TO (VARS ADIRCOMS)
|
||||
|
||||
:PREVIOUS-DATE "25-Jan-2022 17:19:00"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ADIR.;11)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -14,14 +15,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(PRETTYCOMPRINT ADIRCOMS)
|
||||
|
||||
(RPAQQ ADIRCOMS
|
||||
[[COMS (* ; "user-level i/o routines")
|
||||
[[COMS (* ; "user-level i/o routines")
|
||||
(FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP
|
||||
RENAMEFILE SIMPLE.FINDFILE VMEMSIZE \COPYSYS \FLUSHVM \LOGOUT0)
|
||||
(CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
|
||||
(P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P
|
||||
|
||||
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
|
||||
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
|
||||
|
||||
(MOVD? 'NILL 'CL:PATHNAMEP]
|
||||
(COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP
|
||||
@@ -29,9 +30,10 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY
|
||||
PACKFILENAME.ASSEMBLE UNPACKFILE1))
|
||||
(VARS \FILENAME.SYNTAX)
|
||||
(FNS FILEDIRCASEARRAY)
|
||||
(VARS (FILEDIRCASEARRAY (FILEDIRCASEARRAY)))
|
||||
(GLOBALVARS \FILENAME.SYNTAX))
|
||||
(COMS (* ;
|
||||
"saving and restoring system state")
|
||||
(COMS (* ; "saving and restoring system state")
|
||||
(FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT)
|
||||
(ADDVARS (AROUNDEXITFNS))
|
||||
(INITVARS (HERALDSTRING "")
|
||||
@@ -274,7 +276,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
|
||||
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
|
||||
(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.")
|
||||
|
||||
|
||||
(MOVD? 'NILL 'CL:PATHNAMEP)
|
||||
@@ -286,10 +288,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])
|
||||
|
||||
(UNPACKFILENAME.STRING
|
||||
[LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm")
|
||||
[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)
|
||||
@@ -302,7 +308,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
((TYPEP FILE 'PATHNAME)
|
||||
(RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
|
||||
[(STREAMP FILE) (* ;
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
|
||||
(RETURN (COND
|
||||
(ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
|
||||
@@ -316,12 +322,12 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
FILE 2)
|
||||
0))))
|
||||
(%[ (* ;
|
||||
"some Xerox and Arpanet systems use '[' for host")
|
||||
"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")
|
||||
"this is the 'proposed standard' for Xerox servers")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
|
||||
FILE 2)
|
||||
0))))
|
||||
@@ -329,21 +335,26 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(UNPACKFILE1 'HOST 2 TEM)
|
||||
[COND
|
||||
((EQ TEM -1) (* ;
|
||||
"Started with the host field delimiter, but there was no corresponding terminating delimiter .")
|
||||
"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.")
|
||||
"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]
|
||||
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
|
||||
((SETQ TEM (LASTCHPOS (CHARCODE %:)
|
||||
FILE POS)) (* ;
|
||||
"all device returned have DEVICE.END on it so that NIL: will work")
|
||||
((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))
|
||||
@@ -356,7 +367,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(NIL (* ; "just host, return")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
((/ <) (* ;
|
||||
"Started with the initial directory delimiter.")
|
||||
"Started with the initial directory delimiter.")
|
||||
(ADD1 POS))
|
||||
POS))
|
||||
END)
|
||||
@@ -364,7 +375,7 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
((/ >)
|
||||
[COND
|
||||
((EQ START POS) (* ;
|
||||
"Didn't start with a directory delimiter,")
|
||||
"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))
|
||||
@@ -372,13 +383,13 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(SETQ TYPE 'RELATIVEDIRECTORY]
|
||||
(COND
|
||||
((EQ LEN POS) (* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}/%").")
|
||||
"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.")
|
||||
"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))
|
||||
@@ -387,24 +398,24 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(T (COND
|
||||
((EQ LEN POS)
|
||||
(* ;
|
||||
"Only the initial directory is specified (i.e. %"{DSK}<%").")
|
||||
"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")
|
||||
"unix and the 'xerox standard' use / for delimiter")
|
||||
(* ;
|
||||
"In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
|
||||
"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 >>")
|
||||
"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.")
|
||||
"In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE (> /))
|
||||
FILE
|
||||
(ADD1 POS)))
|
||||
@@ -415,20 +426,19 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
|
||||
(if TEM
|
||||
then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
|
||||
(SUB1 TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
(SUB1 TEM))
|
||||
(SETQ POS (ADD1 TEM))
|
||||
else
|
||||
(* ;; "{DSK}/foo: the directory is /, the name is foo")
|
||||
|
||||
(* ;; "{DSK}/foo: the directory is /, the name is foo")
|
||||
|
||||
(UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
|
||||
(SETQ POS (ADD1 POS)))
|
||||
(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.")
|
||||
" This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.")
|
||||
|
||||
[COND
|
||||
((NOT HOSTP) (* ; "%"Incomplete file names%" case.")
|
||||
@@ -448,9 +458,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(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))
|
||||
then (* ;
|
||||
"There wasn't a host field in the name, so we have no clue")
|
||||
(SETQ OSTYPE NIL))
|
||||
NAMELP
|
||||
|
||||
|
||||
@@ -458,61 +468,61 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
|
||||
(SELCHARQ CODE
|
||||
(%. (* ;
|
||||
"Note position for later--we only want to deal with the last set of dots")
|
||||
"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)")
|
||||
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)
|
||||
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")
|
||||
"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)
|
||||
(! (* ;
|
||||
"! 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")
|
||||
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))
|
||||
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
|
||||
(SUB1 SECONDDOT))
|
||||
(SETQ BEYONDEXT T)
|
||||
SECONDDOT
|
||||
else FIRSTDOT)))
|
||||
(SETQ BEYONDNAME T)
|
||||
(SETQ FIRSTDOT NIL))
|
||||
@@ -524,15 +534,15 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
((AND (EQ BEYONDEXT (CHARCODE ";"))
|
||||
(\UPF.TEMPFILEP FILE POS)))
|
||||
(T (* ;
|
||||
"Everything after the semi was version")
|
||||
"Everything after the semi was version")
|
||||
'VERSION))
|
||||
POS
|
||||
(SUB1 TEM))
|
||||
(if (NULL CODE)
|
||||
then (* ; "End of string")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
then (* ; "End of string")
|
||||
(RETURN (DREVERSE VAL)))
|
||||
(SETQ BEYONDEXT CODE) (* ;
|
||||
"Note the character that terminated the name/ext")
|
||||
"Note the character that terminated the name/ext")
|
||||
(SETQ POS (ADD1 TEM)))
|
||||
(%' (* ; "Quoter")
|
||||
(add TEM 1))
|
||||
@@ -623,80 +633,74 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(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 >))
|
||||
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)))
|
||||
(%' (\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 >))
|
||||
(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)
|
||||
))
|
||||
(%' (\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])
|
||||
(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
|
||||
(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 ""])
|
||||
(T (OR NEWDIR "")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
|
||||
(T (OR NEWDIR ""])
|
||||
|
||||
(PUTPROPS PACKFILENAME.ASSEMBLE MACRO
|
||||
[NIL
|
||||
@@ -705,11 +709,11 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION
|
||||
VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
|
||||
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION
|
||||
VERSION TEMPORARY PROTECTION ACCOUNT))
|
||||
VERSION TEMPORARY PROTECTION ACCOUNT))
|
||||
LP (COND
|
||||
((<= I N)
|
||||
|
||||
(* ;; "Grab the next field-name / value pair and fold it into the filename:")
|
||||
(* ;; "Grab the next field-name / value pair and fold it into the filename:")
|
||||
|
||||
(COND
|
||||
((LISTP (SETQ VAR (ARG N I)))
|
||||
@@ -725,9 +729,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(\ILLEGAL.ARG VAL))
|
||||
(SELECTQ VAR
|
||||
(BODY (MAP (UNPACKFILENAME.STRING (COND
|
||||
((LISTP VAL)
|
||||
(PACKFILENAME.STRING VAL))
|
||||
(T VAL))
|
||||
((LISTP VAL)
|
||||
(PACKFILENAME.STRING VAL))
|
||||
(T VAL))
|
||||
NIL
|
||||
'OK)
|
||||
[FUNCTION (LAMBDA (X)
|
||||
@@ -781,52 +785,49 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
((PATHNAME DIRECTORY)
|
||||
[COND
|
||||
(VAL
|
||||
(for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL
|
||||
'RETURN))
|
||||
(for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL 'RETURN))
|
||||
by (CDDR X)
|
||||
do (SELECTQ (CAR X)
|
||||
(HOST [COND
|
||||
((NOT HOST)
|
||||
(SETQ HOST (OR (CADR X)
|
||||
(HOST [COND
|
||||
((NOT HOST)
|
||||
(SETQ HOST (OR (CADR X)
|
||||
BLIP])
|
||||
(DEVICE [COND
|
||||
((NOT DEVICE)
|
||||
(SETQ DEVICE (OR (CADR X)
|
||||
BLIP])
|
||||
(DEVICE [COND
|
||||
((NOT DEVICE)
|
||||
(SETQ DEVICE (OR (CADR X)
|
||||
BLIP])
|
||||
(SUBDIRECTORY [OR DIRECTORY
|
||||
(COND
|
||||
(RELATIVEDIRECTORY (SETQ
|
||||
DIRECTORY
|
||||
BLIP))
|
||||
(T (SETQ DIRECTORY
|
||||
(OR (CADR X)
|
||||
BLIP])
|
||||
(RELATIVEDIRECTORY
|
||||
(SUBDIRECTORY [OR DIRECTORY
|
||||
(COND
|
||||
(RELATIVEDIRECTORY (SETQ DIRECTORY
|
||||
BLIP))
|
||||
(T (SETQ DIRECTORY
|
||||
(OR (CADR X)
|
||||
BLIP])
|
||||
(RELATIVEDIRECTORY
|
||||
|
||||
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
|
||||
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
|
||||
|
||||
(OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
|
||||
(OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
|
||||
(OR (CADR X)
|
||||
BLIP))))
|
||||
(DIRECTORY [OR DIRECTORY (COND
|
||||
(RELATIVEDIRECTORY
|
||||
(SETQ DIRECTORY BLIP))
|
||||
(T (SETQ DIRECTORY
|
||||
(OR (CADR X)
|
||||
BLIP))))
|
||||
(DIRECTORY [OR DIRECTORY
|
||||
(COND
|
||||
(RELATIVEDIRECTORY (SETQ DIRECTORY
|
||||
BLIP))
|
||||
(T (SETQ DIRECTORY
|
||||
(OR (CADR X)
|
||||
BLIP])
|
||||
(ERROR "Illegal field in DIRECTORY slot" VAL)))
|
||||
BLIP])
|
||||
(ERROR "Illegal field in DIRECTORY slot" VAL)))
|
||||
(for X on VAL by (CDDR X)
|
||||
do (SELECTQ (CAR X)
|
||||
(HOST (OR DEVICE (SETQ DEVICE BLIP))
|
||||
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
|
||||
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
|
||||
NIL)))
|
||||
(HOST (OR DEVICE (SETQ DEVICE BLIP))
|
||||
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
|
||||
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
|
||||
NIL)))
|
||||
(T (OR DIRECTORY (SETQ DIRECTORY BLIP])
|
||||
(SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP))))
|
||||
(RELATIVEDIRECTORY
|
||||
|
||||
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
|
||||
(* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS")
|
||||
|
||||
(OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP))))
|
||||
(DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP))))
|
||||
@@ -868,9 +869,9 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
[COND
|
||||
(DIRECTORY (COND
|
||||
[[OR (STREQUAL DIRECTORY "<")
|
||||
(AND (SETQ TEMP (LASTCHPOS
|
||||
(CHARCODE (> /))
|
||||
DIRECTORY 1))
|
||||
(AND (SETQ TEMP (LASTCHPOS (CHARCODE
|
||||
(> /))
|
||||
DIRECTORY 1))
|
||||
(EQ TEMP (NCHARS DIRECTORY]
|
||||
(COND
|
||||
((EQMEMB (NTHCHARCODE DIRECTORY 1)
|
||||
@@ -913,24 +914,41 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(SUBSTRING VERSION 2 -1))
|
||||
VERSION])
|
||||
|
||||
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END)
|
||||
(* lmm "22-APR-81 22:21")
|
||||
(COND
|
||||
[(NOT ONEFIELDFLG)
|
||||
(SETQ VAL (CONS (COND
|
||||
(PACKFLG (SUBATOM FILE ST END))
|
||||
(T (OR (SUBSTRING FILE ST END)
|
||||
"")))
|
||||
(CONS NAM VAL]
|
||||
((EQMEMB NAM ONEFIELDFLG)
|
||||
(RETURN (COND
|
||||
(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)
|
||||
""])
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQQ \FILENAME.SYNTAX ("<" ">" ";"))
|
||||
(DEFINEQ
|
||||
|
||||
(FILEDIRCASEARRAY
|
||||
[LAMBDA NIL (* ; "Edited 8-Jan-2022 20:15 by rmk")
|
||||
|
||||
(* ;; "Returns a case array suitable for case insensitive directory matching: <, >, and / all map together in any position. Presumably there are other well-formedness conditions that put < and > only in their proper positions.")
|
||||
(* ; "Edited 8-Jan-2022 20:12 by rmk")
|
||||
(for I (CA _ (CASEARRAY)) from (CHARCODE a) to (CHARCODE z)
|
||||
do [SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a)
|
||||
(CHARCODE A]
|
||||
finally (SETCASEARRAY CA (CHARCODE <)
|
||||
(CHARCODE /))
|
||||
(SETCASEARRAY CA (CHARCODE >)
|
||||
(CHARCODE /))
|
||||
(RETURN CA])
|
||||
)
|
||||
|
||||
(RPAQ FILEDIRCASEARRAY (FILEDIRCASEARRAY))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS \FILENAME.SYNTAX)
|
||||
@@ -1158,14 +1176,14 @@ Copyright (c) 1981-1988, 1990-1992, 1920, 2017, 2020-2021 by Venue & Xerox Corpo
|
||||
(PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1991 1992 1920 2017 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2733 13858 (DELFILE 2743 . 2904) (FULLNAME 2906 . 3273) (INFILE 3275 . 3423) (INFILEP
|
||||
3425 . 3560) (IOFILE 3562 . 3702) (OPENFILE 3704 . 4104) (OPENSTREAM 4106 . 8446) (OUTFILE 8448 . 8599
|
||||
) (OUTFILEP 8601 . 8737) (RENAMEFILE 8739 . 9045) (SIMPLE.FINDFILE 9047 . 9457) (VMEMSIZE 9459 . 9626)
|
||||
(\COPYSYS 9628 . 12577) (\FLUSHVM 12579 . 13651) (\LOGOUT0 13653 . 13856)) (14230 33821 (
|
||||
UNPACKFILENAME 14240 . 14426) (UNPACKFILENAME.STRING 14428 . 30700) (LASTCHPOS 30702 . 31396) (
|
||||
\UPF.NEXTPOS 31398 . 32043) (\UPF.TEMPFILEP 32045 . 32622) (FILENAMEFIELD 32624 . 33109) (PACKFILENAME
|
||||
33111 . 33454) (PACKFILENAME.STRING 33456 . 33819)) (56262 63442 (LOGOUT 56272 . 57189) (MAKESYS
|
||||
57191 . 58820) (SYSOUT 58822 . 60374) (SAVEVM 60376 . 61176) (HERALD 61178 . 61338) (INTERPRET.REM.CM
|
||||
61340 . 63065) (\USEREVENT 63067 . 63440)) (63624 65351 (USERNAME 63634 . 64590) (SETUSERNAME 64592 .
|
||||
65349)))))
|
||||
(FILEMAP (NIL (2771 13896 (DELFILE 2781 . 2942) (FULLNAME 2944 . 3311) (INFILE 3313 . 3461) (INFILEP
|
||||
3463 . 3598) (IOFILE 3600 . 3740) (OPENFILE 3742 . 4142) (OPENSTREAM 4144 . 8484) (OUTFILE 8486 . 8637
|
||||
) (OUTFILEP 8639 . 8775) (RENAMEFILE 8777 . 9083) (SIMPLE.FINDFILE 9085 . 9495) (VMEMSIZE 9497 . 9664)
|
||||
(\COPYSYS 9666 . 12615) (\FLUSHVM 12617 . 13689) (\LOGOUT0 13691 . 13894)) (14268 34500 (
|
||||
UNPACKFILENAME 14278 . 14464) (UNPACKFILENAME.STRING 14466 . 31379) (LASTCHPOS 31381 . 32075) (
|
||||
\UPF.NEXTPOS 32077 . 32722) (\UPF.TEMPFILEP 32724 . 33301) (FILENAMEFIELD 33303 . 33788) (PACKFILENAME
|
||||
33790 . 34133) (PACKFILENAME.STRING 34135 . 34498)) (56022 56935 (FILEDIRCASEARRAY 56032 . 56933)) (
|
||||
57102 64282 (LOGOUT 57112 . 58029) (MAKESYS 58031 . 59660) (SYSOUT 59662 . 61214) (SAVEVM 61216 .
|
||||
62016) (HERALD 62018 . 62178) (INTERPRET.REM.CM 62180 . 63905) (\USEREVENT 63907 . 64280)) (64464
|
||||
66191 (USERNAME 64474 . 65430) (SETUSERNAME 65432 . 66189)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
55
sources/ATBL
55
sources/ATBL
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Dec-2021 14:09:43" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;31 91882
|
||||
(FILECREATED "26-Dec-2021 14:32:50" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;32 91860
|
||||
|
||||
:CHANGES-TO (FNS EQUAL-READER-ENVIRONMENT)
|
||||
:CHANGES-TO (FNS MAKE-READER-ENVIRONMENT)
|
||||
|
||||
:PREVIOUS-DATE "24-Oct-2021 21:53:59"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;29)
|
||||
:PREVIOUS-DATE "19-Dec-2021 14:09:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;31)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -1832,10 +1832,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(MAKE-READER-ENVIRONMENT
|
||||
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
|
||||
(* ;
|
||||
"Edited 24-Oct-2021 21:53 by rmk:")
|
||||
(* ;
|
||||
"Edited 16-Aug-2021 23:44 by rmk:")
|
||||
(* ; "Edited 26-Dec-2021 14:32 by rmk")
|
||||
(* ; "Edited 24-Oct-2021 21:53 by rmk:")
|
||||
(* ; "Edited 16-Aug-2021 23:44 by rmk:")
|
||||
|
||||
(* ;; "PACKAGE can be a prop list of keyword-values")
|
||||
|
||||
@@ -1852,12 +1851,12 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
((CL:PACKAGEP PACKAGE)
|
||||
PACKAGE)
|
||||
[PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
|
||||
(\DEST PACKAGE 'PACKAGE]
|
||||
(\DTEST PACKAGE 'PACKAGE]
|
||||
(T *PACKAGE*))
|
||||
REREADTABLE _ (COND
|
||||
((READTABLEP READTABLE))
|
||||
[READTABLE (OR (FIND-READTABLE READTABLE)
|
||||
(\DEST READTABLE 'READTABLEP]
|
||||
(\DTEST READTABLE 'READTABLEP]
|
||||
(T *READTABLE*))
|
||||
REBASE _ (COND
|
||||
(BASE (\CHECKRADIX BASE))
|
||||
@@ -1925,22 +1924,22 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018
|
||||
2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (17750 28902 (GETSYNTAX 17760 . 22591) (SETSYNTAX 22593 . 23666) (SYNTAXP 23668 . 26165)
|
||||
(\COPYSYNTAX 26167 . 26884) (\GETCHARCODE 26886 . 27174) (\SETFATSYNCODE 27176 . 28467) (
|
||||
\MAPCHARTABLE 28469 . 28900)) (28935 43901 (CONTROL 28945 . 29197) (COPYTERMTABLE 29199 . 29566) (
|
||||
DELETECONTROL 29568 . 32209) (GETDELETECONTROL 32211 . 33173) (ECHOCHAR 33175 . 34616) (ECHOCONTROL
|
||||
34618 . 35075) (ECHOMODE 35077 . 35323) (GETECHOMODE 35325 . 35489) (GETCONTROL 35491 . 35657) (
|
||||
GETTERMTABLE 35659 . 35726) (RAISE 35728 . 36154) (GETRAISE 36156 . 36318) (RESETTERMTABLE 36320 .
|
||||
37404) (SETTERMTABLE 37406 . 37640) (TERMTABLEP 37642 . 37803) (\GETTERMSYNTAX 37805 . 38076) (
|
||||
\GTTERMTABLE 38078 . 38414) (\ORIGTERMTABLE 38416 . 42026) (\SETTERMSYNTAX 42028 . 42663) (
|
||||
\TERMCLASSTOCODE 42665 . 43094) (\TERMCODETOCLASS 43096 . 43483) (\LITCHECK 43485 . 43899)) (46412
|
||||
70236 (COPYREADTABLE 46422 . 46620) (FIND-READTABLE 46622 . 46769) (IN-READTABLE 46771 . 46931) (
|
||||
ESCAPE 46933 . 47186) (GETBRK 47188 . 47326) (GETREADTABLE 47328 . 47464) (GETSEPR 47466 . 47604) (
|
||||
READMACROS 47606 . 47869) (READTABLEP 47871 . 48034) (READTABLEPROP 48036 . 53194) (RESETREADTABLE
|
||||
53196 . 57443) (SETBRK 57445 . 59055) (SETREADTABLE 59057 . 59245) (SETSEPR 59247 . 60789) (
|
||||
\GETREADSYNTAX 60791 . 63481) (\GTREADTABLE 63483 . 63708) (\GTREADTABLE1 63710 . 63966) (
|
||||
\ORIGREADTABLE 63968 . 65876) (\READCLASSTOCODE 65878 . 66329) (\SETMACROSYNTAX 66331 . 68126) (
|
||||
\SETREADSYNTAX 68128 . 69189) (\READTABLEP.DEFPRINT 69191 . 70234)) (83068 87521 (\ATBLSET 83078 .
|
||||
87519)) (87968 91406 (MAKE-READER-ENVIRONMENT 87978 . 89656) (EQUAL-READER-ENVIRONMENT 89658 . 90808)
|
||||
(SET-READER-ENVIRONMENT 90810 . 91404)))))
|
||||
(FILEMAP (NIL (17749 28901 (GETSYNTAX 17759 . 22590) (SETSYNTAX 22592 . 23665) (SYNTAXP 23667 . 26164)
|
||||
(\COPYSYNTAX 26166 . 26883) (\GETCHARCODE 26885 . 27173) (\SETFATSYNCODE 27175 . 28466) (
|
||||
\MAPCHARTABLE 28468 . 28899)) (28934 43900 (CONTROL 28944 . 29196) (COPYTERMTABLE 29198 . 29565) (
|
||||
DELETECONTROL 29567 . 32208) (GETDELETECONTROL 32210 . 33172) (ECHOCHAR 33174 . 34615) (ECHOCONTROL
|
||||
34617 . 35074) (ECHOMODE 35076 . 35322) (GETECHOMODE 35324 . 35488) (GETCONTROL 35490 . 35656) (
|
||||
GETTERMTABLE 35658 . 35725) (RAISE 35727 . 36153) (GETRAISE 36155 . 36317) (RESETTERMTABLE 36319 .
|
||||
37403) (SETTERMTABLE 37405 . 37639) (TERMTABLEP 37641 . 37802) (\GETTERMSYNTAX 37804 . 38075) (
|
||||
\GTTERMTABLE 38077 . 38413) (\ORIGTERMTABLE 38415 . 42025) (\SETTERMSYNTAX 42027 . 42662) (
|
||||
\TERMCLASSTOCODE 42664 . 43093) (\TERMCODETOCLASS 43095 . 43482) (\LITCHECK 43484 . 43898)) (46411
|
||||
70235 (COPYREADTABLE 46421 . 46619) (FIND-READTABLE 46621 . 46768) (IN-READTABLE 46770 . 46930) (
|
||||
ESCAPE 46932 . 47185) (GETBRK 47187 . 47325) (GETREADTABLE 47327 . 47463) (GETSEPR 47465 . 47603) (
|
||||
READMACROS 47605 . 47868) (READTABLEP 47870 . 48033) (READTABLEPROP 48035 . 53193) (RESETREADTABLE
|
||||
53195 . 57442) (SETBRK 57444 . 59054) (SETREADTABLE 59056 . 59244) (SETSEPR 59246 . 60788) (
|
||||
\GETREADSYNTAX 60790 . 63480) (\GTREADTABLE 63482 . 63707) (\GTREADTABLE1 63709 . 63965) (
|
||||
\ORIGREADTABLE 63967 . 65875) (\READCLASSTOCODE 65877 . 66328) (\SETMACROSYNTAX 66330 . 68125) (
|
||||
\SETREADSYNTAX 68127 . 69188) (\READTABLEP.DEFPRINT 69190 . 70233)) (83067 87520 (\ATBLSET 83077 .
|
||||
87518)) (87967 91384 (MAKE-READER-ENVIRONMENT 87977 . 89634) (EQUAL-READER-ENVIRONMENT 89636 . 90786)
|
||||
(SET-READER-ENVIRONMENT 90788 . 91382)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "27-Nov-2021 13:30:46"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3| 53235
|
||||
(FILECREATED "20-Jan-2022 09:16:52"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;4| 53233
|
||||
|
||||
|previous| |date:| " 3-Apr-91 15:11:53"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;2|)
|
||||
:PREVIOUS-DATE "27-Nov-2021 13:30:46"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3|)
|
||||
|
||||
|
||||
; Copyright (c) 1985-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
@@ -955,48 +955,51 @@
|
||||
(PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (5167 14142 (OPEN 5167 . 14142)) (14144 15070 (CL:CLOSE 14144 . 15070)) (15072 15150 (
|
||||
CL:STREAM-EXTERNAL-FORMAT 15072 . 15150)) (15152 15219 (CL:STREAM-ELEMENT-TYPE 15152 . 15219)) (15221
|
||||
15455 (CL:INPUT-STREAM-P 15221 . 15455)) (15457 15693 (CL:OUTPUT-STREAM-P 15457 . 15693)) (15695 15832
|
||||
(XCL:OPEN-STREAM-P 15695 . 15832)) (15834 15901 (FILE-STREAM-POSITION 15834 . 15901)) (15953 17296 (
|
||||
CL:MAKE-SYNONYM-STREAM 15953 . 17296)) (17298 17387 (XCL:SYNONYM-STREAM-P 17298 . 17387)) (17389 17527
|
||||
(XCL:SYNONYM-STREAM-SYMBOL 17389 . 17527)) (17529 17807 (XCL:FOLLOW-SYNONYM-STREAMS 17529 . 17807)) (
|
||||
17809 18568 (CL:MAKE-BROADCAST-STREAM 17809 . 18568)) (18570 18713 (XCL:BROADCAST-STREAM-P 18570 .
|
||||
18713)) (18715 18930 (XCL:BROADCAST-STREAM-STREAMS 18715 . 18930)) (18932 19617 (
|
||||
CL:MAKE-CONCATENATED-STREAM 18932 . 19617)) (19619 19718 (XCL:CONCATENATED-STREAM-P 19619 . 19718)) (
|
||||
19720 19933 (XCL:CONCATENATED-STREAM-STREAMS 19720 . 19933)) (19935 21519 (CL:MAKE-TWO-WAY-STREAM
|
||||
19935 . 21519)) (21521 21658 (XCL:TWO-WAY-STREAM-P 21521 . 21658)) (21660 21805 (
|
||||
XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21660 . 21805)) (21807 21951 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21807
|
||||
. 21951)) (21953 23503 (CL:MAKE-ECHO-STREAM 21953 . 23503)) (23505 23634 (XCL:ECHO-STREAM-P 23505 .
|
||||
23634)) (23636 23774 (XCL:ECHO-STREAM-INPUT-STREAM 23636 . 23774)) (23776 23915 (
|
||||
XCL:ECHO-STREAM-OUTPUT-STREAM 23776 . 23915)) (23917 24644 (CL:MAKE-STRING-INPUT-STREAM 23917 . 24644)
|
||||
) (24646 25139 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24646 . 25139)) (25141 25301 (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS 25141 . 25301)) (28348 29874 (MAKE-FILL-POINTER-OUTPUT-STREAM
|
||||
28348 . 29874)) (29876 30597 (CL:GET-OUTPUT-STREAM-STRING 29876 . 30597)) (30599 31078 (
|
||||
\\STRING-STREAM-OUTCHARFN 30599 . 31078)) (31080 32935 (\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31080 .
|
||||
32935)) (32964 33046 (%NEW-FILE 32964 . 33046)) (33048 33193 (PREDICT-NAME 33048 . 33193)) (33434
|
||||
34622 (%BROADCAST-STREAM-DEVICE-BOUT 33444 . 33667) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33669 . 34120)
|
||||
(%BROADCAST-STREAM-DEVICE-CLOSEFILE 34122 . 34361) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34363 .
|
||||
34620)) (34624 34951 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34624 . 34951)) (34952 37011 (
|
||||
%CONCATENATED-STREAM-DEVICE-BIN 34962 . 35367) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35369 . 35682) (
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP 35684 . 36048) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36050 . 36525) (
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36527 . 37009)) (37013 37344 (
|
||||
%CONCATENATED-STREAM-DEVICE-CHARSETFN 37013 . 37344)) (37345 37564 (%ECHO-STREAM-DEVICE-BIN 37355 .
|
||||
37562)) (37566 37791 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37566 . 37791)) (37792 41137 (
|
||||
%SYNONYM-STREAM-DEVICE-BIN 37802 . 37990) (%SYNONYM-STREAM-DEVICE-BOUT 37992 . 38193) (
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN 38195 . 38902) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38904 . 39488) (
|
||||
%SYNONYM-STREAM-DEVICE-EOFP 39490 . 39681) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39683 . 39921) (
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO 39923 . 40160) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40162 . 40385) (
|
||||
%SYNONYM-STREAM-DEVICE-READP 40387 . 40498) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40500 . 40646) (
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO 40648 . 40897) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40899 . 41135)) (
|
||||
41138 45463 (%TWO-WAY-STREAM-DEVICE-BIN 41148 . 41321) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41323 .
|
||||
41514) (%TWO-WAY-STREAM-DEVICE-BOUT 41516 . 41688) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41690 . 41880)
|
||||
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41882 . 42744) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42746 . 44169) (
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP 44171 . 44347) (%TWO-WAY-STREAM-DEVICE-READP 44349 . 44542) (
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44544 . 44680) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44682 . 44911) (
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN 44913 . 45126) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45128 . 45461)) (45465
|
||||
45690 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45465 . 45690)) (45692 45811 (
|
||||
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45692 . 45811)) (46051 46290 (%SYNONYM-STREAM-DEVICE-GET-STREAM
|
||||
46061 . 46288)) (46521 46997 (%INITIALIZE-STANDARD-STREAMS 46521 . 46997)) (46998 52961 (
|
||||
%INITIALIZE-CLSTREAM-TYPES 47008 . 52959)))))
|
||||
(FILEMAP (NIL (5165 14140 (OPEN 5165 . 14140)) (14142 15068 (CL:CLOSE 14142 . 15068)) (15070 15148 (
|
||||
CL:STREAM-EXTERNAL-FORMAT 15070 . 15148)) (15150 15217 (CL:STREAM-ELEMENT-TYPE 15150 . 15217)) (15219
|
||||
15453 (CL:INPUT-STREAM-P 15219 . 15453)) (15455 15691 (CL:OUTPUT-STREAM-P 15455 . 15691)) (15693 15830
|
||||
(XCL:OPEN-STREAM-P 15693 . 15830)) (15832 15899 (FILE-STREAM-POSITION 15832 . 15899)) (15951 17294 (
|
||||
CL:MAKE-SYNONYM-STREAM 15951 . 17294)) (17296 17385 (XCL:SYNONYM-STREAM-P 17296 . 17385)) (17387 17525
|
||||
(XCL:SYNONYM-STREAM-SYMBOL 17387 . 17525)) (17527 17805 (XCL:FOLLOW-SYNONYM-STREAMS 17527 . 17805)) (
|
||||
17807 18566 (CL:MAKE-BROADCAST-STREAM 17807 . 18566)) (18568 18711 (XCL:BROADCAST-STREAM-P 18568 .
|
||||
18711)) (18713 18928 (XCL:BROADCAST-STREAM-STREAMS 18713 . 18928)) (18930 19615 (
|
||||
CL:MAKE-CONCATENATED-STREAM 18930 . 19615)) (19617 19716 (XCL:CONCATENATED-STREAM-P 19617 . 19716)) (
|
||||
19718 19931 (XCL:CONCATENATED-STREAM-STREAMS 19718 . 19931)) (19933 21517 (CL:MAKE-TWO-WAY-STREAM
|
||||
19933 . 21517)) (21519 21656 (XCL:TWO-WAY-STREAM-P 21519 . 21656)) (21658 21803 (
|
||||
XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21658 . 21803)) (21805 21949 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21805
|
||||
. 21949)) (21951 23501 (CL:MAKE-ECHO-STREAM 21951 . 23501)) (23503 23632 (XCL:ECHO-STREAM-P 23503 .
|
||||
23632)) (23634 23772 (XCL:ECHO-STREAM-INPUT-STREAM 23634 . 23772)) (23774 23913 (
|
||||
XCL:ECHO-STREAM-OUTPUT-STREAM 23774 . 23913)) (23915 24642 (CL:MAKE-STRING-INPUT-STREAM 23915 . 24642)
|
||||
) (24644 25137 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24644 . 25137)) (25139 25299 (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS 25139 . 25299)) (25301 25731 (CL:WITH-OPEN-STREAM 25301 . 25731))
|
||||
(25733 26962 (CL:WITH-INPUT-FROM-STRING 25733 . 26962)) (26964 27466 (CL:WITH-OUTPUT-TO-STRING 26964
|
||||
. 27466)) (27468 28122 (CL:WITH-OPEN-FILE 27468 . 28122)) (28346 29872 (
|
||||
MAKE-FILL-POINTER-OUTPUT-STREAM 28346 . 29872)) (29874 30595 (CL:GET-OUTPUT-STREAM-STRING 29874 .
|
||||
30595)) (30597 31076 (\\STRING-STREAM-OUTCHARFN 30597 . 31076)) (31078 32933 (
|
||||
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31078 . 32933)) (32962 33044 (%NEW-FILE 32962 . 33044)) (33046
|
||||
33191 (PREDICT-NAME 33046 . 33191)) (33227 33378 (INTERLISP-ACCESS 33227 . 33378)) (33432 34620 (
|
||||
%BROADCAST-STREAM-DEVICE-BOUT 33442 . 33665) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33667 . 34118) (
|
||||
%BROADCAST-STREAM-DEVICE-CLOSEFILE 34120 . 34359) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34361 . 34618)
|
||||
) (34622 34949 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34622 . 34949)) (34950 37009 (
|
||||
%CONCATENATED-STREAM-DEVICE-BIN 34960 . 35365) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35367 . 35680) (
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP 35682 . 36046) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36048 . 36523) (
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36525 . 37007)) (37011 37342 (
|
||||
%CONCATENATED-STREAM-DEVICE-CHARSETFN 37011 . 37342)) (37343 37562 (%ECHO-STREAM-DEVICE-BIN 37353 .
|
||||
37560)) (37564 37789 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37564 . 37789)) (37790 41135 (
|
||||
%SYNONYM-STREAM-DEVICE-BIN 37800 . 37988) (%SYNONYM-STREAM-DEVICE-BOUT 37990 . 38191) (
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN 38193 . 38900) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38902 . 39486) (
|
||||
%SYNONYM-STREAM-DEVICE-EOFP 39488 . 39679) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39681 . 39919) (
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO 39921 . 40158) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40160 . 40383) (
|
||||
%SYNONYM-STREAM-DEVICE-READP 40385 . 40496) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40498 . 40644) (
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO 40646 . 40895) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40897 . 41133)) (
|
||||
41136 45461 (%TWO-WAY-STREAM-DEVICE-BIN 41146 . 41319) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41321 .
|
||||
41512) (%TWO-WAY-STREAM-DEVICE-BOUT 41514 . 41686) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41688 . 41878)
|
||||
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41880 . 42742) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42744 . 44167) (
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP 44169 . 44345) (%TWO-WAY-STREAM-DEVICE-READP 44347 . 44540) (
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44542 . 44678) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44680 . 44909) (
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN 44911 . 45124) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45126 . 45459)) (45463
|
||||
45688 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45463 . 45688)) (45690 45809 (
|
||||
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45690 . 45809)) (46049 46288 (%SYNONYM-STREAM-DEVICE-GET-STREAM
|
||||
46059 . 46286)) (46519 46995 (%INITIALIZE-STANDARD-STREAMS 46519 . 46995)) (46996 52959 (
|
||||
%INITIALIZE-CLSTREAM-TYPES 47006 . 52957)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,37 +1,139 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(filecreated " 8-Jun-90 16:41:26" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;4| 4326
|
||||
|
||||
|changes| |to:| (functions cl:directory cl:user-homedir-pathname)
|
||||
(FILECREATED "23-Jan-2022 12:32:16"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;4| 6055
|
||||
|
||||
|previous| |date:| " 4-Jun-90 14:56:58" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLFILESYS.;3|)
|
||||
:CHANGES-TO (FUNCTIONS CL:DIRECTORY)
|
||||
|
||||
:PREVIOUS-DATE "22-Jan-2022 09:26:49"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLFILESYS.;3|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
|
||||
|
||||
(prettycomprint cmlfilesyscoms)
|
||||
(PRETTYCOMPRINT CMLFILESYSCOMS)
|
||||
|
||||
(rpaqq cmlfilesyscoms ((functions cl:directory cl:file-author cl:file-length cl:file-position cl:user-homedir-pathname cl:file-write-date) (functions cl:probe-file cl:rename-file cl:delete-file) (prop filetype cmlfilesys)))
|
||||
(RPAQQ CMLFILESYSCOMS ((FUNCTIONS CL:DIRECTORY CL:FILE-AUTHOR CL:FILE-LENGTH CL:FILE-POSITION
|
||||
CL:USER-HOMEDIR-PATHNAME CL:FILE-WRITE-DATE)
|
||||
(FUNCTIONS CL:PROBE-FILE CL:RENAME-FILE CL:DELETE-FILE)
|
||||
(PROP FILETYPE CMLFILESYS)))
|
||||
|
||||
(cl:defun cl:directory (pathname) (let (generator file) (declare (cl:special generator)) (resetlst (|if| (eql \\machinetype \\maiko) |then| (resetsave nil (quote (and resetstate (\\ufs.abort.cl-directory))))) (cl:setq generator (\\generatefiles (directory.fill.pattern (cl:namestring pathname)) nil (quote (sort resetlst)))) (|while| (setq file (\\generatenextfile generator)) |collect| (pathname file)))))
|
||||
(CL:DEFUN CL:DIRECTORY (PATHNAME &KEY CL::DEFAULTEXT CL::DEFAULTVERS)
|
||||
(* \; "Edited 23-Jan-2022 12:32 by rmk")
|
||||
(* \; "Edited 22-Jan-2022 09:26 by rmk")
|
||||
(LET (GENERATOR FILE)
|
||||
(DECLARE (CL:SPECIAL GENERATOR))
|
||||
(RESETLST
|
||||
(CL:WHEN (EQL \\MACHINETYPE \\MAIKO)
|
||||
(RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
|
||||
(CL:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (CL:NAMESTRING PATHNAME)
|
||||
CL::DEFAULTEXT CL::DEFAULTVERS)
|
||||
NIL
|
||||
'(SORT RESETLST)))
|
||||
(|while| (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect| (PATHNAME FILE)))))
|
||||
|
||||
(cl:defun cl:file-author (cl::file) (* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.") (let ((cl::author (getfileinfo cl::file (quote author)))) (cl:if cl::author (coerce cl::author (quote cl:simple-string)) nil)))
|
||||
(CL:DEFUN CL:FILE-AUTHOR (CL::FILE)
|
||||
|
||||
(cl:defun cl:file-length (file-stream) (|if| (and (streamp file-stream) (openp file-stream)) |then| (geteofptr file-stream)))
|
||||
(* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.")
|
||||
|
||||
(cl:defun cl:file-position (cl::file-stream &optional (cl:position nil cl::positionp)) (cl:unless (streamp cl::file-stream) (\\illegal.arg cl::file-stream)) (cl:if cl::positionp (cl:if (randaccessp cl::file-stream) (progn (setfileptr cl::file-stream (case cl:position (:start 0) (:end (geteofptr cl::file-stream)) (t cl:position))) t) nil) (getfileptr cl::file-stream)))
|
||||
(LET ((CL::AUTHOR (GETFILEINFO CL::FILE 'AUTHOR)))
|
||||
(CL:IF CL::AUTHOR
|
||||
(COERCE CL::AUTHOR 'CL:SIMPLE-STRING)
|
||||
NIL)))
|
||||
|
||||
(cl:defun cl:user-homedir-pathname (&optional host) (declare (globalvars loginhost/dir *default-pathname-defaults*)) (cl:if (machinetype (quote maiko)) (cl:if (and host (cl:string-not-equal (string host) (unix-getparm "HOSTNAME"))) nil (cl:make-pathname :host :dsk :directory (unpackfilename.string (unix-getenv "HOME") (quote directory) (quote return)))) (pathname (or loginhost/dir *default-pathname-defaults*))))
|
||||
(CL:DEFUN CL:FILE-LENGTH (FILE-STREAM)
|
||||
(|if| (AND (STREAMP FILE-STREAM)
|
||||
(OPENP FILE-STREAM))
|
||||
|then| (GETEOFPTR FILE-STREAM)))
|
||||
|
||||
(cl:defun cl:file-write-date (file) (* |;;| "Return file's creation date, or NIL if it doesn't exist.") (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time") (let ((tn (cl:probe-file file))) (cl:when tn (%convert-internal-time-to-clut (getfileinfo tn (quote icreationdate))))))
|
||||
(CL:DEFUN CL:FILE-POSITION (CL::FILE-STREAM &OPTIONAL (CL:POSITION NIL CL::POSITIONP))
|
||||
(CL:UNLESS (STREAMP CL::FILE-STREAM)
|
||||
(\\ILLEGAL.ARG CL::FILE-STREAM))
|
||||
(CL:IF CL::POSITIONP
|
||||
(CL:IF (RANDACCESSP CL::FILE-STREAM)
|
||||
(PROGN (SETFILEPTR CL::FILE-STREAM (CASE CL:POSITION
|
||||
(:START 0)
|
||||
(:END (GETEOFPTR CL::FILE-STREAM))
|
||||
(T CL:POSITION)))
|
||||
T)
|
||||
NIL)
|
||||
(GETFILEPTR CL::FILE-STREAM)))
|
||||
|
||||
(cl:defun cl:probe-file (file) (* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.") (if (streamp file) then (if (openp file) then (pathname (fetch (stream fullname) of file)) else (let ((namestring-if-exists (infilep (fetch (stream fullname) of file)))) (and namestring-if-exists (pathname namestring-if-exists)))) else (let ((infilep (\\getfilename file (quote old)))) (if infilep then (pathname infilep) else nil))))
|
||||
(CL:DEFUN CL:USER-HOMEDIR-PATHNAME (&OPTIONAL HOST)
|
||||
(DECLARE (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
|
||||
(CL:IF (MACHINETYPE 'MAIKO)
|
||||
(CL:IF (AND HOST (CL:STRING-NOT-EQUAL (STRING HOST)
|
||||
(UNIX-GETPARM "HOSTNAME")))
|
||||
NIL
|
||||
(CL:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME")
|
||||
'DIRECTORY
|
||||
'RETURN)))
|
||||
(PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
|
||||
|
||||
(cl:defun cl:rename-file (file new-name) (* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.") (let ((old-pathname (pathname file)) (cl::new-fullname)) (if (streamp file) then (if (openp file) then (cl:error "Renaming open streams is not supported: ~S" file) else (setq cl::new-fullname (renamefile (setq file (fetch (stream fullname) of file)) new-name))) else (setq cl::new-fullname (renamefile file new-name))) (if cl::new-fullname then (cl:values (cl:merge-pathnames new-name file) old-pathname (pathname cl::new-fullname)) else (cl:error "Rename failed"))))
|
||||
(CL:DEFUN CL:FILE-WRITE-DATE (FILE)
|
||||
|
||||
(cl:defun cl:delete-file (file) (* * "Delete the specified file.") (let ((tn (cl:probe-file file))) (cl:when (streamp file) (cl:close file :abort t)) (cl:if tn (let ((ns (interlisp-namestring tn))) (cl:unless (delfile ns) (cl:error "Could not delete the file ~S" file))) (cl:unless (streamp file) (cl:error "File to be deleted does not exist: ~S" file)))) t)
|
||||
(* |;;| "Return file's creation date, or NIL if it doesn't exist.")
|
||||
|
||||
(putprops cmlfilesys filetype cl:compile-file)
|
||||
(putprops cmlfilesys copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil)))
|
||||
stop
|
||||
(* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time")
|
||||
|
||||
(LET ((TN (CL:PROBE-FILE FILE)))
|
||||
(CL:WHEN TN
|
||||
(%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE)))))
|
||||
|
||||
(CL:DEFUN CL:PROBE-FILE (FILE)
|
||||
|
||||
(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.")
|
||||
|
||||
(IF (STREAMP FILE)
|
||||
THEN (IF (OPENP FILE)
|
||||
THEN (PATHNAME (FETCH (STREAM FULLNAME) OF FILE))
|
||||
ELSE (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH (STREAM FULLNAME) OF FILE))))
|
||||
(AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS))))
|
||||
ELSE (LET ((INFILEP (\\GETFILENAME FILE 'OLD)))
|
||||
(IF INFILEP
|
||||
THEN (PATHNAME INFILEP)
|
||||
ELSE NIL))))
|
||||
|
||||
(CL:DEFUN CL:RENAME-FILE (FILE NEW-NAME)
|
||||
|
||||
(* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.")
|
||||
|
||||
(LET ((OLD-PATHNAME (PATHNAME FILE))
|
||||
(CL::NEW-FULLNAME))
|
||||
(IF (STREAMP FILE)
|
||||
THEN (IF (OPENP FILE)
|
||||
THEN (CL:ERROR "Renaming open streams is not supported: ~S" FILE)
|
||||
ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE (SETQ FILE (FETCH (STREAM FULLNAME)
|
||||
OF FILE))
|
||||
NEW-NAME)))
|
||||
ELSE (SETQ CL::NEW-FULLNAME (RENAMEFILE FILE NEW-NAME)))
|
||||
(IF CL::NEW-FULLNAME
|
||||
THEN (CL:VALUES (CL:MERGE-PATHNAMES NEW-NAME FILE)
|
||||
OLD-PATHNAME
|
||||
(PATHNAME CL::NEW-FULLNAME))
|
||||
ELSE (CL:ERROR "Rename failed"))))
|
||||
|
||||
(CL:DEFUN CL:DELETE-FILE (FILE)
|
||||
|
||||
(* * "Delete the specified file.")
|
||||
|
||||
(LET ((TN (CL:PROBE-FILE FILE)))
|
||||
(CL:WHEN (STREAMP FILE)
|
||||
(CL:CLOSE FILE :ABORT T))
|
||||
(CL:IF TN
|
||||
(LET ((NS (INTERLISP-NAMESTRING TN)))
|
||||
(CL:UNLESS (DELFILE NS)
|
||||
(CL:ERROR "Could not delete the file ~S" FILE)))
|
||||
(CL:UNLESS (STREAMP FILE)
|
||||
(CL:ERROR "File to be deleted does not exist: ~S" FILE))))
|
||||
T)
|
||||
|
||||
(PUTPROPS CMLFILESYS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (751 1642 (CL:DIRECTORY 751 . 1642)) (1644 1950 (CL:FILE-AUTHOR 1644 . 1950)) (1952 2113
|
||||
(CL:FILE-LENGTH 1952 . 2113)) (2115 2709 (CL:FILE-POSITION 2115 . 2709)) (2711 3302 (
|
||||
CL:USER-HOMEDIR-PATHNAME 2711 . 3302)) (3304 3662 (CL:FILE-WRITE-DATE 3304 . 3662)) (3664 4329 (
|
||||
CL:PROBE-FILE 3664 . 4329)) (4331 5387 (CL:RENAME-FILE 4331 . 5387)) (5389 5894 (CL:DELETE-FILE 5389
|
||||
. 5894)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "28-Sep-90 15:14:19" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPATHNAME.;9| 42057
|
||||
|
||||
changes to%: (FNS CL:MAKE-PATHNAME)
|
||||
(FILECREATED "14-Jan-2022 11:40:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;2 41496
|
||||
|
||||
previous date%: "22-Aug-90 19:16:14" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPATHNAME.;8|)
|
||||
:PREVIOUS-DATE "28-Sep-90 15:14:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLPATHNAME.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1986-1988, 1990 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLPATHNAMECOMS)
|
||||
@@ -38,11 +39,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING))
|
||||
(FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES
|
||||
PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA
|
||||
CL:ENOUGH-NAMESTRING
|
||||
CL:MERGE-PATHNAMES
|
||||
CL:MAKE-PATHNAME])
|
||||
|
||||
|
||||
|
||||
@@ -68,20 +70,20 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL)
|
||||
`[if (NOT ,ONEFIELDFLG)
|
||||
then [SETQ ,VAL (CONS (COND
|
||||
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
|
||||
(T (OR (SUBSTRING ,FILE ,ST ,END)
|
||||
"")))
|
||||
(CONS ,NAM ,VAL]
|
||||
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
|
||||
(T (OR (SUBSTRING ,FILE ,ST ,END)
|
||||
"")))
|
||||
(CONS ,NAM ,VAL]
|
||||
elseif (EQMEMB ,NAM ,ONEFIELDFLG)
|
||||
then (RETURN (COND
|
||||
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
|
||||
(T (OR (SUBSTRING ,FILE ,ST ,END)
|
||||
""])
|
||||
(,PACKFLG (SUBATOM ,FILE ,ST ,END))
|
||||
(T (OR (SUBSTRING ,FILE ,ST ,END)
|
||||
""])
|
||||
|
||||
(CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-)
|
||||
(:PRINT-FUNCTION %%PRINT-PATHNAME)
|
||||
(:CONSTRUCTOR %%%%MAKE-PATHNAME)
|
||||
(:PREDICATE CL:PATHNAMEP))
|
||||
(:PRINT-FUNCTION %%PRINT-PATHNAME)
|
||||
(:CONSTRUCTOR %%%%MAKE-PATHNAME)
|
||||
(:PREDICATE CL:PATHNAMEP))
|
||||
HOST
|
||||
DEVICE
|
||||
DIRECTORY
|
||||
@@ -90,9 +92,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
VERSION)
|
||||
|
||||
(CL:DEFSTRUCT (DIRECTORY-COMPONENT (:CONC-NAME %%DIRECTORY-COMPONENT-)
|
||||
(:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT)
|
||||
(:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT)
|
||||
(:PREDICATE %%DIRECTORY-COMPONENT-P))
|
||||
(:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT)
|
||||
(:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT)
|
||||
(:PREDICATE %%DIRECTORY-COMPONENT-P))
|
||||
TYPE
|
||||
PATH)
|
||||
(DEFINEQ
|
||||
@@ -252,9 +254,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(* ;;; "Returns the full form of PATHNAME as a string.")
|
||||
|
||||
(CL:WHEN (AND (STREAMP PATHNAME)
|
||||
(NOT (fetch (STREAM NAMEDP) of PATHNAME)))
|
||||
(* ;
|
||||
"unnamed streams have the empty string as name.")
|
||||
(NOT (fetch (STREAM NAMEDP) of PATHNAME))) (* ;
|
||||
"unnamed streams have the empty string as name.")
|
||||
(CL:RETURN-FROM CL:NAMESTRING ""))
|
||||
[LET* ((PATHNAME (PATHNAME PATHNAME))
|
||||
(CL::HOST (%%PATHNAME-HOST PATHNAME))
|
||||
@@ -306,8 +307,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(T CL::VERSION))])])
|
||||
|
||||
(CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0)
|
||||
END
|
||||
(JUNK-ALLOWED NIL))
|
||||
END
|
||||
(JUNK-ALLOWED NIL))
|
||||
|
||||
(* ;;; "Parses a string representation of a pathname into a pathname. For details on the other silly arguments see the manual. NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything) It also ignores Host and defaults since we don't support non-standard hosts")
|
||||
|
||||
@@ -317,9 +318,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(PATHNAME (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:VALUES THING START)))
|
||||
(STREAM (CL:IF (XCL:SYNONYM-STREAM-P THING)
|
||||
[CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:PARSE-NAMESTRING (CL:SYMBOL-VALUE
|
||||
(
|
||||
(
|
||||
XCL:SYNONYM-STREAM-SYMBOL
|
||||
THING]
|
||||
THING]
|
||||
(SETQ THING (FILE-NAME THING))))
|
||||
(CL:SYMBOL (SETQ THING (CL:SYMBOL-NAME THING)))
|
||||
(T (CL:ERROR "This is of an inappropriate type for parse-namestring: ~S" THING)))
|
||||
@@ -339,8 +340,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(CL:DIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH
|
||||
(%%WILD-NAME CL:DIRECTORY)))
|
||||
(CL::SUBDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :SUBDIRECTORY
|
||||
:PATH (%%WILD-NAME CL::SUBDIRECTORY))
|
||||
)
|
||||
:PATH (%%WILD-NAME CL::SUBDIRECTORY)))
|
||||
(CL::RELATIVEDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE
|
||||
:PATH (%%WILD-NAME
|
||||
CL::RELATIVEDIRECTORY))
|
||||
@@ -374,8 +374,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
((OR (LITATOM FILE)
|
||||
(CL:STRINGP FILE)
|
||||
(NUMBERP FILE)))
|
||||
[(type? STREAM FILE) (* ;
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
[(type? STREAM FILE) (* ;
|
||||
"For streams, use full name. If anonymous, fake it")
|
||||
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
|
||||
(RETURN (CONS (SUB1 POS)
|
||||
(LIST 'NAME FILE]
|
||||
@@ -387,12 +387,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
FILE 2)
|
||||
0))))
|
||||
(%[ (* ;
|
||||
"some Xerox and Arpanet systems use `[' for host")
|
||||
"some Xerox and Arpanet systems use `[' for host")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
|
||||
FILE 2)
|
||||
0))))
|
||||
(%( (* ;
|
||||
"this is the standard for Xerox product file servers")
|
||||
"this is the standard for Xerox product file servers")
|
||||
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
|
||||
FILE 2)
|
||||
0))))
|
||||
@@ -426,7 +426,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
[COND
|
||||
((AND (EQ START POS)
|
||||
(NOT HOSTP)) (* ;
|
||||
"Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory")
|
||||
"Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory")
|
||||
(SETQ TYPE 'SUBDIRECTORY]
|
||||
-2)
|
||||
(PROGN -1)))
|
||||
@@ -435,12 +435,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(DREVERSE VAL]
|
||||
((SELCHARQ (NTHCHARCODE FILE POS)
|
||||
(/ (* ;
|
||||
"unix and the `xerox standard' use / for delimiter")
|
||||
"unix and the `xerox standard' use / for delimiter")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE /)
|
||||
FILE
|
||||
(ADD1 POS))))
|
||||
((< >) (* ;
|
||||
"Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
|
||||
"Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>")
|
||||
(SETQ TEM (LASTCHPOS (CHARCODE >)
|
||||
FILE
|
||||
(ADD1 POS))))
|
||||
@@ -456,7 +456,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
NAMELP
|
||||
(SELCHARQ CODE
|
||||
((%. ! ; NIL) (* ;
|
||||
"NAME and SUBDIRECTORY fields definitely terminated by now")
|
||||
"NAME and SUBDIRECTORY fields definitely terminated by now")
|
||||
(COND
|
||||
((AND (EQ CODE (CHARCODE %.))
|
||||
(NOT BEYONDNAME)
|
||||
@@ -475,29 +475,29 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(COND
|
||||
((AND (NULL CODE)
|
||||
(EQ POS TEM)) (* ;
|
||||
"Nothing follows the subdirectory; null name is NOT implied")
|
||||
"Nothing follows the subdirectory; null name is NOT implied")
|
||||
(RETURN (CONS (SUB1 POS)
|
||||
(DREVERSE VAL]
|
||||
(%%UNPACKFILE1 [COND
|
||||
((NOT BEYONDNAME)
|
||||
(COND
|
||||
((NEQ CODE (CHARCODE %.))
|
||||
(SETQQ BEYONDEXT ;)))
|
||||
(SETQQ BEYONDNAME NAME))
|
||||
((NOT BEYONDEXT)
|
||||
(SETQ BEYONDEXT (COND
|
||||
((NEQ CODE (CHARCODE %.))
|
||||
';)
|
||||
(T T)))
|
||||
'TYPE)
|
||||
(T (SELCHARQ (AND (EQ BEYONDEXT ';)
|
||||
(NTHCHARCODE FILE POS))
|
||||
(P 'PROTECTION)
|
||||
(A (add POS 1)
|
||||
'ACCOUNT)
|
||||
((T S)
|
||||
'TEMPORARY)
|
||||
'VERSION]
|
||||
((NOT BEYONDNAME)
|
||||
(COND
|
||||
((NEQ CODE (CHARCODE %.))
|
||||
(SETQQ BEYONDEXT ;)))
|
||||
(SETQQ BEYONDNAME NAME))
|
||||
((NOT BEYONDEXT)
|
||||
(SETQ BEYONDEXT (COND
|
||||
((NEQ CODE (CHARCODE %.))
|
||||
';)
|
||||
(T T)))
|
||||
'TYPE)
|
||||
(T (SELCHARQ (AND (EQ BEYONDEXT ';)
|
||||
(NTHCHARCODE FILE POS))
|
||||
(P 'PROTECTION)
|
||||
(A (add POS 1)
|
||||
'ACCOUNT)
|
||||
((T S)
|
||||
'TEMPORARY)
|
||||
'VERSION]
|
||||
POS
|
||||
(SUB1 TEM)
|
||||
FILE PACKFLG ONEFIELDFLG VAL)
|
||||
@@ -509,12 +509,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(%' (* ; "Quoter")
|
||||
(add TEM 1))
|
||||
((/ >) (* ;
|
||||
"Subdirectory terminating character")
|
||||
"Subdirectory terminating character")
|
||||
(COND
|
||||
((AND (NOT HOSTP)
|
||||
(NOT BEYONDNAME)
|
||||
DIRFLG) (* ;
|
||||
"Ok to treat this as a subdirectory")
|
||||
"Ok to treat this as a subdirectory")
|
||||
(SETQ SUBDIREND TEM))))
|
||||
NIL)
|
||||
NEXTCHAR
|
||||
@@ -527,14 +527,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
|
||||
[if (STREAMP PATHNAME)
|
||||
then (COND
|
||||
[(XCL:SYNONYM-STREAM-P PATHNAME)
|
||||
(CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (
|
||||
XCL:SYNONYM-STREAM-SYMBOL
|
||||
PATHNAME]
|
||||
((NOT (fetch (STREAM NAMEDP) of PATHNAME))
|
||||
(* ;
|
||||
"let's catch this case, rather than have the message 'The file %"%" does not exist' appear.")
|
||||
(CL:ERROR "The stream ~S has no corresponding named file." PATHNAME]
|
||||
[(XCL:SYNONYM-STREAM-P PATHNAME)
|
||||
(CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (XCL:SYNONYM-STREAM-SYMBOL
|
||||
PATHNAME]
|
||||
((NOT (fetch (STREAM NAMEDP) of PATHNAME)) (* ;
|
||||
"let's catch this case, rather than have the message 'The file %"%" does not exist' appear.")
|
||||
(CL:ERROR "The stream ~S has no corresponding named file." PATHNAME]
|
||||
(LET ((RESULT (CL:PROBE-FILE PATHNAME)))
|
||||
(CL:UNLESS RESULT
|
||||
(CL:ERROR "The file ~S does not exist." (CL:NAMESTRING PATHNAME)))
|
||||
@@ -571,8 +569,9 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS* \CONNECTED.DIRECTORY))
|
||||
(if (NOT (BOUNDP '\CONNECTED.DIRECTORY))
|
||||
then (SETQ \CONNECTED.DIRECTORY '{DSK}))
|
||||
[SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY
|
||||
(FILENAMEFIELD \CONNECTED.DIRECTORY 'HOST]
|
||||
[SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD
|
||||
\CONNECTED.DIRECTORY
|
||||
'HOST]
|
||||
(CL:SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*)
|
||||
:NEWEST)
|
||||
*DEFAULT-PATHNAME-DEFAULTS*)
|
||||
@@ -599,53 +598,52 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(DECLARE (IGNORE DIRFLG))
|
||||
[if ONEFIELDFLG
|
||||
then [AND (CL:CONSP ONEFIELDFLG)
|
||||
(SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG
|
||||
'(HOST DEVICE DIRECTORY NAME EXTENSION VERSION]
|
||||
(LET [(RESULT (CASE ONEFIELDFLG
|
||||
(HOST (CL:PATHNAME-HOST FILE))
|
||||
(DEVICE (CL:PATHNAME-DEVICE FILE))
|
||||
(DIRECTORY (CL:PATHNAME-DIRECTORY FILE))
|
||||
(NAME (CL:PATHNAME-NAME FILE))
|
||||
(EXTENSION (CL:PATHNAME-TYPE FILE))
|
||||
(VERSION (CL:PATHNAME-VERSION FILE))
|
||||
(CL:OTHERWISE NIL))]
|
||||
(if ATOMFLG
|
||||
then (MKATOM RESULT)
|
||||
else RESULT))
|
||||
(SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG
|
||||
'(HOST DEVICE DIRECTORY NAME EXTENSION VERSION]
|
||||
(LET [(RESULT (CASE ONEFIELDFLG
|
||||
(HOST (CL:PATHNAME-HOST FILE))
|
||||
(DEVICE (CL:PATHNAME-DEVICE FILE))
|
||||
(DIRECTORY (CL:PATHNAME-DIRECTORY FILE))
|
||||
(NAME (CL:PATHNAME-NAME FILE))
|
||||
(EXTENSION (CL:PATHNAME-TYPE FILE))
|
||||
(VERSION (CL:PATHNAME-VERSION FILE))
|
||||
(CL:OTHERWISE NIL))]
|
||||
(if ATOMFLG
|
||||
then (MKATOM RESULT)
|
||||
else RESULT))
|
||||
else (LET ((COMPONENT))
|
||||
(APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE))
|
||||
then (LIST 'HOST (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)
|
||||
COMPONENT))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE))
|
||||
then (LIST 'DEVICE (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE))
|
||||
then (LIST 'DIRECTORY (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-NAME FILE))
|
||||
then (LIST 'NAME (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE))
|
||||
then (LIST 'EXTENSION (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE))
|
||||
then (LIST 'VERSION (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else (MKSTRING COMPONENT])
|
||||
(APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE))
|
||||
then (LIST 'HOST (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)
|
||||
COMPONENT))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE))
|
||||
then (LIST 'DEVICE (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE))
|
||||
then (LIST 'DIRECTORY (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-NAME FILE))
|
||||
then (LIST 'NAME (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE))
|
||||
then (LIST 'EXTENSION (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else COMPONENT)))
|
||||
(if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE))
|
||||
then (LIST 'VERSION (if ATOMFLG
|
||||
then (MKATOM COMPONENT)
|
||||
else (MKSTRING COMPONENT])
|
||||
|
||||
(CL:DEFUN CL:FILE-NAMESTRING (PATHNAME)
|
||||
(LET* ((*PRINT-BASE* 10)
|
||||
(*PRINT-RADIX* NIL)
|
||||
(PATH (PATHNAME PATHNAME))
|
||||
[RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING (
|
||||
%%PATHNAME-NAME
|
||||
PATH)))
|
||||
[RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING (%%PATHNAME-NAME
|
||||
PATH)))
|
||||
"."
|
||||
(MKSTRING (%%COMPONENT-STRING (%%PATHNAME-TYPE PATH]
|
||||
(VERSION (%%PATHNAME-VERSION PATH)))
|
||||
@@ -675,8 +673,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME
|
||||
%%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME)
|
||||
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME)
|
||||
)
|
||||
(PRETTYCOMPRINT CMLPATHNAMECOMS)
|
||||
|
||||
@@ -706,24 +703,33 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r
|
||||
(FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING))
|
||||
(FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA
|
||||
CL:ENOUGH-NAMESTRING
|
||||
CL:MERGE-PATHNAMES
|
||||
CL:MAKE-PATHNAME])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES
|
||||
PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME)
|
||||
(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME
|
||||
%%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME)
|
||||
)
|
||||
(PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3597 9368 (%%PRINT-PATHNAME 3607 . 3768) (CL:MAKE-PATHNAME 3770 . 8520) (
|
||||
%%PRINT-DIRECTORY-COMPONENT 8522 . 9366)) (10569 15893 (PATHNAME 10579 . 10771) (CL:MERGE-PATHNAMES
|
||||
10773 . 12859) (FILE-NAME 12861 . 13002) (CL:HOST-NAMESTRING 13004 . 13193) (CL:ENOUGH-NAMESTRING
|
||||
13195 . 15660) (%%NUMERIC-STRING-P 15662 . 15891)))))
|
||||
(FILEMAP (NIL (3743 9514 (%%PRINT-PATHNAME 3753 . 3914) (CL:MAKE-PATHNAME 3916 . 8666) (
|
||||
%%PRINT-DIRECTORY-COMPONENT 8668 . 9512)) (9516 9709 (CL:PATHNAME-HOST 9516 . 9709)) (9711 9910 (
|
||||
CL:PATHNAME-DEVICE 9711 . 9910)) (9912 10120 (CL:PATHNAME-DIRECTORY 9912 . 10120)) (10122 10315 (
|
||||
CL:PATHNAME-NAME 10122 . 10315)) (10317 10510 (CL:PATHNAME-TYPE 10317 . 10510)) (10512 10714 (
|
||||
CL:PATHNAME-VERSION 10512 . 10714)) (10715 16039 (PATHNAME 10725 . 10917) (CL:MERGE-PATHNAMES 10919 .
|
||||
13005) (FILE-NAME 13007 . 13148) (CL:HOST-NAMESTRING 13150 . 13339) (CL:ENOUGH-NAMESTRING 13341 .
|
||||
15806) (%%NUMERIC-STRING-P 15808 . 16037)) (16041 19794 (CL:NAMESTRING 16041 . 19794)) (19796 23267 (
|
||||
CL:PARSE-NAMESTRING 19796 . 23267)) (23269 31722 (PARSE-NAMESTRING1 23269 . 31722)) (31724 32727 (
|
||||
CL:TRUENAME 31724 . 32727)) (32729 32921 (%%MAKE-PATHNAME 32729 . 32921)) (32923 33560 (
|
||||
%%PATHNAME-EQUAL 32923 . 33560)) (33562 34019 (%%DIRECTORY-COMPONENT-EQUAL 33562 . 34019)) (34021
|
||||
34644 (%%INITIALIZE-DEFAULT-PATHNAME 34021 . 34644)) (34734 34901 (INTERLISP-NAMESTRING 34734 . 34901)
|
||||
) (34903 37796 (UNPACKPATHNAME.STRING 34903 . 37796)) (37798 39055 (CL:FILE-NAMESTRING 37798 . 39055))
|
||||
(39057 39255 (CL:DIRECTORY-NAMESTRING 39057 . 39255)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
177
sources/COREIO
177
sources/COREIO
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "22-Nov-2021 09:25:42" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;3 55023
|
||||
(FILECREATED "26-Jan-2022 10:18:51" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;15 56955
|
||||
|
||||
changes to%: (FNS \CORE.SETFILEINFO)
|
||||
:CHANGES-TO (VARS COREIOCOMS)
|
||||
|
||||
previous date%: " 4-Oct-2018 14:13:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;2)
|
||||
:PREVIOUS-DATE "18-Jan-2022 11:22:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;14)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -90,10 +90,34 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(RETURN (fetch IOFILEFULLNAME of INFOBLOCK])
|
||||
|
||||
(\CORE.DIRECTORYNAMEP
|
||||
[LAMBDA (DIRNAME DEV) (* ; "Edited 19-Feb-93 16:04 by jds")
|
||||
(LET [(DIR (UNPACKFILENAME.STRING DIRNAME 'DIRECTORY]
|
||||
(AND DIRNAME DIR (> (NCHARS DIR)
|
||||
0])
|
||||
[LAMBDA (DIRNAME DEV) (* ; "Edited 18-Jan-2022 11:17 by rmk")
|
||||
(* ; "Edited 10-Jan-2022 22:33 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Edited 9-Jan-2022 12:42 by rmk: Using the new FILEDIRCASEARRAY so that slashes and brackets match")
|
||||
|
||||
(* ;; "Edited 5-Jan-2022 15:03 by rmk: The previous definition didn't actually check to see if the directory existed. %"existed%" for COREIO means there is at least one file currently in that directory.")
|
||||
|
||||
(* ;; "Edited 19-Feb-93 16:04 by jds")
|
||||
|
||||
(CL:WHEN DIRNAME
|
||||
|
||||
(* ;; "The DIRNAME could be just {CORE}, which always is OK, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.")
|
||||
|
||||
(IF (EQ (CHARCODE })
|
||||
(NTHCHARCODE DIRNAME -1))
|
||||
ELSE (CL:UNLESS (MEMB (NTHCHARCODE DIRNAME -1)
|
||||
(CHARCODE (> /)))
|
||||
(SETQ DIRNAME (CONCAT DIRNAME ">")))
|
||||
|
||||
(* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)")
|
||||
|
||||
(FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY))
|
||||
FIRST (CL:UNLESS (EQ DIRPOS 1)
|
||||
(SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS)))
|
||||
IN (CDR (FETCH COREDIRECTORY OF DEV)) WHEN (STRPOS DIRNAME (CAR ENTRY)
|
||||
1 NIL T NIL FILEDIRCASEARRAY)
|
||||
DO (RETURN T))))])
|
||||
|
||||
(\CORE.FINDPAGE
|
||||
[LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32")
|
||||
@@ -351,28 +375,30 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(RETURN INFOBLOCK])
|
||||
|
||||
(\CORE.NAMESCAN
|
||||
[LAMBDA (NAME NAMELST CREATEFLG) (* ; "Edited 23-Oct-87 17:11 by bvm:")
|
||||
[LAMBDA (NAME NAMELST CREATEFLG)
|
||||
|
||||
(* ;; "Edited 11-Jan-2022 09:30 by rmk: Matching with FILEDIRCASEARRAY, for /")
|
||||
|
||||
(* ;; "Edited 23-Oct-87 17:11 by bvm:")
|
||||
|
||||
(COND
|
||||
((LISTP NAMELST)
|
||||
(bind NEWSEG NEXTNAME while [AND (CDR NAMELST)
|
||||
(COND
|
||||
((STRING-EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST)
|
||||
))
|
||||
NAME)
|
||||
(COND
|
||||
((STRING.EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST)))
|
||||
NAME FILEDIRCASEARRAY)
|
||||
(* ; "Found it")
|
||||
(RETURN (CADR NAMELST)))
|
||||
(T (UALPHORDER NEXTNAME NAME]
|
||||
do (* ;
|
||||
"Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME")
|
||||
(SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND
|
||||
((AND CREATEFLG (SETQ NEWSEG
|
||||
(
|
||||
\CORE.NAMESEGMENT
|
||||
NAME)))
|
||||
(RPLACD NAMELST
|
||||
(CONS NEWSEG
|
||||
(CDR NAMELST)))
|
||||
NEWSEG])
|
||||
(RETURN (CADR NAMELST)))
|
||||
(T (ALPHORDER NEXTNAME NAME FILEDIRCASEARRAY]
|
||||
do (* ;
|
||||
"Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME")
|
||||
(SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND
|
||||
((AND CREATEFLG (SETQ NEWSEG
|
||||
(\CORE.NAMESEGMENT
|
||||
NAME)))
|
||||
(RPLACD NAMELST (CONS NEWSEG
|
||||
(CDR NAMELST)))
|
||||
NEWSEG])
|
||||
|
||||
(\CORE.NAMESEGMENT
|
||||
[LAMBDA (NAME) (* rmk%: "24-FEB-84 21:14")
|
||||
@@ -612,35 +638,36 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
STREAM])
|
||||
|
||||
(\CORE.SETFILEINFO
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEV) (* ; "Edited 22-Nov-2021 09:25 by rmk:")
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEV)
|
||||
|
||||
(* ;; "Edited 3-Jan-2022 20:00 by rmk: fixed bug--coercing CREATIONDATE twice")
|
||||
(* ; "Edited 3-Jan-2022 19:59 by rmk")
|
||||
|
||||
(* ;; "Edited 22-Nov-2021 09:25 by rmk:")
|
||||
(* bvm%: "15-Jan-85 17:40")
|
||||
(PROG ((INFOBLOCK (\CORE.GETINFOBLOCK STREAM 'OLD DEV)))
|
||||
(SELECTQ ATTRIBUTE
|
||||
(CREATIONDATE (SETQ VALUE (OR (IDATE VALUE)
|
||||
(LISPERROR "ILLEGAL ARG" VALUE))))
|
||||
(ICREATIONDATE (OR (FIXP VALUE)
|
||||
(LISPERROR "NON-NUMERIC ARG" VALUE)))
|
||||
NIL)
|
||||
(RETURN (AND INFOBLOCK (SELECTQ ATTRIBUTE
|
||||
((TYPE FILETYPE)
|
||||
(replace IOFIBType of INFOBLOCK with VALUE))
|
||||
(EOL (replace COREEOLC of INFOBLOCK
|
||||
with (SELECTQ VALUE
|
||||
(CR CR.EOLC)
|
||||
(LF LF.EOLC)
|
||||
(CRLF CRLF.EOLC)
|
||||
(LISPERROR "ILLEGAL ARG" VALUE))))
|
||||
(CREATIONDATE (replace IOFIBCreationTime of INFOBLOCK
|
||||
with (IDATE VALUE)))
|
||||
(READDATE (replace IOFIBReadTime of INFOBLOCK
|
||||
with (IDATE VALUE)))
|
||||
(WRITEDATE (replace IOFIBWriteTime of INFOBLOCK
|
||||
with (IDATE VALUE)))
|
||||
(ICREATIONDATE (replace IOFIBCreationTime of INFOBLOCK
|
||||
with VALUE))
|
||||
(IREADDATE (replace IOFIBReadTime of INFOBLOCK with VALUE))
|
||||
(IWRITEDATE (replace IOFIBWriteTime of INFOBLOCK with VALUE))
|
||||
NIL])
|
||||
(LET ((INFOBLOCK (\CORE.GETINFOBLOCK STREAM 'OLD DEV)))
|
||||
(AND INFOBLOCK (SELECTQ ATTRIBUTE
|
||||
((TYPE FILETYPE)
|
||||
(replace IOFIBType of INFOBLOCK with VALUE))
|
||||
(EOL (replace COREEOLC of INFOBLOCK with (SELECTQ VALUE
|
||||
(CR CR.EOLC)
|
||||
(LF LF.EOLC)
|
||||
(CRLF CRLF.EOLC)
|
||||
(LISPERROR "ILLEGAL ARG"
|
||||
VALUE))))
|
||||
(CREATIONDATE (replace IOFIBCreationTime of INFOBLOCK
|
||||
with (OR (IDATE VALUE)
|
||||
(\ILLEGAL.ARG VALUE))))
|
||||
(READDATE (replace IOFIBReadTime of INFOBLOCK with (OR (IDATE VALUE)
|
||||
(\ILLEGAL.ARG
|
||||
VALUE))))
|
||||
(WRITEDATE (replace IOFIBWriteTime of INFOBLOCK
|
||||
with (OR (IDATE VALUE)
|
||||
(\ILLEGAL.ARG VALUE))))
|
||||
(ICREATIONDATE (replace IOFIBCreationTime of INFOBLOCK with VALUE))
|
||||
(IREADDATE (replace IOFIBReadTime of INFOBLOCK with VALUE))
|
||||
(IWRITEDATE (replace IOFIBWriteTime of INFOBLOCK with VALUE))
|
||||
NIL])
|
||||
|
||||
(\CORE.GETNEXTBUFFER
|
||||
[LAMBDA (STREAM WHATFOR NOERRORFLG) (* ; "Edited 17-Sep-90 13:22 by jds")
|
||||
@@ -709,7 +736,12 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(RETURN T])
|
||||
|
||||
(\CORE.UNPACKFILENAME
|
||||
[LAMBDA (NAME) (* ; "Edited 3-Nov-87 12:12 by bvm:")
|
||||
[LAMBDA (NAME) (* ; "Edited 10-Jan-2022 22:42 by rmk")
|
||||
|
||||
(* ;; "rmk; Convert / in ROOT to < or >")
|
||||
(* ; "Edited 10-Jan-2022 21:14 by rmk")
|
||||
|
||||
(* ;; "Edited 3-Nov-87 12:12 by bvm:")
|
||||
|
||||
(* ;; "Breaks up a file name atom into its fields which it sets freely in its caller")
|
||||
|
||||
@@ -728,6 +760,17 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(SETQ DOT SEMI)))
|
||||
(SETQ ROOT (OR (SUBSTRING NAME START (SUB1 DOT))
|
||||
""))
|
||||
(CL:WHEN (STRPOS "/" ROOT)
|
||||
|
||||
(* ;; "If ROOT has slashes, convert to < ..> ..>")
|
||||
|
||||
(SETQ ROOT (DSUBST (CHARCODE >)
|
||||
(CHARCODE /)
|
||||
(CHCON ROOT)))
|
||||
(CL:WHEN (EQ (CAR ROOT)
|
||||
(CHARCODE >))
|
||||
(RPLACA ROOT (CHARCODE <)))
|
||||
(SETQ ROOT (CONCATCODES ROOT)))
|
||||
(SETQ EXT (COND
|
||||
((< DOT (- SEMI 1))
|
||||
(SUBSTRING NAME (ADD1 DOT)
|
||||
@@ -954,16 +997,16 @@ Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
(PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1993 1999 2018))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1710 44229 (\CORE.CLOSEFILE 1720 . 2493) (\CORE.DELETEFILE 2495 . 4481) (
|
||||
\CORE.DIRECTORYNAMEP 4483 . 4744) (\CORE.FINDPAGE 4746 . 7975) (\CORE.GENERATEFILES 7977 . 10564) (
|
||||
\CORE.NEXTFILEFN 10566 . 11065) (\CORE.FILEINFOFN 11067 . 11296) (\CORE.GETFILEHANDLE 11298 . 13452) (
|
||||
\CORE.GETFILEINFO 13454 . 14417) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14419 . 15956) (\CORE.GETFILENAME
|
||||
15958 . 18247) (\CORE.GETINFOBLOCK 18249 . 20872) (\CORE.NAMESCAN 20874 . 22641) (\CORE.NAMESEGMENT
|
||||
22643 . 23080) (\CORE.OPENFILE 23082 . 26201) (\COREFILE.SETPARAMETERS 26203 . 28384) (
|
||||
\CORE.PACKFILENAME 28386 . 28781) (\CORE.RELEASEPAGES 28783 . 29384) (\CORE.SETFILEPTR 29386 . 30485)
|
||||
(\CORE.UPDATEOF 30487 . 32116) (\CORE.BACKFILEPTR 32118 . 34326) (\CORE.SETEOFPTR 34328 . 36197) (
|
||||
\CORE.SETACCESSTIME 36199 . 36824) (\CORE.SETFILEINFO 36826 . 39012) (\CORE.GETNEXTBUFFER 39014 .
|
||||
42970) (\CORE.UNPACKFILENAME 42972 . 44227)) (44230 47863 (COREDEVICE 44240 . 44411) (
|
||||
\CREATECOREDEVICE 44413 . 47861)) (47864 50165 (\NODIRCOREFDEV 47874 . 48471) (\NODIRCORE.OPENFILE
|
||||
48473 . 50163)))))
|
||||
(FILEMAP (NIL (1703 46161 (\CORE.CLOSEFILE 1713 . 2486) (\CORE.DELETEFILE 2488 . 4474) (
|
||||
\CORE.DIRECTORYNAMEP 4476 . 6157) (\CORE.FINDPAGE 6159 . 9388) (\CORE.GENERATEFILES 9390 . 11977) (
|
||||
\CORE.NEXTFILEFN 11979 . 12478) (\CORE.FILEINFOFN 12480 . 12709) (\CORE.GETFILEHANDLE 12711 . 14865) (
|
||||
\CORE.GETFILEINFO 14867 . 15830) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15832 . 17369) (\CORE.GETFILENAME
|
||||
17371 . 19660) (\CORE.GETINFOBLOCK 19662 . 22285) (\CORE.NAMESCAN 22287 . 23834) (\CORE.NAMESEGMENT
|
||||
23836 . 24273) (\CORE.OPENFILE 24275 . 27394) (\COREFILE.SETPARAMETERS 27396 . 29577) (
|
||||
\CORE.PACKFILENAME 29579 . 29974) (\CORE.RELEASEPAGES 29976 . 30577) (\CORE.SETFILEPTR 30579 . 31678)
|
||||
(\CORE.UPDATEOF 31680 . 33309) (\CORE.BACKFILEPTR 33311 . 35519) (\CORE.SETEOFPTR 35521 . 37390) (
|
||||
\CORE.SETACCESSTIME 37392 . 38017) (\CORE.SETFILEINFO 38019 . 40321) (\CORE.GETNEXTBUFFER 40323 .
|
||||
44279) (\CORE.UNPACKFILENAME 44281 . 46159)) (46162 49795 (COREDEVICE 46172 . 46343) (
|
||||
\CREATECOREDEVICE 46345 . 49793)) (49796 52097 (\NODIRCOREFDEV 49806 . 50403) (\NODIRCORE.OPENFILE
|
||||
50405 . 52095)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
117
sources/DMISC
117
sources/DMISC
@@ -1,13 +1,15 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "16-May-90 15:53:57" {DSK}<usr>local>lde>lispcore>sources>DMISC.;3 45292
|
||||
|
||||
changes to%: (VARS DMISCCOMS)
|
||||
(FILECREATED " 6-Jan-2022 19:08:15" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DMISC.;3 45512
|
||||
|
||||
previous date%: " 6-Apr-90 10:59:19" {DSK}<usr>local>lde>lispcore>sources>DMISC.;2)
|
||||
:CHANGES-TO (FNS FLASHWINDOW)
|
||||
|
||||
:PREVIOUS-DATE "16-May-90 15:53:57"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>DMISC.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1982-1990 by Venue & Xerox Corporation.
|
||||
The following program was created in 1982 but has not been published
|
||||
within the meaning of the copyright law, is furnished under license,
|
||||
and may not be used, copied and/or disclosed except in accordance
|
||||
@@ -41,7 +43,7 @@ with the terms of said license.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \PlayTimer))
|
||||
(INITRESOURCES \PlayTimer)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (* ;
|
||||
"Overrides definition in the shared MISC")
|
||||
"Overrides definition in the shared MISC")
|
||||
(P (MOVD 'RINGBELLS 'PRINTBELLS]
|
||||
[COMS (* ; "Changing display")
|
||||
(FNS DISPLAYDOWN SETDISPLAYHEIGHT VIDEORATE)
|
||||
@@ -68,7 +70,7 @@ with the terms of said license.
|
||||
\MISC1.UFN \MISC2.UFN \MISC3.UFN \MISC4.UFN \MISC5.UFN \MISC6.UFN \MISC7.UFN
|
||||
\MISC8.UFN \MISC10.UFN)
|
||||
(* ;
|
||||
"sub-functions of floating-point ufns")
|
||||
"sub-functions of floating-point ufns")
|
||||
(FNS \BLKFDIFF.UFN \BLKFPLUS.UFN \BLKFTIMES.UFN \BLKSEP.UFN \BLKPERM.UFN
|
||||
\BLKEXPONENT.UFN \BLKFLOATP2COMP.UFN \BLKSMALLP2FLOAT.UFN \BLKMAG.UFN
|
||||
\FLOATTOBYTE.UFN \BLKFMAX.UFN \BLKFMIN.UFN \BLKFABSMAX.UFN \BLKFABSMIN.UFN)
|
||||
@@ -79,7 +81,7 @@ with the terms of said license.
|
||||
(LOCALVARS . T)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA \DIRTYBACKGROUND])
|
||||
(LAMA])
|
||||
(DEFINEQ
|
||||
|
||||
(BACKSPACEDEL
|
||||
@@ -226,28 +228,35 @@ with the terms of said license.
|
||||
(FLASHWINDOW NIL N])
|
||||
|
||||
(FLASHWINDOW
|
||||
[LAMBDA (WIN? N FLASHINTERVAL SHADE) (* bvm%: "16-Jul-85 12:20")
|
||||
(* ; "This is an 'attention getting' action.")
|
||||
(* ;
|
||||
"rrb --- added shade argument so contrast of flash could be explored.")
|
||||
[LAMBDA (WIN? N FLASHINTERVAL SHADE) (* ; "Edited 6-Jan-2022 19:08 by rmk")
|
||||
(* bvm%: "16-Jul-85 12:20")
|
||||
(* ;
|
||||
"This is an 'attention getting' action.")
|
||||
(* ;
|
||||
"rrb --- added shade argument so contrast of flash could be explored.")
|
||||
(OR (FIXP N)
|
||||
(SETQ N 1))
|
||||
(OR (FIXP FLASHINTERVAL)
|
||||
(SETQ FLASHINTERVAL 200))
|
||||
[COND
|
||||
((WINDOWP WIN?)
|
||||
(SETQ WIN? (GETSTREAM WIN? 'OUTPUT]
|
||||
(WIN?
|
||||
(* ;;
|
||||
"RMK: GETSTREAM even if not a window. Catches T, other streams. But NIL still means whole screen")
|
||||
|
||||
(SETQ WIN? (GETSTREAM WIN? 'OUTPUT]
|
||||
(for I to N bind (WHOLEP _ (NOT (DISPLAYSTREAMP WIN?)))
|
||||
COLORP first [COND
|
||||
(WHOLEP (SETQ COLORP (NULL (VIDEOCOLOR]
|
||||
do (UNINTERRUPTABLY
|
||||
(* ;
|
||||
"Open-coded 'during' loops so that no one else can sneak in and steal cycles")
|
||||
(* ;
|
||||
"Open-coded 'during' loops so that no one else can sneak in and steal cycles")
|
||||
(COND
|
||||
[WHOLEP (* ; "Flash the whole screen")
|
||||
[WHOLEP (* ; "Flash the whole screen")
|
||||
(VIDEOCOLOR (PROG1 (VIDEOCOLOR COLORP)
|
||||
(DISMISS FLASHINTERVAL NIL T]
|
||||
(T (* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer")
|
||||
(T
|
||||
(* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer")
|
||||
|
||||
(INVERTW WIN? SHADE)
|
||||
(DISMISS FLASHINTERVAL NIL T)
|
||||
(INVERTW WIN? SHADE))))
|
||||
@@ -907,26 +916,26 @@ with the terms of said license.
|
||||
)
|
||||
|
||||
(RPAQQ RINGBELLS.L1 ((1000 . 1000)
|
||||
(800 . 1000)
|
||||
(600 . 1000)
|
||||
(500 . 1000)
|
||||
(400 . 1000)
|
||||
(NIL . 500)
|
||||
(440 . 1000)
|
||||
(484 . 1000)
|
||||
(540 . 1000)
|
||||
(600 . 1000)))
|
||||
(800 . 1000)
|
||||
(600 . 1000)
|
||||
(500 . 1000)
|
||||
(400 . 1000)
|
||||
(NIL . 500)
|
||||
(440 . 1000)
|
||||
(484 . 1000)
|
||||
(540 . 1000)
|
||||
(600 . 1000)))
|
||||
|
||||
(RPAQQ RINGBELLS.L2 ((2000 . 1000)
|
||||
(1600 . 1000)
|
||||
(1200 . 1000)
|
||||
(1000 . 1000)
|
||||
(800 . 1000)
|
||||
(NIL . 500)
|
||||
(880 . 1000)
|
||||
(968 . 1000)
|
||||
(1080 . 1000)
|
||||
(1188 . 1000)))
|
||||
(1600 . 1000)
|
||||
(1200 . 1000)
|
||||
(1000 . 1000)
|
||||
(800 . 1000)
|
||||
(NIL . 500)
|
||||
(880 . 1000)
|
||||
(968 . 1000)
|
||||
(1080 . 1000)
|
||||
(1188 . 1000)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
@@ -937,27 +946,27 @@ with the terms of said license.
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA \DIRTYBACKGROUND)
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS DMISC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4791 5494 (BACKSPACEDEL 4801 . 5492)) (5589 6022 (PERIODICALLYRECLAIM 5599 . 6020)) (
|
||||
6252 7943 (\DIRTYBACKGROUND 6262 . 6684) (\SAVEVMBACKGROUND 6686 . 7470) (COPYVM 7472 . 7941)) (8364
|
||||
9563 (SETTIME 8374 . 9561)) (9564 13243 (RINGBELLS 9574 . 10067) (FLASHWINDOW 10069 . 11645) (PLAYTUNE
|
||||
11647 . 13241)) (13505 19037 (DISPLAYDOWN 13515 . 13903) (SETDISPLAYHEIGHT 13905 . 16705) (VIDEORATE
|
||||
16707 . 19035)) (19461 20182 (DOAROUNDEXITFORMS 19471 . 20180)) (20385 22100 (REALMEMORYSIZE 20395 .
|
||||
20553) (LISPVERSION 20555 . 20708) (MICROCODEVERSION 20710 . 20868) (BCPLVERSION 20870 . 21023) (
|
||||
REQUIREVERSION 21025 . 22098)) (22137 26715 (APROPOS 22147 . 26163) (APROPRINT 26165 . 26713)) (26741
|
||||
30649 (READPRINTERPORT 26751 . 26892) (WRITEPRINTERPORT 26894 . 27049) (\READPRINTERPORT.UFN 27051 .
|
||||
27240) (\WRITEPRINTERPORT.UFN 27242 . 27440) (\MISC1.UFN 27442 . 27595) (\MISC2.UFN 27597 . 27835) (
|
||||
\MISC3.UFN 27837 . 28570) (\MISC4.UFN 28572 . 29122) (\MISC5.UFN 29124 . 29277) (\MISC6.UFN 29279 .
|
||||
29529) (\MISC7.UFN 29531 . 30016) (\MISC8.UFN 30018 . 30319) (\MISC10.UFN 30321 . 30647)) (30703 38152
|
||||
(\BLKFDIFF.UFN 30713 . 31278) (\BLKFPLUS.UFN 31280 . 31852) (\BLKFTIMES.UFN 31854 . 32429) (
|
||||
\BLKSEP.UFN 32431 . 33562) (\BLKPERM.UFN 33564 . 34033) (\BLKEXPONENT.UFN 34035 . 34445) (
|
||||
\BLKFLOATP2COMP.UFN 34447 . 35031) (\BLKSMALLP2FLOAT.UFN 35033 . 35392) (\BLKMAG.UFN 35394 . 36045) (
|
||||
\FLOATTOBYTE.UFN 36047 . 36626) (\BLKFMAX.UFN 36628 . 37020) (\BLKFMIN.UFN 37022 . 37411) (
|
||||
\BLKFABSMAX.UFN 37413 . 37782) (\BLKFABSMIN.UFN 37784 . 38150)) (38192 40010 (\P-MISC2.UFN 38202 .
|
||||
38443) (\LINES-EQUAL-P 38445 . 38829) (\GET-NEXT-RUN 38831 . 40008)) (40011 44190 (IBLT1 40021 . 42023
|
||||
) (IBLT2 42025 . 44188)))))
|
||||
(FILEMAP (NIL (4747 5450 (BACKSPACEDEL 4757 . 5448)) (5545 5978 (PERIODICALLYRECLAIM 5555 . 5976)) (
|
||||
6208 7899 (\DIRTYBACKGROUND 6218 . 6640) (\SAVEVMBACKGROUND 6642 . 7426) (COPYVM 7428 . 7897)) (8320
|
||||
9519 (SETTIME 8330 . 9517)) (9520 13551 (RINGBELLS 9530 . 10023) (FLASHWINDOW 10025 . 11953) (PLAYTUNE
|
||||
11955 . 13549)) (13813 19345 (DISPLAYDOWN 13823 . 14211) (SETDISPLAYHEIGHT 14213 . 17013) (VIDEORATE
|
||||
17015 . 19343)) (19769 20490 (DOAROUNDEXITFORMS 19779 . 20488)) (20693 22408 (REALMEMORYSIZE 20703 .
|
||||
20861) (LISPVERSION 20863 . 21016) (MICROCODEVERSION 21018 . 21176) (BCPLVERSION 21178 . 21331) (
|
||||
REQUIREVERSION 21333 . 22406)) (22445 27023 (APROPOS 22455 . 26471) (APROPRINT 26473 . 27021)) (27049
|
||||
30957 (READPRINTERPORT 27059 . 27200) (WRITEPRINTERPORT 27202 . 27357) (\READPRINTERPORT.UFN 27359 .
|
||||
27548) (\WRITEPRINTERPORT.UFN 27550 . 27748) (\MISC1.UFN 27750 . 27903) (\MISC2.UFN 27905 . 28143) (
|
||||
\MISC3.UFN 28145 . 28878) (\MISC4.UFN 28880 . 29430) (\MISC5.UFN 29432 . 29585) (\MISC6.UFN 29587 .
|
||||
29837) (\MISC7.UFN 29839 . 30324) (\MISC8.UFN 30326 . 30627) (\MISC10.UFN 30629 . 30955)) (31011 38460
|
||||
(\BLKFDIFF.UFN 31021 . 31586) (\BLKFPLUS.UFN 31588 . 32160) (\BLKFTIMES.UFN 32162 . 32737) (
|
||||
\BLKSEP.UFN 32739 . 33870) (\BLKPERM.UFN 33872 . 34341) (\BLKEXPONENT.UFN 34343 . 34753) (
|
||||
\BLKFLOATP2COMP.UFN 34755 . 35339) (\BLKSMALLP2FLOAT.UFN 35341 . 35700) (\BLKMAG.UFN 35702 . 36353) (
|
||||
\FLOATTOBYTE.UFN 36355 . 36934) (\BLKFMAX.UFN 36936 . 37328) (\BLKFMIN.UFN 37330 . 37719) (
|
||||
\BLKFABSMAX.UFN 37721 . 38090) (\BLKFABSMIN.UFN 38092 . 38458)) (38500 40318 (\P-MISC2.UFN 38510 .
|
||||
38751) (\LINES-EQUAL-P 38753 . 39137) (\GET-NEXT-RUN 39139 . 40316)) (40319 44498 (IBLT1 40329 . 42331
|
||||
) (IBLT2 42333 . 44496)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Dec-2021 18:25:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;29 47473
|
||||
(FILECREATED "19-Jan-2022 23:09:02"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;34 47559
|
||||
|
||||
:CHANGES-TO (FNS EDITDATE? EDITDATE)
|
||||
:CHANGES-TO (FNS FIXEDITDATE EDITDATE?)
|
||||
|
||||
:PREVIOUS-DATE " 8-Dec-2021 16:11:23"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;27)
|
||||
:PREVIOUS-DATE "19-Jan-2022 10:22:03"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;31)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -109,7 +109,7 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
|
||||
"used in ED to stash last call info so (ED NIL) will restart last edit")
|
||||
|
||||
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
|
||||
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
|
||||
|
||||
(* ;;; "Standard Common Lisp editor entry. CLtL say's ED does something reasonable when passed a pathname. We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit that. Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.")
|
||||
|
||||
@@ -627,13 +627,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
OLDATE INITLS])
|
||||
|
||||
(FIXEDITDATE
|
||||
[LAMBDA (EXPR)
|
||||
[LAMBDA (EXPR) (* ; "Edited 19-Jan-2022 23:08 by rmk")
|
||||
|
||||
(* ;; "Edited 8-Dec-2021 16:11 by rmk: Updated to add dates to the initial undated comments that begins with current-editor initials, to provide a kind of dated change-log capability.")
|
||||
(* ; "Edited 3-Dec-2021 15:03 by rmk")
|
||||
(* ; "Edited 22-Oct-2021 16:58 by rmk:")
|
||||
(* ; "Edited 27-Sep-2018 22:04 by rmk:")
|
||||
(* ; "Edited 31-Mar-2000 17:13 by rmk:")
|
||||
(* ; "Edited 27-Sep-2018 22:04 by rmk:")
|
||||
(* ; "Edited 31-Mar-2000 17:13 by rmk:")
|
||||
(* ; "Edited 17-Jul-89 11:13 by jtm:")
|
||||
(* ; "18-JUL-78 21:11")
|
||||
|
||||
@@ -722,56 +720,57 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
ELSEIF (SETQ PARSE (EDITDATE? (CAR E)
|
||||
T))
|
||||
THEN
|
||||
(* ;; "Attach the new timestamp at the beginning of E, provided the new date is either more than a day later than the previous one or by a different editor.")
|
||||
(* ;; "If edited by the same editor within a day, then update the previous timestamp rather than cluttering with a new one. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ")
|
||||
|
||||
(* ;; "If edited by the same editor within a day, then update the previous timestamp rather than just leaving the original time. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ")
|
||||
|
||||
(IF (STRING.EQUAL INITLS (CADR PARSE))
|
||||
(IF [AND (STRING.EQUAL INITLS (CADR PARSE))
|
||||
(ILEQ (IDIFFERENCE (IDATE)
|
||||
(IDATE (CAR PARSE)))
|
||||
(CONSTANT (TIMES 24 3600]
|
||||
THEN
|
||||
|
||||
(* ;; "Another edit by the same author. If not dated but contains a rest, then upgrade the rest comment with a date Otherwise,If more than a day later, add a new date. If less than a day, assume we are in essentially the same session, and update (CAR E) to the current time.")
|
||||
(* ;; "Same edit session with the same author: update the last previous timestamp. If the (CAR PARSE) is NIL, we are looking at an initialed comment that becomes a timestamp, and we convert it. If just after this we see another timestamp for the same session, we take that out.")
|
||||
|
||||
[IF (NULL (CAR PARSE))
|
||||
THEN
|
||||
(* ;; "If no date but %"INITIALS: xxx%", we definitely want to upgraded to the Edited... initials: xxx format")
|
||||
|
||||
(/RPLACA E (EDITDATE (CAR E)
|
||||
INITLS
|
||||
(CADDR PARSE)))
|
||||
ELSEIF (IGREATERP (IDIFFERENCE (IDATE)
|
||||
(/RPLACA E (EDITDATE (CAR E)
|
||||
INITLS
|
||||
(CADDR PARSE)))
|
||||
(CL:WHEN [AND (SETQ PARSE (EDITDATE? (CADR E)
|
||||
T))
|
||||
(NULL (CADDR PARSE))
|
||||
(STRING.EQUAL INITLS (CADR PARSE))
|
||||
(ILEQ (IDIFFERENCE (IDATE)
|
||||
(IDATE (CAR PARSE)))
|
||||
(TIMES 24 3600))
|
||||
THEN
|
||||
(* ;;
|
||||
"If we aren't upgrading, then we don't want to propagate the previous REST.")
|
||||
|
||||
(/ATTACH (EDITDATE NIL INITLS)
|
||||
E)
|
||||
ELSE
|
||||
(* ;;
|
||||
"Same author, within a day. Just change the date, keep the REST.")
|
||||
|
||||
(/RPLACA E (EDITDATE (CAR E)
|
||||
INITLS
|
||||
(CADDR PARSE]
|
||||
(CONSTANT (TIMES 24 3600]
|
||||
(/RPLACD E (CDDR E)))
|
||||
ELSE
|
||||
(* ;;
|
||||
"Different edit sequence, attach a new timestamp in front of any old ones.")
|
||||
|
||||
(* ;; "Not a previous date, or not one with this author. Add a new one. If rmk is editing and sees an lmm: rest, we don't want to attribute that rest to rmk in the new one.")
|
||||
(/ATTACH (EDITDATE NIL INITLS (CADDR PARSE))
|
||||
E))
|
||||
|
||||
(/ATTACH (EDITDATE NIL INITLS)
|
||||
E))
|
||||
(* ;; "If the new date has an upgraded comment-level, update all of the previous dates so that they align on the left instead of the right.")
|
||||
|
||||
(CL:UNLESS (EQ (CADR (CAR E))
|
||||
';)
|
||||
(FOR PREV (NEWTYPE _ (CADR (CAR E))) IN (CDR E)
|
||||
WHILE (EDITDATE? PREV T) UNTIL (EQ (CADR PREV)
|
||||
NEWTYPE)
|
||||
DO (/RPLACA (CDR PREV)
|
||||
NEWTYPE)))
|
||||
ELSE
|
||||
(* ;; "Need a new date, didn't even see %"<initials: xxx%"")
|
||||
(* ;;
|
||||
"First edit: we didn't see an old date to compare with or smash, not even an initials: xxx form.")
|
||||
|
||||
(/ATTACH (EDITDATE NIL INITLS)
|
||||
E)))
|
||||
(RETURN EXPR)))])
|
||||
|
||||
(EDITDATE?
|
||||
[LAMBDA (COMMENT RESTOK) (* ; "Edited 8-Dec-2021 18:24 by rmk")
|
||||
[LAMBDA (COMMENT RESTOK) (* ; "Edited 19-Jan-2022 22:49 by rmk")
|
||||
(* ; "Edited 8-Dec-2021 18:24 by rmk")
|
||||
|
||||
(* ;; "Edited 6-Dec-2021 16:04 by rmk: Return will have date/initial, initial/rest, or date/initial/rest. Always an initial and something, or NIL.")
|
||||
(* ; "Edited 4-Dec-2021 10:39 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 10:39 by rmk")
|
||||
|
||||
(* ;;; "This determines whether this is a dated or initialed comment that is potentially reusable in the current context. Unless RESTOK, this only recognizes modern-format configurations of the form %"Edited <date> by <initials>%", and returns a parsed pair (DATE INITIALS).")
|
||||
|
||||
@@ -818,12 +817,14 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
(CL:WHEN (SETQ REST (SUBSTRING STRING (ADD1 IENDPOS)))
|
||||
(SETQ REST (CL:STRING-TRIM `(#\Space)
|
||||
REST)))
|
||||
(IF (IGREATERP (NCHARS REST)
|
||||
0)
|
||||
THEN
|
||||
(* ;; "Could be %"<initials>: abc%" to be upgraded with a date")
|
||||
(IF (AND REST (IGREATERP (NCHARS REST)
|
||||
0))
|
||||
THEN (CL:WHEN RESTOK
|
||||
|
||||
(CL:WHEN RESTOK (LIST DATE I REST))
|
||||
(* ;; "Could be %"<initials>: abc%" , we fill in the date")
|
||||
|
||||
(LIST (DATE (DATEFORMAT NO.SECONDS))
|
||||
I REST))
|
||||
ELSEIF DATE
|
||||
THEN
|
||||
(* ;; "If we saw just initials")
|
||||
@@ -928,11 +929,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4086 10381 (ED 4086 . 10381)) (10383 14359 (INSTALL-PROTOTYPE-DEFN 10383 . 14359)) (
|
||||
14360 31143 (EDITDEF.FNS 14370 . 15706) (EDITF 15708 . 16588) (EDITFB 16590 . 17438) (EDITFNS 17440 .
|
||||
18760) (EDITLOADFNS? 18762 . 22562) (EDITMODE 22564 . 24574) (EDITP 24576 . 25087) (EDITV 25089 .
|
||||
25728) (DC 25730 . 26411) (DF 26413 . 27455) (DP 27457 . 28541) (DV 28543 . 29115) (EDITPROP 29117 .
|
||||
29336) (EF 29338 . 29667) (EP 29669 . 29852) (EV 29854 . 30033) (EDITE 30035 . 30913) (EDITL 30915 .
|
||||
31141)) (31493 46618 (NEW/EDITDATE 31503 . 31725) (FIXEDITDATE 31727 . 39874) (EDITDATE? 39876 . 43363
|
||||
) (EDITDATE 43365 . 44621) (SETINITIALS 44623 . 46616)))))
|
||||
(FILEMAP (NIL (4089 10388 (ED 4089 . 10388)) (10390 14366 (INSTALL-PROTOTYPE-DEFN 10390 . 14366)) (
|
||||
14367 31150 (EDITDEF.FNS 14377 . 15713) (EDITF 15715 . 16595) (EDITFB 16597 . 17445) (EDITFNS 17447 .
|
||||
18767) (EDITLOADFNS? 18769 . 22569) (EDITMODE 22571 . 24581) (EDITP 24583 . 25094) (EDITV 25096 .
|
||||
25735) (DC 25737 . 26418) (DF 26420 . 27462) (DP 27464 . 28548) (DV 28550 . 29122) (EDITPROP 29124 .
|
||||
29343) (EF 29345 . 29674) (EP 29676 . 29859) (EV 29861 . 30040) (EDITE 30042 . 30920) (EDITL 30922 .
|
||||
31148)) (31500 46704 (NEW/EDITDATE 31510 . 31732) (FIXEDITDATE 31734 . 39753) (EDITDATE? 39755 . 43449
|
||||
) (EDITDATE 43451 . 44707) (SETINITIALS 44709 . 46702)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Dec-2021 09:31:06" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;103 160528
|
||||
(FILECREATED "13-Jan-2022 19:45:36" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;105 160514
|
||||
|
||||
:CHANGES-TO (FNS \DO.PARAMS.AT.OPEN SETFILEINFO)
|
||||
:CHANGES-TO (RECORDS FDEV)
|
||||
|
||||
:PREVIOUS-DATE "14-Dec-2021 16:10:18"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;102)
|
||||
:PREVIOUS-DATE "19-Dec-2021 09:31:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEIO.;103)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -859,12 +859,12 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
"(stream byte) output byte to stream")
|
||||
(PEEKBIN POINTER) (* ;
|
||||
"(stream) => next byte without advancing position in stream")
|
||||
(NIL POINTER) (* ;
|
||||
"Was READCHAR, replaced by READCHARCODE")
|
||||
(NIL POINTER) (* ;
|
||||
(FDEV1 POINTER) (* ;
|
||||
"Was READCHAR, replaced by READCHARCODE. Now available for device-specific use")
|
||||
(FDEV2 POINTER) (* ;
|
||||
"Was WRITECHAR (stream char) => writes char to stream")
|
||||
(NIL POINTER) (* ; "Was PEEKCHAR")
|
||||
(NIL POINTER) (* ; "Was UNREADCHAR")
|
||||
(FDEV3 POINTER) (* ; "Was PEEKCHAR")
|
||||
(FDEV4 POINTER) (* ; "Was UNREADCHAR")
|
||||
(READP POINTER) (* ;
|
||||
"(stream flag) => T if there is input available from stream right now")
|
||||
(EOFP POINTER) (* ;
|
||||
@@ -1125,10 +1125,10 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation.
|
||||
(BIN POINTER)
|
||||
(BOUT POINTER)
|
||||
(PEEKBIN POINTER)
|
||||
(NIL POINTER)
|
||||
(NIL POINTER)
|
||||
(NIL POINTER)
|
||||
(NIL POINTER)
|
||||
(FDEV1 POINTER)
|
||||
(FDEV2 POINTER)
|
||||
(FDEV3 POINTER)
|
||||
(FDEV4 POINTER)
|
||||
(READP POINTER)
|
||||
(EOFP POINTER)
|
||||
(BLOCKIN POINTER)
|
||||
@@ -3089,40 +3089,40 @@ update the map")
|
||||
(PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1992 1993 1999 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (26876 30354 (STREAMPROP 26886 . 27320) (GETSTREAMPROP 27322 . 27791) (PUTSTREAMPROP
|
||||
27793 . 30202) (STREAMP 30204 . 30352)) (30397 32916 (\DEFPRINT.BY.NAME 30407 . 31559) (
|
||||
\STREAM.DEFPRINT 31561 . 32609) (\FDEV.DEFPRINT 32611 . 32914)) (33174 38215 (\GETACCESS 33184 . 33638
|
||||
) (\SETACCESS 33640 . 38213)) (58368 64337 (\DEFINEDEVICE 58378 . 60694) (\GETDEVICEFROMNAME 60696 .
|
||||
61169) (\GETDEVICEFROMHOSTNAME 61171 . 62215) (\REMOVEDEVICE 62217 . 63340) (\REMOVEDEVICE.NAMES 63342
|
||||
. 64335)) (64377 88654 (\CLOSEFILE 64387 . 65212) (\DELETEFILE 65214 . 65508) (\DEVICEEVENT 65510 .
|
||||
67280) (\GENERATEFILES 67282 . 67760) (\GENERATENEXTFILE 67762 . 68413) (\GENERATEFILEINFO 68415 .
|
||||
68876) (\GETFILENAME 68878 . 69267) (\GENERIC.OUTFILEP 69269 . 69739) (\OPENFILE 69741 . 72319) (
|
||||
\DO.PARAMS.AT.OPEN 72321 . 74491) (\RENAMEFILE 74493 . 74917) (\REVALIDATEFILE 74919 . 77521) (
|
||||
\PAGED.REVALIDATEFILELST 77523 . 79081) (\PAGED.REVALIDATEFILES 79083 . 80802) (\PAGED.REVALIDATEFILE
|
||||
80804 . 83087) (\BUFFERED.REVALIDATEFILE 83089 . 85375) (\BUFFERED.REVALIDATEFILELST 85377 . 86561) (
|
||||
\PRINT-REVALIDATION-RESULT 86563 . 86978) (\TRUNCATEFILE 86980 . 87371) (\FILE-CONFLICT 87373 . 88652)
|
||||
) (88690 93353 (\GENERATENOFILES 88700 . 90796) (\NULLFILEGENERATOR 90798 . 91042) (\NOFILESNEXTFILEFN
|
||||
91044 . 93035) (\NOFILESINFOFN 93037 . 93351)) (93472 95380 (\FILE.NOT.OPEN 93482 . 93995) (
|
||||
\FILE.WONT.OPEN 93997 . 94325) (\ILLEGAL.DEVICEOP 94327 . 94609) (\IS.NOT.RANDACCESSP 94611 . 95057) (
|
||||
\STREAM.NOT.OPEN 95059 . 95378)) (95515 97813 (\FDEVINSTANCE 95525 . 97811)) (99015 106389 (CNDIR
|
||||
99025 . 100330) (DIRECTORYNAME 100332 . 104515) (DIRECTORYNAMEP 104517 . 105133) (HOSTNAMEP 105135 .
|
||||
105942) (\ADD.CONNECTED.DIR 105944 . 106387)) (106434 134314 (\BACKFILEPTR 106444 . 106632) (
|
||||
\BACKPEEKBIN 106634 . 106995) (\BACKBIN 106997 . 107348) (BIN 107350 . 107567) (\BIN 107569 . 107846)
|
||||
(\BINS 107848 . 108134) (BOUT 108136 . 108498) (\BOUT 108500 . 108815) (\BOUTS 108817 . 109128) (
|
||||
COPYBYTES 109130 . 112462) (COPYCHARS 112464 . 116130) (COPYFILE 116132 . 116929) (\COPYOPENFILE
|
||||
116931 . 120004) (\INFER.FILE.TYPE 120006 . 120960) (EOFP 120962 . 121259) (FORCEOUTPUT 121261 .
|
||||
121508) (\FLUSH.OPEN.STREAMS 121510 . 121866) (CHARSET 121868 . 123532) (ACCESS-CHARSET 123534 .
|
||||
123751) (GETEOFPTR 123753 . 124003) (GETFILEINFO 124005 . 127198) (\TYPE.FROM.FILETYPE 127200 . 127670
|
||||
) (\FILETYPE.FROM.TYPE 127672 . 127851) (GETFILEPTR 127853 . 128105) (SETFILEINFO 128107 . 132213) (
|
||||
SETFILEPTR 132215 . 133934) (BOUT16 133936 . 134121) (BIN16 134123 . 134312)) (134417 139622 (
|
||||
\GENERIC.BINS 134427 . 134707) (\GENERIC.BOUTS 134709 . 134974) (\GENERIC.RENAMEFILE 134976 . 136807)
|
||||
(\GENERIC.OPENP 136809 . 138124) (\GENERIC.READP 138126 . 139167) (\GENERIC.CHARSET 139169 . 139620))
|
||||
(139623 139962 (\MAP-OPEN-STREAMS 139633 . 139960)) (141746 143826 (\EOF.ACTION 141756 . 142007) (
|
||||
\EOSERROR 142009 . 142202) (\GETEOFPTR 142204 . 142386) (\INCFILEPTR 142388 . 142738) (\PEEKBIN 142740
|
||||
. 142931) (\SETCLOSEDFILELENGTH 142933 . 143267) (\SETEOFPTR 143269 . 143457) (\SETFILEPTR 143459 .
|
||||
143824)) (143827 144369 (\FIXPOUT 143837 . 144137) (\FIXPIN 144139 . 144367)) (144370 144936 (\BOUTEOL
|
||||
144380 . 144934)) (147832 157696 (\BUFFERED.BIN 147842 . 148694) (\BUFFERED.PEEKBIN 148696 . 149478)
|
||||
(\BUFFERED.BOUT 149480 . 150340) (\BUFFERED.BINS 150342 . 154027) (\BUFFERED.BOUTS 154029 . 155830) (
|
||||
\BUFFERED.COPYBYTES 155832 . 157694)) (157725 160077 (\NULLDEVICE 157735 . 159753) (\NULL.OPENFILE
|
||||
159755 . 160075)))))
|
||||
(FILEMAP (NIL (26854 30332 (STREAMPROP 26864 . 27298) (GETSTREAMPROP 27300 . 27769) (PUTSTREAMPROP
|
||||
27771 . 30180) (STREAMP 30182 . 30330)) (30375 32894 (\DEFPRINT.BY.NAME 30385 . 31537) (
|
||||
\STREAM.DEFPRINT 31539 . 32587) (\FDEV.DEFPRINT 32589 . 32892)) (33152 38193 (\GETACCESS 33162 . 33616
|
||||
) (\SETACCESS 33618 . 38191)) (58354 64323 (\DEFINEDEVICE 58364 . 60680) (\GETDEVICEFROMNAME 60682 .
|
||||
61155) (\GETDEVICEFROMHOSTNAME 61157 . 62201) (\REMOVEDEVICE 62203 . 63326) (\REMOVEDEVICE.NAMES 63328
|
||||
. 64321)) (64363 88640 (\CLOSEFILE 64373 . 65198) (\DELETEFILE 65200 . 65494) (\DEVICEEVENT 65496 .
|
||||
67266) (\GENERATEFILES 67268 . 67746) (\GENERATENEXTFILE 67748 . 68399) (\GENERATEFILEINFO 68401 .
|
||||
68862) (\GETFILENAME 68864 . 69253) (\GENERIC.OUTFILEP 69255 . 69725) (\OPENFILE 69727 . 72305) (
|
||||
\DO.PARAMS.AT.OPEN 72307 . 74477) (\RENAMEFILE 74479 . 74903) (\REVALIDATEFILE 74905 . 77507) (
|
||||
\PAGED.REVALIDATEFILELST 77509 . 79067) (\PAGED.REVALIDATEFILES 79069 . 80788) (\PAGED.REVALIDATEFILE
|
||||
80790 . 83073) (\BUFFERED.REVALIDATEFILE 83075 . 85361) (\BUFFERED.REVALIDATEFILELST 85363 . 86547) (
|
||||
\PRINT-REVALIDATION-RESULT 86549 . 86964) (\TRUNCATEFILE 86966 . 87357) (\FILE-CONFLICT 87359 . 88638)
|
||||
) (88676 93339 (\GENERATENOFILES 88686 . 90782) (\NULLFILEGENERATOR 90784 . 91028) (\NOFILESNEXTFILEFN
|
||||
91030 . 93021) (\NOFILESINFOFN 93023 . 93337)) (93458 95366 (\FILE.NOT.OPEN 93468 . 93981) (
|
||||
\FILE.WONT.OPEN 93983 . 94311) (\ILLEGAL.DEVICEOP 94313 . 94595) (\IS.NOT.RANDACCESSP 94597 . 95043) (
|
||||
\STREAM.NOT.OPEN 95045 . 95364)) (95501 97799 (\FDEVINSTANCE 95511 . 97797)) (99001 106375 (CNDIR
|
||||
99011 . 100316) (DIRECTORYNAME 100318 . 104501) (DIRECTORYNAMEP 104503 . 105119) (HOSTNAMEP 105121 .
|
||||
105928) (\ADD.CONNECTED.DIR 105930 . 106373)) (106420 134300 (\BACKFILEPTR 106430 . 106618) (
|
||||
\BACKPEEKBIN 106620 . 106981) (\BACKBIN 106983 . 107334) (BIN 107336 . 107553) (\BIN 107555 . 107832)
|
||||
(\BINS 107834 . 108120) (BOUT 108122 . 108484) (\BOUT 108486 . 108801) (\BOUTS 108803 . 109114) (
|
||||
COPYBYTES 109116 . 112448) (COPYCHARS 112450 . 116116) (COPYFILE 116118 . 116915) (\COPYOPENFILE
|
||||
116917 . 119990) (\INFER.FILE.TYPE 119992 . 120946) (EOFP 120948 . 121245) (FORCEOUTPUT 121247 .
|
||||
121494) (\FLUSH.OPEN.STREAMS 121496 . 121852) (CHARSET 121854 . 123518) (ACCESS-CHARSET 123520 .
|
||||
123737) (GETEOFPTR 123739 . 123989) (GETFILEINFO 123991 . 127184) (\TYPE.FROM.FILETYPE 127186 . 127656
|
||||
) (\FILETYPE.FROM.TYPE 127658 . 127837) (GETFILEPTR 127839 . 128091) (SETFILEINFO 128093 . 132199) (
|
||||
SETFILEPTR 132201 . 133920) (BOUT16 133922 . 134107) (BIN16 134109 . 134298)) (134403 139608 (
|
||||
\GENERIC.BINS 134413 . 134693) (\GENERIC.BOUTS 134695 . 134960) (\GENERIC.RENAMEFILE 134962 . 136793)
|
||||
(\GENERIC.OPENP 136795 . 138110) (\GENERIC.READP 138112 . 139153) (\GENERIC.CHARSET 139155 . 139606))
|
||||
(139609 139948 (\MAP-OPEN-STREAMS 139619 . 139946)) (141732 143812 (\EOF.ACTION 141742 . 141993) (
|
||||
\EOSERROR 141995 . 142188) (\GETEOFPTR 142190 . 142372) (\INCFILEPTR 142374 . 142724) (\PEEKBIN 142726
|
||||
. 142917) (\SETCLOSEDFILELENGTH 142919 . 143253) (\SETEOFPTR 143255 . 143443) (\SETFILEPTR 143445 .
|
||||
143810)) (143813 144355 (\FIXPOUT 143823 . 144123) (\FIXPIN 144125 . 144353)) (144356 144922 (\BOUTEOL
|
||||
144366 . 144920)) (147818 157682 (\BUFFERED.BIN 147828 . 148680) (\BUFFERED.PEEKBIN 148682 . 149464)
|
||||
(\BUFFERED.BOUT 149466 . 150326) (\BUFFERED.BINS 150328 . 154013) (\BUFFERED.BOUTS 154015 . 155816) (
|
||||
\BUFFERED.COPYBYTES 155818 . 157680)) (157711 160063 (\NULLDEVICE 157721 . 159739) (\NULL.OPENFILE
|
||||
159741 . 160061)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
526
sources/LLCHAR
526
sources/LLCHAR
@@ -1,9 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Jun-2021 18:08:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;6 108072
|
||||
|
||||
previous date%: "19-Jun-2021 10:00:42"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LLCHAR.;5)
|
||||
(FILECREATED " 8-Jan-2022 19:08:41" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;8 106473
|
||||
|
||||
:CHANGES-TO (FNS STRING.EQUAL)
|
||||
|
||||
:PREVIOUS-DATE "21-Jun-2021 18:08:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>LLCHAR.;6)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -18,8 +20,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE GLC GLCCODE STREQUAL
|
||||
STRING.EQUAL STRINGP CHCON1 U-CASE L-CASE U-CASEP \SMASHABLESTRING \MAKEWRITABLESTRING
|
||||
\SMASHSTRING \FATTENSTRING)
|
||||
(COMS (* ;
|
||||
"Temporary until low level system is changed to call STRING.EQUAL again")
|
||||
(COMS (* ;
|
||||
"Temporary until low level system is changed to call STRING.EQUAL again")
|
||||
(P (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T)
|
||||
(MOVD? 'STRING.EQUAL 'CL::SIMPLE-STRING-EQUAL NIL T)))
|
||||
(FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString)
|
||||
@@ -30,11 +32,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(MACROS \PNAMESTRINGPUTCHAR)
|
||||
(OPTIMIZERS FCHARACTER)
|
||||
(I.S.OPRS inpname inatom instring)
|
||||
(* ;
|
||||
"For use when the inner-loop test in the generic operators is too expensive")
|
||||
(* ;
|
||||
"For use when the inner-loop test in the generic operators is too expensive")
|
||||
(I.S.OPRS infatatom inthinatom infatstring inthinstring)
|
||||
(MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP)
|
||||
(* ; "For benefit of Masterscope")
|
||||
(* ; "For benefit of Masterscope")
|
||||
(MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN)
|
||||
(MACROS \PUTBASECHAR \GETBASECHAR)
|
||||
(MACROS \CHARSET \CHAR8CODE)
|
||||
@@ -48,7 +50,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING)
|
||||
(P (MOVD? 'CHARACTER 'FCHARACTER NIL T))
|
||||
[COMS (FNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
|
||||
(* ; "For MAKEINIT")
|
||||
(* ; "For MAKEINIT")
|
||||
(DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY
|
||||
%%COPY-STRING-TO-ARRAY))
|
||||
(* "So %%COPY-ONED-ARRAY will compile properly")
|
||||
@@ -59,7 +61,7 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY]
|
||||
(DECLARE%: DONTCOPY EVAL@COMPILE (LOCALVARS . T))
|
||||
|
||||
(* ;; "Arrange for the proper compiler")
|
||||
(* ;; "Arrange for the proper compiler")
|
||||
|
||||
(PROP FILETYPE LLCHAR)))
|
||||
(DEFINEQ
|
||||
@@ -966,10 +968,14 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GO SLOWLP])
|
||||
|
||||
(STRING.EQUAL
|
||||
[LAMBDA (X Y) (* ;
|
||||
"Edited 12-Jan-94 10:01 by sybalsky:mv:envos")
|
||||
[LAMBDA (X Y CASEARRAY) (* ; "Edited 8-Jan-2022 19:08 by rmk")
|
||||
(* ;
|
||||
"Edited 12-Jan-94 10:01 by sybalsky:mv:envos")
|
||||
|
||||
(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case")
|
||||
(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case.")
|
||||
|
||||
(* ;;
|
||||
"RMK: Added CASEARRAY argument, silly not to extend this to other than the default UPPERCASEARRAY.")
|
||||
|
||||
(PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2)
|
||||
(COND
|
||||
@@ -1012,28 +1018,32 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ OFFSETY (ffetch (STRINGP OFFST) of Y))
|
||||
(SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y)))
|
||||
(T (RETURN NIL)))
|
||||
(CL:UNLESS CASEARRAY (SETQ CASEARRAY UPPERCASEARRAY))
|
||||
[COND
|
||||
((NEQ (ffetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY 'ARRAYP))
|
||||
\ST.BYTE) (* ;
|
||||
"Someone smashed UPPERCASEARRAY ?")
|
||||
(SETQ UPPERCASEARRAY (UPPERCASEARRAY]
|
||||
(SETQ CABASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY))
|
||||
((NEQ (ffetch (ARRAYP TYP) of (\DTEST CASEARRAY 'ARRAYP))
|
||||
\ST.BYTE)
|
||||
(IF (EQ CASEARRAY UPPERCASEARRAY)
|
||||
THEN
|
||||
(* ;; "Did someone smashed the UPPERCASEARRAY? We can repair it")
|
||||
|
||||
(SETQ CASEARRAY (SETQ UPPERCASEARRAY (UPPERCASEARRAY)))
|
||||
ELSE (\ILLEGAL.ARG CASEARRAY]
|
||||
(SETQ CABASE (ffetch (ARRAYP BASE) of CASEARRAY))
|
||||
(RETURN (COND
|
||||
[(OR FATPX FATPY) (* ; "Slow case")
|
||||
(for BNX from OFFSETX as BNY from OFFSETY as I to
|
||||
LEN
|
||||
[(OR FATPX FATPY) (* ; "Slow case")
|
||||
(for BNX from OFFSETX as BNY from OFFSETY as I to LEN
|
||||
always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX))
|
||||
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
|
||||
(COND
|
||||
((OR (IGREATERP C1 \MAXTHINCHAR)
|
||||
(IGREATERP C2 \MAXTHINCHAR))
|
||||
(* ; "Fat chars not alphabetic")
|
||||
(EQ C1 C2))
|
||||
(T (EQ (\GETBASEBYTE CABASE C1)
|
||||
(\GETBASEBYTE CABASE C2]
|
||||
(T (for BNX from OFFSETX as BNY from OFFSETY as I
|
||||
to LEN always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
|
||||
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
|
||||
(SETQ C2 (\GETBASECHAR FATPY BASEY BNY))
|
||||
(COND
|
||||
((OR (IGREATERP C1 \MAXTHINCHAR)
|
||||
(IGREATERP C2 \MAXTHINCHAR))
|
||||
(* ; "Fat chars not alphabetic")
|
||||
(EQ C1 C2))
|
||||
(T (EQ (\GETBASEBYTE CABASE C1)
|
||||
(\GETBASEBYTE CABASE C2]
|
||||
(T (for BNX from OFFSETX as BNY from OFFSETY as I to LEN
|
||||
always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX))
|
||||
(\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY])
|
||||
|
||||
(STRINGP
|
||||
[LAMBDA (OBJECT) (* jop%: "24-Sep-86 22:58")
|
||||
@@ -1374,141 +1384,136 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS STRINGP ((XREADONLY (fetch (ARRAY-HEADER READ-ONLY-P) of DATUM)
|
||||
(replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE
|
||||
))
|
||||
(XBASE ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-BASE STRING))
|
||||
(T (fetch (ARRAY-HEADER BASE) of STRING]
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER INDIRECT-P) of STRING with
|
||||
NIL)
|
||||
(replace (ARRAY-HEADER BASE) of STRING with NV)
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(TYP ((OPENLAMBDA (STRING)
|
||||
(SELECTC (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING)))
|
||||
(%%THIN-CHAR-TYPENUMBER
|
||||
\ST.BYTE)
|
||||
(%%FAT-CHAR-TYPENUMBER
|
||||
\ST.POS16)
|
||||
(SHOULDNT "Unknown type-number")))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (SELECTC NV
|
||||
(\ST.BYTE %%THIN-CHAR-TYPENUMBER)
|
||||
(\ST.POS16 %%FAT-CHAR-TYPENUMBER)
|
||||
(SHOULDNT "Unknown typ value"]
|
||||
(COND
|
||||
(replace (ARRAY-HEADER READ-ONLY-P) of DATUM with NEWVALUE))
|
||||
(XBASE ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-BASE STRING))
|
||||
(T (fetch (ARRAY-HEADER BASE) of STRING]
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER INDIRECT-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER BASE) of STRING with NV)
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(TYP ((OPENLAMBDA (STRING)
|
||||
(SELECTC (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING
|
||||
with %%NEW-TYPE-NUMBER]
|
||||
DATUM NEWVALUE))
|
||||
(LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER FILL-POINTER) of STRING with
|
||||
NV)
|
||||
(replace (ARRAY-HEADER TOTAL-SIZE) of STRING with
|
||||
NV)
|
||||
[COND
|
||||
((%%GENERAL-ARRAY-P STRING)
|
||||
(freplace (GENERAL-ARRAY DIMS) of STRING
|
||||
with (LIST NV]
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(OFFST ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-OFFSET STRING))
|
||||
(T (fetch (ARRAY-HEADER OFFSET) of STRING]
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ 0 NV))
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING
|
||||
with T)))
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-OFFSET STRING NV))
|
||||
(T (replace (ARRAY-HEADER OFFSET) of STRING with
|
||||
NV]
|
||||
DATUM NEWVALUE))
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER) of STRING)))
|
||||
(%%THIN-CHAR-TYPENUMBER
|
||||
\ST.BYTE)
|
||||
(%%FAT-CHAR-TYPENUMBER
|
||||
\ST.POS16)
|
||||
(SHOULDNT "Unknown type-number")))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (SELECTC NV
|
||||
(\ST.BYTE %%THIN-CHAR-TYPENUMBER)
|
||||
(\ST.POS16 %%FAT-CHAR-TYPENUMBER)
|
||||
(SHOULDNT "Unknown typ value"]
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER) of STRING with
|
||||
%%NEW-TYPE-NUMBER
|
||||
]
|
||||
DATUM NEWVALUE))
|
||||
(LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(replace (ARRAY-HEADER FILL-POINTER) of STRING with NV)
|
||||
(replace (ARRAY-HEADER TOTAL-SIZE) of STRING with NV)
|
||||
[COND
|
||||
((%%GENERAL-ARRAY-P STRING)
|
||||
(freplace (GENERAL-ARRAY DIMS) of STRING with (LIST NV]
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(OFFST ([OPENLAMBDA (STRING)
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%ARRAY-OFFSET STRING))
|
||||
(T (fetch (ARRAY-HEADER OFFSET) of STRING]
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ 0 NV))
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING with T)))
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-OFFSET STRING NV))
|
||||
(T (replace (ARRAY-HEADER OFFSET) of STRING with NV]
|
||||
DATUM NEWVALUE))
|
||||
|
||||
(* ;; "The rest of these fields only appear when smashing")
|
||||
(* ;; "The rest of these fields only appear when smashing")
|
||||
|
||||
(XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
|
||||
15)
|
||||
((OPENLAMBDA (STRING)
|
||||
(replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with
|
||||
NIL)
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING with
|
||||
NIL)
|
||||
(replace (ARRAY-HEADER FILL-POINTER-P) of STRING
|
||||
with NIL)
|
||||
(replace (ARRAY-HEADER EXTENDABLE-P) of STRING with
|
||||
NIL))
|
||||
DATUM)))
|
||||
[ACCESSFNS STRINGP
|
||||
((ORIG ((OPENLAMBDA (STRING)
|
||||
1)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ NV 1))
|
||||
(ERROR "Il:stringp's are always origin 1")))
|
||||
NV)
|
||||
DATUM NEWVALUE)) (* ; "An inoperative field")
|
||||
(SUBSTRINGED ((OPENLAMBDA (STRING)
|
||||
NIL)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(OR (NULL NV)
|
||||
(ERROR "Substringed field not supported")))
|
||||
DATUM NEWVALUE))
|
||||
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
|
||||
(freplace (STRINGP XREADONLY) of DATUM with
|
||||
NEWVALUE))
|
||||
(FATSTRINGP ((OPENLAMBDA (STRING)
|
||||
(EQ (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P)
|
||||
of STRING)
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING)))
|
||||
%%FAT-CHAR-TYPENUMBER))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (COND
|
||||
(NV %%FAT-CHAR-TYPENUMBER)
|
||||
(T %%THIN-CHAR-TYPENUMBER]
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P) of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING %%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING with %%NEW-TYPE-NUMBER]
|
||||
DATUM NEWVALUE))
|
||||
(BASE (ffetch (STRINGP XBASE) of DATUM)
|
||||
(freplace (STRINGP XBASE) of DATUM with NEWVALUE]
|
||||
(CREATE (create ONED-ARRAY
|
||||
BASE _ XBASE
|
||||
READ-ONLY-P _ XREADONLY
|
||||
STRING-P _ T
|
||||
DISPLACED-P _ (NOT (EQ OFFST 0))
|
||||
TYPE-NUMBER _ (COND
|
||||
((EQ TYP \ST.POS16)
|
||||
%%FAT-CHAR-TYPENUMBER)
|
||||
(T %%THIN-CHAR-TYPENUMBER))
|
||||
OFFSET _ OFFST
|
||||
FILL-POINTER _ LENGTH
|
||||
TOTAL-SIZE _ LENGTH))
|
||||
(TYPE? (CL:STRINGP DATUM))
|
||||
OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
|
||||
(XFLAGS (LOGAND (fetch (ARRAY-HEADER FLAGS) of DATUM)
|
||||
15)
|
||||
((OPENLAMBDA (STRING)
|
||||
(replace (ARRAY-HEADER ADJUSTABLE-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER DISPLACED-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER FILL-POINTER-P) of STRING with NIL)
|
||||
(replace (ARRAY-HEADER EXTENDABLE-P) of STRING with NIL))
|
||||
DATUM)))
|
||||
[ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING)
|
||||
1)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(COND
|
||||
((NOT (EQ NV 1))
|
||||
(ERROR "Il:stringp's are always origin 1")))
|
||||
NV)
|
||||
DATUM NEWVALUE))
|
||||
(* ; "An inoperative field")
|
||||
(SUBSTRINGED ((OPENLAMBDA (STRING)
|
||||
NIL)
|
||||
DATUM)
|
||||
((OPENLAMBDA (STRING NV)
|
||||
(OR (NULL NV)
|
||||
(ERROR "Substringed field not supported")))
|
||||
DATUM NEWVALUE))
|
||||
(READONLY (ffetch (STRINGP XREADONLY) of DATUM)
|
||||
(freplace (STRINGP XREADONLY) of DATUM with NEWVALUE))
|
||||
(FATSTRINGP ((OPENLAMBDA (STRING)
|
||||
(EQ (COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P)
|
||||
of STRING)
|
||||
(%%ARRAY-TYPE-NUMBER STRING))
|
||||
(T (fetch (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING)))
|
||||
%%FAT-CHAR-TYPENUMBER))
|
||||
DATUM)
|
||||
([OPENLAMBDA (STRING NV)
|
||||
(LET [(%%NEW-TYPE-NUMBER (COND
|
||||
(NV
|
||||
%%FAT-CHAR-TYPENUMBER
|
||||
)
|
||||
(T
|
||||
%%THIN-CHAR-TYPENUMBER
|
||||
]
|
||||
(COND
|
||||
((fetch (ARRAY-HEADER INDIRECT-P)
|
||||
of STRING)
|
||||
(%%SET-ARRAY-TYPE-NUMBER STRING
|
||||
%%NEW-TYPE-NUMBER))
|
||||
(T (replace (ARRAY-HEADER TYPE-NUMBER)
|
||||
of STRING with %%NEW-TYPE-NUMBER]
|
||||
DATUM NEWVALUE))
|
||||
(BASE (ffetch (STRINGP XBASE) of DATUM)
|
||||
(freplace (STRINGP XBASE) of DATUM with NEWVALUE]
|
||||
(CREATE (create ONED-ARRAY
|
||||
BASE _ XBASE
|
||||
READ-ONLY-P _ XREADONLY
|
||||
STRING-P _ T
|
||||
DISPLACED-P _ (NOT (EQ OFFST 0))
|
||||
TYPE-NUMBER _ (COND
|
||||
((EQ TYP \ST.POS16)
|
||||
%%FAT-CHAR-TYPENUMBER)
|
||||
(T %%THIN-CHAR-TYPENUMBER))
|
||||
OFFSET _ OFFST
|
||||
FILL-POINTER _ LENGTH
|
||||
TOTAL-SIZE _ LENGTH))
|
||||
(TYPE? (CL:STRINGP DATUM))
|
||||
OFFST _ 0 TYP _ \ST.BYTE LENGTH _ 0)
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -1531,27 +1536,25 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE)
|
||||
(* ;
|
||||
"For stuffing chars into resource \PNAMESTRING")
|
||||
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
|
||||
(PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* ;
|
||||
"For stuffing chars into resource \PNAMESTRING")
|
||||
(\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE)))
|
||||
)
|
||||
|
||||
(DEFOPTIMIZER FCHARACTER (NUM)
|
||||
`([OPENLAMBDA (N)
|
||||
(COND
|
||||
((IGREATERP N \MAXTHINCHAR)
|
||||
(* ;
|
||||
"The character we're getting is NOT a thin character -- do it the hard way")
|
||||
(CHARACTER N))
|
||||
((IGREATERP N (CHARCODE 9))
|
||||
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
|
||||
((IGEQ N (CHARCODE 0))
|
||||
(IDIFFERENCE N (CHARCODE 0)))
|
||||
(T (* ;
|
||||
"The common case -- just add on the one-atom base.")
|
||||
(\ADDBASE \OneCharAtomBase N]
|
||||
,NUM))
|
||||
`([OPENLAMBDA (N)
|
||||
(COND
|
||||
((IGREATERP N \MAXTHINCHAR) (* ;
|
||||
"The character we're getting is NOT a thin character -- do it the hard way")
|
||||
(CHARACTER N))
|
||||
((IGREATERP N (CHARCODE 9))
|
||||
(\ADDBASE \OneCharAtomBase (IDIFFERENCE N 10)))
|
||||
((IGEQ N (CHARCODE 0))
|
||||
(IDIFFERENCE N (CHARCODE 0)))
|
||||
(T (* ;
|
||||
"The common case -- just add on the one-atom base.")
|
||||
(\ADDBASE \OneCharAtomBase N]
|
||||
,NUM))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET)
|
||||
@@ -1563,30 +1566,26 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
`(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
|
||||
declare (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET)
|
||||
first [PROG NIL
|
||||
$$RETRY
|
||||
(COND
|
||||
((STRINGP $$BODY)
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE)
|
||||
of $$BODY))
|
||||
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP
|
||||
OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch
|
||||
(STRINGP
|
||||
LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP
|
||||
FATSTRINGP)
|
||||
of $$BODY)))
|
||||
((LITATOM $$BODY)
|
||||
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
|
||||
of $$BODY)))
|
||||
(T (SETQ $$BODY (MKSTRING $$BODY))
|
||||
(GO $$RETRY]
|
||||
$$RETRY
|
||||
(COND
|
||||
((STRINGP $$BODY)
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH
|
||||
)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
|
||||
of $$BODY)))
|
||||
((LITATOM $$BODY)
|
||||
(SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP)
|
||||
of $$BODY)))
|
||||
(T (SETQ $$BODY (MKSTRING $$BODY))
|
||||
(GO $$RETRY]
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1603,10 +1602,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END $$FATP
|
||||
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY
|
||||
))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE)
|
||||
)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
|
||||
(SETQ $$FATP (ffetch (LITATOM FATPNAMEP) of $$BODY))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
@@ -1624,13 +1621,11 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE $$FATP
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP)
|
||||
of $$BODY))
|
||||
(SETQ $$FATP (ffetch (STRINGP FATSTRINGP) of $$BODY))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1648,10 +1643,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
|
||||
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1665,10 +1658,8 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$OFFSET _ 0 $$BODY _ BODY $$BASE $$END
|
||||
declare (LOCALVARS $$OFFSET $$BODY $$BASE $$END)
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE)
|
||||
of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH)
|
||||
of $$BASE))
|
||||
first (SETQ $$BASE (ffetch (LITATOM PNAMEBASE) of $$BODY))
|
||||
(SETQ $$END (ffetch (PNAMEBASE PNAMELENGTH) of $$BASE))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
(GO $$OUT))
|
||||
@@ -1682,12 +1673,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(GETDUMMYVAR))
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY
|
||||
))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
|
||||
LENGTH)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST) of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
@@ -1703,11 +1691,9 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
'(bind $$BODY _ BODY $$END $$OFFSET $$BASE
|
||||
declare (LOCALVARS $$BODY $$END $$OFFSET $$BASE)
|
||||
first (SETQ $$OFFSET (SUB1 (ffetch (STRINGP OFFST)
|
||||
of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of
|
||||
$$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP
|
||||
LENGTH)
|
||||
of $$BODY)))
|
||||
(SETQ $$BASE (ffetch (STRINGP BASE) of $$BODY))
|
||||
(SETQ $$END (IPLUS $$OFFSET (ffetch (STRINGP LENGTH)
|
||||
of $$BODY)))
|
||||
eachtime (SETQ $$OFFSET (ADD1 $$OFFSET))
|
||||
(AND (IGREATERP $$OFFSET $$END)
|
||||
@@ -1717,20 +1703,20 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0))))
|
||||
(PUTPROPS \CHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0))))
|
||||
|
||||
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGREATERP X \MAXTHINCHAR))))
|
||||
(PUTPROPS \FATCHARCODEP DMACRO (OPENLAMBDA (X) (* ;
|
||||
"Used to also say (ILEQ X \MAXFATCHAR), but that's implied by the first two clauses")
|
||||
(AND (SMALLP X)
|
||||
(IGREATERP X \MAXTHINCHAR))))
|
||||
|
||||
(PUTPROPS \THINCHARCODEP DMACRO (OPENLAMBDA (X)
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0)
|
||||
(ILEQ X \MAXTHINCHAR))))
|
||||
(AND (SMALLP X)
|
||||
(IGEQ X 0)
|
||||
(ILEQ X \MAXTHINCHAR))))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1745,22 +1731,22 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \PUTBASECHAR MACRO [OPENLAMBDA (FATP BASE OFFSET CODE)
|
||||
(COND
|
||||
(FATP (\PUTBASEFAT BASE OFFSET CODE))
|
||||
(T (\PUTBASETHIN BASE OFFSET CODE])
|
||||
(COND
|
||||
(FATP (\PUTBASEFAT BASE OFFSET CODE))
|
||||
(T (\PUTBASETHIN BASE OFFSET CODE])
|
||||
|
||||
(PUTPROPS \GETBASECHAR MACRO [(FATP BASE N)
|
||||
(COND
|
||||
(FATP (\GETBASEFAT BASE N))
|
||||
(T (\GETBASETHIN BASE N])
|
||||
(COND
|
||||
(FATP (\GETBASEFAT BASE N))
|
||||
(T (\GETBASETHIN BASE N])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CHARSET MACRO ((CHARCODE)
|
||||
(LRSH CHARCODE 8)))
|
||||
(LRSH CHARCODE 8)))
|
||||
|
||||
(PUTPROPS \CHAR8CODE MACRO ((CHARCODE)
|
||||
(LOGAND CHARCODE 255)))
|
||||
(LOGAND CHARCODE 255)))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1787,10 +1773,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \NATOMCHARS DMACRO ((AT)
|
||||
(fetch (LITATOM PNAMELENGTH) of AT)))
|
||||
(fetch (LITATOM PNAMELENGTH) of AT)))
|
||||
|
||||
(PUTPROPS \NSTRINGCHARS DMACRO ((S)
|
||||
(fetch (STRINGP LENGTH) of S)))
|
||||
(fetch (STRINGP LENGTH) of S)))
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -1866,10 +1852,10 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY))
|
||||
|
||||
(ADDTOVAR INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
|
||||
CMLARRAY-SUPPORT))
|
||||
CMLARRAY-SUPPORT))
|
||||
|
||||
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN
|
||||
\GETBASEFAT \PUTBASECHAR)
|
||||
(ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT
|
||||
\PUTBASECHAR)
|
||||
|
||||
(ADDTOVAR DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)
|
||||
)
|
||||
@@ -1889,16 +1875,16 @@ Copyright (c) 1982-1988, 1990, 1994, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994
|
||||
2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3970 73876 (ALLOCSTRING 3980 . 6003) (MKATOM 6005 . 6640) (SUBATOM 6642 . 8512) (
|
||||
CHARACTER 8514 . 9518) (\PARSE.NUMBER 9520 . 25240) (\INVALID.DOTTED.SYMBOL 25242 . 25737) (
|
||||
\INVALID.INTEGER 25739 . 27191) (\MKINTEGER 27193 . 29900) (MKSTRING 29902 . 32045) (
|
||||
\PRINDATUM.TO.STRING 32047 . 38225) (BKSYSBUF 38227 . 39761) (NCHARS 39763 . 41463) (NTHCHARCODE 41465
|
||||
. 43511) (RPLCHARCODE 43513 . 44574) (\RPLCHARCODE 44576 . 46111) (NTHCHAR 46113 . 46306) (RPLSTRING
|
||||
46308 . 49519) (SUBSTRING 49521 . 52444) (GNC 52446 . 52619) (GNCCODE 52621 . 53389) (GLC 53391 .
|
||||
53564) (GLCCODE 53566 . 54331) (STREQUAL 54333 . 56447) (STRING.EQUAL 56449 . 60507) (STRINGP 60509 .
|
||||
60660) (CHCON1 60662 . 61449) (U-CASE 61451 . 64678) (L-CASE 64680 . 68540) (U-CASEP 68542 . 69116) (
|
||||
\SMASHABLESTRING 69118 . 69580) (\MAKEWRITABLESTRING 69582 . 70018) (\SMASHSTRING 70020 . 73726) (
|
||||
\FATTENSTRING 73728 . 73874)) (74061 79223 (\GETBASESTRING 74071 . 74725) (\PUTBASESTRING 74727 .
|
||||
77466) (\PUTBASESTRINGFAT 77468 . 78214) (GetBcplString 78216 . 78881) (SetBcplString 78883 . 79221))
|
||||
(104450 107264 (%%COPY-ONED-ARRAY 104460 . 106310) (%%COPY-STRING-TO-ARRAY 106312 . 107262)))))
|
||||
(FILEMAP (NIL (4009 74195 (ALLOCSTRING 4019 . 6042) (MKATOM 6044 . 6679) (SUBATOM 6681 . 8551) (
|
||||
CHARACTER 8553 . 9557) (\PARSE.NUMBER 9559 . 25279) (\INVALID.DOTTED.SYMBOL 25281 . 25776) (
|
||||
\INVALID.INTEGER 25778 . 27230) (\MKINTEGER 27232 . 29939) (MKSTRING 29941 . 32084) (
|
||||
\PRINDATUM.TO.STRING 32086 . 38264) (BKSYSBUF 38266 . 39800) (NCHARS 39802 . 41502) (NTHCHARCODE 41504
|
||||
. 43550) (RPLCHARCODE 43552 . 44613) (\RPLCHARCODE 44615 . 46150) (NTHCHAR 46152 . 46345) (RPLSTRING
|
||||
46347 . 49558) (SUBSTRING 49560 . 52483) (GNC 52485 . 52658) (GNCCODE 52660 . 53428) (GLC 53430 .
|
||||
53603) (GLCCODE 53605 . 54370) (STREQUAL 54372 . 56486) (STRING.EQUAL 56488 . 60826) (STRINGP 60828 .
|
||||
60979) (CHCON1 60981 . 61768) (U-CASE 61770 . 64997) (L-CASE 64999 . 68859) (U-CASEP 68861 . 69435) (
|
||||
\SMASHABLESTRING 69437 . 69899) (\MAKEWRITABLESTRING 69901 . 70337) (\SMASHSTRING 70339 . 74045) (
|
||||
\FATTENSTRING 74047 . 74193)) (74380 79542 (\GETBASESTRING 74390 . 75044) (\PUTBASESTRING 75046 .
|
||||
77785) (\PUTBASESTRINGFAT 77787 . 78533) (GetBcplString 78535 . 79200) (SetBcplString 79202 . 79540))
|
||||
(102859 105673 (%%COPY-ONED-ARRAY 102869 . 104719) (%%COPY-STRING-TO-ARRAY 104721 . 105671)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,23 +1,26 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "29-Apr-2021 22:31:24" {DSK}<Users>larry>medley>SOURCES>LOADUP-FULL.;2 4691
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS LOADUP-FULLCOMS)
|
||||
(FNS LOADUP-FULL)
|
||||
(FILECREATED "15-Jan-2022 15:49:06" {DSK}<home>larry>medley>sources>LOADUP-FULL.;2 4784
|
||||
|
||||
previous date%: "26-Mar-2021 10:47:11" {DSK}<Users>larry>medley>SOURCES>LOADUP-FULL.;1)
|
||||
:CHANGES-TO (FNS LOADUP-FULL)
|
||||
|
||||
:PREVIOUS-DATE "29-Apr-2021 22:31:24" {DSK}<home>larry>medley>sources>LOADUP-FULL.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-FULLCOMS)
|
||||
|
||||
(RPAQQ LOADUP-FULLCOMS ((COMMANDS "cd" "pwd" "ls")
|
||||
(FNS LOADFULLFONTS LOADUP-FULL FIXMETA)
|
||||
(P (FIXMETA))))
|
||||
(FNS LOADFULLFONTS LOADUP-FULL FIXMETA)
|
||||
(P (FIXMETA))))
|
||||
|
||||
(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))
|
||||
(DEFCOMMAND "cd" (DIR)
|
||||
(/CNDIR DIR))
|
||||
|
||||
(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))
|
||||
(DEFCOMMAND "pwd" ()
|
||||
(DIRECTORYNAME T))
|
||||
|
||||
(DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST)))
|
||||
(DEFCOMMAND "ls" (FIRST . REST)
|
||||
(DODIR (CONS FIRST REST)))
|
||||
(DEFINEQ
|
||||
|
||||
(LOADFULLFONTS
|
||||
@@ -47,16 +50,18 @@
|
||||
(PRINTOUT T "FULL fonts loaded" T])
|
||||
|
||||
(LOADUP-FULL
|
||||
[LAMBDA (DOIT) (* ; "Edited 29-Apr-2021 22:27 by rmk:")
|
||||
(* ; "Edited 14-May-2018 15:01 by kaplan")
|
||||
(* ; "Edited 28-Sep-2020 12:35 by rmk:")
|
||||
(* ; "Edited 21-Apr-2018 07:27 by rmk:")
|
||||
[LAMBDA (DOIT) (* ; "Edited 15-Jan-2022 15:48 by larry")
|
||||
(* ; "Edited 29-Apr-2021 22:27 by rmk:")
|
||||
(* ;
|
||||
"Edited 14-May-2018 15:01 by kaplan")
|
||||
(* ; "Edited 28-Sep-2020 12:35 by rmk:")
|
||||
(* ; "Edited 21-Apr-2018 07:27 by rmk:")
|
||||
(* ; "Edited 23-Feb-94 15:04 by bvm")
|
||||
(PROGN (SETQ MEDLEYDIR)
|
||||
(CNDIR (MEDLEYDIR)))
|
||||
(MEDLEY-INIT-VARS)
|
||||
(SETQ MAKESYSFILENAME (MEDLEYDIR "tmp" "full.sysout" T))
|
||||
(SETQ MAKESYSNAME (CONCAT "Medley from Interlisp.org of " (DATE)))
|
||||
(SETQ MAKESYSNAME :MEDLEY)
|
||||
(DRIBBLE (MEDLEYDIR "tmp" "full.dribble" T))
|
||||
|
||||
(* ;; "BKSYSBUF stops page holding ")
|
||||
@@ -67,16 +72,16 @@
|
||||
(DIRECTORYNAME T)
|
||||
T T)
|
||||
(SETQ DEFAULTFILETYPE 'BINARY) (* ;
|
||||
"These prevent bits from being lost due to lack of knowledge")
|
||||
"These prevent bits from being lost due to lack of knowledge")
|
||||
(DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
|
||||
DEFAULTFILETYPELIST)
|
||||
(push DEFAULTFILETYPELIST '(DRIBBLE . TEXT)
|
||||
'(SH . TEXT)
|
||||
'(TXT . TEXT)
|
||||
'(TEXT . TEXT)
|
||||
'(TEX . TEXT)
|
||||
'(HTML . TEXT)
|
||||
'(HTM . TEXT))
|
||||
'(SH . TEXT)
|
||||
'(TXT . TEXT)
|
||||
'(TEXT . TEXT)
|
||||
'(TEX . TEXT)
|
||||
'(HTML . TEXT)
|
||||
'(HTM . TEXT))
|
||||
(LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT")
|
||||
(LOADFULLFONTS)
|
||||
(LISTPUT IDLE.PROFILE 'TIMEOUT 0)
|
||||
@@ -100,6 +105,5 @@
|
||||
|
||||
(FIXMETA)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (685 4653 (LOADFULLFONTS 695 . 2283) (LOADUP-FULL 2285 . 4407) (FIXMETA 4409 . 4651))))
|
||||
)
|
||||
(FILEMAP (NIL (659 4746 (LOADFULLFONTS 669 . 2257) (LOADUP-FULL 2259 . 4500) (FIXMETA 4502 . 4744)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,27 +1,30 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "21-Aug-2021 18:03:35" |{DSK}<home>larry>medley>sources>LOADUP-LISP.;2| 4983
|
||||
|
||||
|changes| |to:| (VARS LOADUP-LISPCOMS)
|
||||
(FILECREATED "15-Jan-2022 15:47:28" |{DSK}<home>larry>medley>sources>LOADUP-LISP.;2| 5105
|
||||
|
||||
|previous| |date:| " 1-Aug-2021 13:16:06" |{DSK}<home>larry>medley>sources>LOADUP-LISP.;1|)
|
||||
:CHANGES-TO (FNS LOADUP-LISP)
|
||||
|
||||
:PREVIOUS-DATE "21-Aug-2021 18:03:35" |{DSK}<home>larry>medley>sources>LOADUP-LISP.;1|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-LISPCOMS)
|
||||
|
||||
(RPAQQ LOADUP-LISPCOMS ((FNS LOADUP-LISP)
|
||||
(INITVARS (FILING.ENUMERATION.DEPTH 1))
|
||||
(FILES MEDLEYDIR)
|
||||
(GLOBALVARS LISPMAKESYSDATE MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR
|
||||
SYSTEMINITVARS USERRECLST)))
|
||||
(INITVARS (FILING.ENUMERATION.DEPTH 1))
|
||||
(FILES MEDLEYDIR)
|
||||
(GLOBALVARS LISPMAKESYSDATE MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR
|
||||
SYSTEMINITVARS USERRECLST)))
|
||||
(DEFINEQ
|
||||
|
||||
(LOADUP-LISP
|
||||
(LAMBDA NIL (* \; "Edited 29-Apr-2021 22:30 by rmk:")
|
||||
(LAMBDA NIL (* \;
|
||||
"Edited 15-Jan-2022 15:47 by larry")
|
||||
(* \; "Edited 29-Apr-2021 22:30 by rmk:")
|
||||
(SETQQ COMPILE.EXT LCOM) (* \; "should be set earlier")
|
||||
(DRIBBLE (MEDLEYDIR "tmp" "lisp.dribble" T))
|
||||
(DRIBBLE (MEDLEYDIR "tmp" "lisp.dribble" T))
|
||||
(FOR X IN BOOTLOADEDFILES DO (CL:UNLESS (MEMB X SYSFILES)
|
||||
(PRINTOUT T X " bootloaded" T)
|
||||
(SETQ SYSFILES (CONS X SYSFILES))))
|
||||
(PRINTOUT T X " bootloaded" T)
|
||||
(SETQ SYSFILES (CONS X SYSFILES))))
|
||||
(SETQ BOOTLOADEDFILES NIL)
|
||||
(IF (NOT (BOUNDP 'DIRECTORIES))
|
||||
THEN (SETQ DIRECTORIES LOADUPDIRECTORIES))
|
||||
@@ -87,7 +90,7 @@
|
||||
(LOADUP '(TIME))
|
||||
(LOADUP '(BRKDWN))
|
||||
(LOADUP '(XCL-EXTRAS)) (*
|
||||
"CMLPACKAGE pushes onto INSPECTMACROS")
|
||||
"CMLPACKAGE pushes onto INSPECTMACROS")
|
||||
(LOADUP '(CMLPACKAGE))
|
||||
|
||||
(* |;;| "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
|
||||
@@ -101,7 +104,7 @@
|
||||
(LOADUP '(PUP 10MBDRIVER LEAF LLETHER DPUPFTP LOCALFILE DSKDISPLAY COURIER LLNS TRSERVER SPP
|
||||
NSPRINT AUTHENTICATION BSP CLEARINGHOUSE NSFILING MAIKOETHER))
|
||||
(DRIBBLE)
|
||||
(SETQ MAKESYSNAME ':LISP)))
|
||||
(SETQ MAKESYSNAME :MEDLEY)))
|
||||
)
|
||||
|
||||
(RPAQ? FILING.ENUMERATION.DEPTH 1)
|
||||
@@ -112,5 +115,5 @@
|
||||
(GLOBALVARS LISPMAKESYSDATE MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (671 4761 (LOADUP-LISP 681 . 4759)))))
|
||||
(FILEMAP (NIL (642 4883 (LOADUP-LISP 652 . 4881)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Nov-2021 22:18:04" {DSK}<home>larry>medley>sources>PRETTY.;2 65400
|
||||
(FILECREATED "19-Jan-2022 20:35:18" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>PRETTY.;23 65357
|
||||
|
||||
:CHANGES-TO (FNS PRINTDATE1)
|
||||
:CHANGES-TO (FNS PRINTDEF1)
|
||||
|
||||
:PREVIOUS-DATE "11-Sep-2021 09:14:19" {DSK}<home>larry>medley>sources>PRETTY.;1)
|
||||
:PREVIOUS-DATE "30-Nov-2021 22:18:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>PRETTY.;21)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -89,7 +90,7 @@ with the terms of said license.
|
||||
PRETTYCOMFONT COMMENTFONT
|
||||
**COMMENT**FLG PRETTYPRINTMACROS]
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (* ;
|
||||
"IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES")
|
||||
"IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES")
|
||||
(FILES (IMPORT)
|
||||
FILEPKG))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP)
|
||||
@@ -418,24 +419,30 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
)
|
||||
|
||||
(PRINTDEF1
|
||||
[LAMBDA (EXPR FORMFLG) (* ; "Edited 16-Apr-2018 21:35 by rmk:")
|
||||
(* ; "Edited 16-Apr-2018 10:14 by rmk:")
|
||||
(* ; "Edited 14-Apr-88 18:21 by bvm")
|
||||
[LAMBDA (EXPR FORMFLG)
|
||||
|
||||
(* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS")
|
||||
(* ;; "Edited 19-Jan-2022 20:35 by rmk: Added DEFMACRO")
|
||||
|
||||
(* ;; "Used by MAKEFILE to print P, etc expressions. ")
|
||||
(* ;; "Edited 16-Apr-2018 21:35 by rmk:")
|
||||
|
||||
(* ;; "Edited 16-Apr-2018 10:14 by rmk:")
|
||||
|
||||
(* ;; "Edited 14-Apr-88 18:21 by bvm")
|
||||
|
||||
(* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS")
|
||||
|
||||
(* ;; "Used by MAKEFILE to print P, etc expressions. ")
|
||||
|
||||
(TERPRI)
|
||||
(LET (STARTPOS ENDPOS)
|
||||
(IF (AND FORMFLG NEWFILEMAP (EQ (CAR EXPR)
|
||||
'CL:DEFUN))
|
||||
(IF [AND FORMFLG NEWFILEMAP (MEMB (CAR EXPR)
|
||||
'(CL:DEFUN DEFMACRO)]
|
||||
THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE)))
|
||||
(PRINTDEF EXPR NIL FORMFLG NIL FNSLST)
|
||||
[IF STARTPOS
|
||||
THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE))
|
||||
(NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR)
|
||||
(CONS STARTPOS ENDPOS]
|
||||
(NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR)
|
||||
(CONS STARTPOS ENDPOS]
|
||||
(TERPRI])
|
||||
|
||||
(SUPERPRINTEQ
|
||||
@@ -629,8 +636,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
|
||||
(RPAQ? COPYRIGHTSRESERVED T)
|
||||
|
||||
(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
|
||||
:XCCS))
|
||||
(RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT
|
||||
:XCCS))
|
||||
|
||||
(RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* )
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -658,8 +665,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
(RPAQ? PRETTYTABFLG T)
|
||||
|
||||
(RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY
|
||||
DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN
|
||||
EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST))
|
||||
DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD
|
||||
EVAL@LOADWHEN FIRST NOTFIRST))
|
||||
|
||||
(RPAQ? AVERAGEVARLENGTH 4)
|
||||
|
||||
@@ -679,8 +686,8 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
|
||||
(RPAQ? PRETTYPRINTYPEMACROS )
|
||||
|
||||
(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS
|
||||
ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *))
|
||||
(RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS
|
||||
APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *))
|
||||
|
||||
(RPAQ? SYSPROPS
|
||||
'(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE
|
||||
@@ -722,14 +729,14 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
(PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018
|
||||
))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5881 48457 (PRETTYDEF 5891 . 21564) (PRETTYDEFCOMS 21566 . 22248) (PRETTYDEF0 22250 .
|
||||
22441) (PRETTYDEF1 22443 . 24206) (PRINTDATE 24208 . 25444) (PRINTDATE1 25446 . 27076) (PRINTFNS 27078
|
||||
. 27647) (PRETTYCOM 27649 . 33990) (PRETTYVAR 33992 . 35030) (PRETTYVAR1 35032 . 37250) (PRETTYCOM1
|
||||
37252 . 37956) (ENDFILE 37958 . 38054) (MAKEDEFLIST 38056 . 38460) (PP 38462 . 38738) (PP* 38740 .
|
||||
39053) (PPT 39055 . 39374) (PRETTYPRINT 39376 . 42528) (PRETTYPRINT1 42530 . 44416) (PRETTYPRINT2
|
||||
44418 . 45734) (PRETTYPRINT3 45736 . 46691) (PRINTDEF1 46693 . 47701) (SUPERPRINTEQ 47703 . 47797) (
|
||||
SUPERPRINTGETPROP 47799 . 47943) (CHANGEFONT 47945 . 48455)) (48458 53804 (READARRAY 48468 . 49394) (
|
||||
PRINTARRAY 49396 . 51136) (READARRAY-FROM-LIST 51138 . 52243) (PRINTARRAY-TO-LIST 52245 . 53802)) (
|
||||
53931 61449 (PRINTCOPYRIGHT 53941 . 58018) (PRINTCOPYRIGHT1 58020 . 61144) (SAVECOPYRIGHT 61146 .
|
||||
61447)))))
|
||||
(FILEMAP (NIL (5927 48431 (PRETTYDEF 5937 . 21610) (PRETTYDEFCOMS 21612 . 22294) (PRETTYDEF0 22296 .
|
||||
22487) (PRETTYDEF1 22489 . 24252) (PRINTDATE 24254 . 25490) (PRINTDATE1 25492 . 27122) (PRINTFNS 27124
|
||||
. 27693) (PRETTYCOM 27695 . 34036) (PRETTYVAR 34038 . 35076) (PRETTYVAR1 35078 . 37296) (PRETTYCOM1
|
||||
37298 . 38002) (ENDFILE 38004 . 38100) (MAKEDEFLIST 38102 . 38506) (PP 38508 . 38784) (PP* 38786 .
|
||||
39099) (PPT 39101 . 39420) (PRETTYPRINT 39422 . 42574) (PRETTYPRINT1 42576 . 44462) (PRETTYPRINT2
|
||||
44464 . 45780) (PRETTYPRINT3 45782 . 46737) (PRINTDEF1 46739 . 47675) (SUPERPRINTEQ 47677 . 47771) (
|
||||
SUPERPRINTGETPROP 47773 . 47917) (CHANGEFONT 47919 . 48429)) (48432 53778 (READARRAY 48442 . 49368) (
|
||||
PRINTARRAY 49370 . 51110) (READARRAY-FROM-LIST 51112 . 52217) (PRINTARRAY-TO-LIST 52219 . 53776)) (
|
||||
53905 61423 (PRINTCOPYRIGHT 53915 . 57992) (PRINTCOPYRIGHT1 57994 . 61118) (SAVECOPYRIGHT 61120 .
|
||||
61421)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
523
sources/UFS
523
sources/UFS
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Apr-2021 11:36:54" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>UFS.;5 69271
|
||||
|
||||
changes to%: (FNS \UFSeol)
|
||||
(FILECREATED "22-Jan-2022 09:06:35" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>UFS.;4 79559
|
||||
|
||||
previous date%: "20-Apr-2021 12:11:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>UFS.;4)
|
||||
:CHANGES-TO (FNS \UFSGenerateFiles \UFS.NEXTFILEFN)
|
||||
|
||||
:PREVIOUS-DATE "22-Jan-2022 08:36:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>UFS.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -19,7 +20,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
|
||||
DIRECTORY FILEIO))
|
||||
(INITVARS (\UFS.DEFAULT.EOLC NIL))
|
||||
(COMS (* ; "Create FDEV function.")
|
||||
(COMS (* ; "Create FDEV function.")
|
||||
(FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice)
|
||||
(INITVARS (\UFSdevice)
|
||||
(\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor")))
|
||||
@@ -27,15 +28,14 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE)))
|
||||
(INITRECORDS UFSGENFILESTATE)
|
||||
(SYSRECORDS UFSGENFILESTATE))
|
||||
(COMS (* ;
|
||||
"UNIX File System's FDEV methods.")
|
||||
(COMS (* ; "UNIX File System's FDEV methods.")
|
||||
(FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile
|
||||
\UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages
|
||||
\UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS
|
||||
\UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP
|
||||
\UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY
|
||||
\UFS.CLEANUP.GFS.TABLE))
|
||||
(COMS (* ; "File Name parsing")
|
||||
(COMS (* ; "File Name parsing")
|
||||
(FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY
|
||||
\UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD
|
||||
\UFS.HANDLE.RELATIVEDIRECTORY)
|
||||
@@ -56,22 +56,22 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
\UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE
|
||||
*DSK-HOST-NAME* *UFS-HOST-NAME*))
|
||||
(COMS
|
||||
(* ;; "Change UNIX Curent Directory")
|
||||
(* ;; "Change UNIX Curent Directory")
|
||||
|
||||
(FNS CHDIR)
|
||||
|
||||
(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.")
|
||||
(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.")
|
||||
|
||||
(FNS \DEVICEFILE.EOSERROR)
|
||||
|
||||
(* ;; "flush/revalidate unvisible stream, like dribble files.")
|
||||
(* ;; "flush/revalidate unvisible stream, like dribble files.")
|
||||
|
||||
(FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS)
|
||||
|
||||
(* ;; " Error handler")
|
||||
(* ;; " Error handler")
|
||||
|
||||
(FNS \UFSError))
|
||||
(COMS (* ; "File Type and EOL handling")
|
||||
(COMS (* ; "File Type and EOL handling")
|
||||
(FNS \UFSGetFileType \UFSSetFileType \UFSeol)
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY)
|
||||
(DEFAULTFILETYPELIST '((NIL . BINARY)
|
||||
@@ -110,11 +110,11 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(VM . BINARY]
|
||||
(GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS))
|
||||
(COMS (* ; "Filetypepatch functions. ")
|
||||
(COMS (* ; "Filetypepatch functions. ")
|
||||
(FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu)
|
||||
(* ; "for hardcopy")
|
||||
(* ; "for hardcopy")
|
||||
(FNS \UFStoOtherCopyMess \UFStoOtherRenameMess)
|
||||
(* ; "for copyfile,renamefile")
|
||||
(* ; "for copyfile,renamefile")
|
||||
(INITVARS (FileTypeConfirmFlg T))
|
||||
(GLOBALVARS FileTypeMenu FileTypeConfirmFlg))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
@@ -166,35 +166,38 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE UFSGENFILESTATE (
|
||||
(* ;;
|
||||
"Holds the file-directory-generator state for %"Unix%" file system enumeration.")
|
||||
(* ;;
|
||||
"Holds the file-directory-generator state for %"Unix%" file system enumeration.")
|
||||
|
||||
(FINFOID FIXP)
|
||||
(FILEID FIXP) (* ;
|
||||
"Current file in list of 1 to TOTALNUM files.")
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS (* ;
|
||||
"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.")
|
||||
CURRENT-DEPTH (* ;
|
||||
"Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH")
|
||||
MAX-DEPTH (* ;
|
||||
"Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.")
|
||||
))
|
||||
(FINFOID FIXP)
|
||||
(FILEID FIXP) (* ;
|
||||
"Current file in list of 1 to TOTALNUM files.")
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS (* ;
|
||||
"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.")
|
||||
CURRENT-DEPTH (* ;
|
||||
"Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH")
|
||||
MAX-DEPTH (* ;
|
||||
"Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.")
|
||||
DEFAULTEXT (* ;
|
||||
"Value of DEFAULTEXT, so we can propagate it through subdirectories")
|
||||
DEFAULTVERS (* ; "Value of DEFAULTVERS")
|
||||
))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'UFSGENFILESTATE
|
||||
'(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP
|
||||
POINTER POINTER POINTER)
|
||||
POINTER POINTER POINTER POINTER POINTER)
|
||||
'((UFSGENFILESTATE 0 FIXP)
|
||||
(UFSGENFILESTATE 2 FIXP)
|
||||
(UFSGENFILESTATE 4 FIXP)
|
||||
@@ -212,8 +215,10 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(UFSGENFILESTATE 26 FIXP)
|
||||
(UFSGENFILESTATE 28 POINTER)
|
||||
(UFSGENFILESTATE 30 POINTER)
|
||||
(UFSGENFILESTATE 32 POINTER))
|
||||
'34)
|
||||
(UFSGENFILESTATE 32 POINTER)
|
||||
(UFSGENFILESTATE 34 POINTER)
|
||||
(UFSGENFILESTATE 36 POINTER))
|
||||
'38)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
@@ -221,7 +226,7 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(/DECLAREDATATYPE 'UFSGENFILESTATE
|
||||
'(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP
|
||||
POINTER POINTER POINTER)
|
||||
POINTER POINTER POINTER POINTER POINTER)
|
||||
'((UFSGENFILESTATE 0 FIXP)
|
||||
(UFSGENFILESTATE 2 FIXP)
|
||||
(UFSGENFILESTATE 4 FIXP)
|
||||
@@ -239,24 +244,26 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
(UFSGENFILESTATE 26 FIXP)
|
||||
(UFSGENFILESTATE 28 POINTER)
|
||||
(UFSGENFILESTATE 30 POINTER)
|
||||
(UFSGENFILESTATE 32 POINTER))
|
||||
'34)
|
||||
(UFSGENFILESTATE 32 POINTER)
|
||||
(UFSGENFILESTATE 34 POINTER)
|
||||
(UFSGENFILESTATE 36 POINTER))
|
||||
'38)
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE UFSGENFILESTATE ((FINFOID FIXP)
|
||||
(FILEID FIXP)
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS CURRENT-DEPTH MAX-DEPTH))
|
||||
(FILEID FIXP)
|
||||
(TOTALNUM FIXP)
|
||||
DIRECTORY DEV (PROPP FLAG)
|
||||
THISFILE
|
||||
(ERRONO FIXP)
|
||||
NAME
|
||||
(LENGTH FIXP)
|
||||
(WDATE FIXP)
|
||||
(RDATE FIXP)
|
||||
(PROTECTION FIXP)
|
||||
AUTHOR
|
||||
(AULEN FIXP)
|
||||
SUBGENERATORS CURRENT-DEPTH MAX-DEPTH DEFAULTEXT DEFAULTVERS))
|
||||
)
|
||||
|
||||
|
||||
@@ -330,12 +337,244 @@ Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(\UFSGenerateFiles
|
||||
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 27-Sep-93 16:17 by jds") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (DEVICE (LISTGET PARSED (QUOTE DEVICE))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) (SETQ FILTER (COND ((STREQUAL DIRECTORY "<") (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" (OR DEVICE "") "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (T (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE DEVICE) DEVICE (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))))) (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) (COND ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR)))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND ((< TOTALNUM 0) (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR)))) (T (COND ((ZEROP TOTALNUM) (RETURN (\NULLFILEGENERATOR))) (T (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN)) CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH))))))))))))
|
||||
)
|
||||
[LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS)
|
||||
|
||||
(* ;;
|
||||
"Edited 22-Jan-2022 09:06 by rmk: Capture current free values of DEFAULTEXT and DEFAULTVERS")
|
||||
|
||||
(* ;; "Edited 27-Sep-93 16:17 by jds")
|
||||
|
||||
(DECLARE (SPECVARS DEFAULTEXT DEFAULTVERS))
|
||||
|
||||
(* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.")
|
||||
|
||||
(WITH.MONITOR (\UFSGetMonitor FDEV)
|
||||
[PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN))
|
||||
(DIRECTORY (OR (LISTGET PARSED 'DIRECTORY)
|
||||
(\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY)
|
||||
FDEV)
|
||||
(\UFS.DEFAULT.DIR FDEV)))
|
||||
(DEVICE (LISTGET PARSED 'DEVICE))
|
||||
(NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN))
|
||||
FILTER LEN)
|
||||
(COND
|
||||
((STREQUAL DIRECTORY "/")
|
||||
(SETQ DIRECTORY "<")))
|
||||
[SETQ FILTER (COND
|
||||
[(STREQUAL DIRECTORY "<")
|
||||
(CONCAT "{" (LISTGET PARSED 'HOST)
|
||||
"}"
|
||||
(OR DEVICE "")
|
||||
"<"
|
||||
(PACKFILENAME.STRING 'NAME (OR (LISTGET PARSED 'NAME)
|
||||
"*")
|
||||
'EXTENSION
|
||||
(OR (LISTGET PARSED 'EXTENSION)
|
||||
"*")
|
||||
'VERSION
|
||||
(OR (LISTGET PARSED 'VERSION)
|
||||
"*"]
|
||||
(T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET
|
||||
PARSED
|
||||
'HOST)
|
||||
'DEVICE DEVICE 'NAME (OR (LISTGET PARSED 'NAME)
|
||||
"*")
|
||||
'EXTENSION
|
||||
(OR (LISTGET PARSED 'EXTENSION)
|
||||
"*")
|
||||
'VERSION
|
||||
(OR (LISTGET PARSED 'VERSION)
|
||||
"*"]
|
||||
(SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "")
|
||||
DIRECTORY)
|
||||
NAMEAREA FDEV))
|
||||
[COND
|
||||
((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case")
|
||||
(PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory")
|
||||
(RETURN (\NULLFILEGENERATOR]
|
||||
(SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN))
|
||||
|
||||
(* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.")
|
||||
|
||||
(LET ((ID (CREATECELL \FIXP))
|
||||
(ERRNO (CREATECELL \FIXP))
|
||||
(PROPP (\UFS.VALID.PROPP DESIREDPROPS))
|
||||
TOTALNUM)
|
||||
(SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO))
|
||||
(COND
|
||||
[(< TOTALNUM 0)
|
||||
(OR (\UFSError DIRECTORY ERRNO FDEV)
|
||||
(RETURN (\NULLFILEGENERATOR]
|
||||
(T (COND
|
||||
((ZEROP TOTALNUM)
|
||||
(RETURN (\NULLFILEGENERATOR)))
|
||||
(T [AND (OR (AND (NOT (LISTP OPTIONS))
|
||||
(EQ OPTIONS 'RESETLST))
|
||||
(FMEMB 'RESETLST OPTIONS))
|
||||
(RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID]
|
||||
(RETURN (create FILEGENOBJ
|
||||
NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN)
|
||||
FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN)
|
||||
GENFILESTATE _
|
||||
(\UFS.REGISTER.GFS (create UFSGENFILESTATE
|
||||
FINFOID _ ID
|
||||
FILEID _ 0
|
||||
TOTALNUM _ TOTALNUM
|
||||
DIRECTORY _ DIRECTORY
|
||||
DEV _ FDEV
|
||||
PROPP _ PROPP
|
||||
NAME _ (ALLOCSTRING
|
||||
MAX-PATHNAME-LEN
|
||||
)
|
||||
AUTHOR _ (AND PROPP
|
||||
(ALLOCSTRING
|
||||
MAX-UNAME-LEN
|
||||
))
|
||||
CURRENT-DEPTH _ 1
|
||||
MAX-DEPTH _
|
||||
FILING.ENUMERATION.DEPTH
|
||||
DEFAULTEXT _ DEFAULTEXT
|
||||
DEFAULTVERS _ DEFAULTVERS])])
|
||||
|
||||
(\UFS.NEXTFILEFN
|
||||
(LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE))) (DECLARE (SPECVARS FILEGROUP)) (COND (SUBGEN (* ;; "We're in a sub-directory.") (LET (FILENAME NAMELEN NEWWNAME FILEGROUP) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))))) (T (* ;; "Not in a sub-directory, so act directly on the top-level generator.") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (QUOTE *)) (DEFAULTVERS (QUOTE *)) (DESIREDPROPS (COND ((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (QUOTE (SIZE CREATIONDATE AUTHOR))) (T NIL)))) (DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS)) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (COND ((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))) (COND ((= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T)) (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))) (COND ((AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) T) (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE) (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))) (IEQP (CHARCODE >) (NTHCHARCODE FILENAME (NCHARS FILENAME))) (DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP))) (* ;; "It's a directory, so let's recurse into it.") (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))) (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE))) (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)))) (T (COND (NAMEONLY NEWNAME) (T FILENAME)))))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))))))))
|
||||
)
|
||||
[LAMBDA (GENFILESTATE NAMEONLY)
|
||||
|
||||
(* ;;
|
||||
"Edited 22-Jan-2022 09:05 by rmk: Bind DEFAULTEXT and DEFAULTVERS to values in GENFILESTATE")
|
||||
|
||||
(* ;; "Edited 7-Oct-93 14:31 by jds")
|
||||
|
||||
(* ;; "Given a UFS filesystem generator, return the %"next%" file in line.")
|
||||
|
||||
(LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE)))
|
||||
(DECLARE (SPECVARS FILEGROUP))
|
||||
(COND
|
||||
[SUBGEN
|
||||
|
||||
(* ;; "We're in a sub-directory.")
|
||||
|
||||
(LET (FILENAME NAMELEN NEWWNAME FILEGROUP)
|
||||
(SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY))
|
||||
(COND
|
||||
(FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE)
|
||||
(replace (UFSGENFILESTATE LENGTH) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE RDATE) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE RDATE) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE WDATE) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE WDATE) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AULEN) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AULEN) of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN)))
|
||||
FILENAME)
|
||||
(T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL)
|
||||
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY]
|
||||
(T
|
||||
(* ;; "Not in a sub-directory, so act directly on the top-level generator.")
|
||||
|
||||
(LET* [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))
|
||||
(FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE))
|
||||
(ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE)))
|
||||
FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (FETCH (UFSGENFILESTATE
|
||||
DEFAULTEXT)
|
||||
OF GENFILESTATE))
|
||||
(DEFAULTVERS (FETCH (UFSGENFILESTATE DEFAULTVERS) OF GENFILESTATE))
|
||||
(DESIREDPROPS (COND
|
||||
((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE)
|
||||
'(SIZE CREATIONDATE AUTHOR))
|
||||
(T NIL]
|
||||
(DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS))
|
||||
(AND (> FINFOID -1)
|
||||
(< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
|
||||
(CL:UNWIND-PROTECT
|
||||
[COND
|
||||
((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE))
|
||||
0)
|
||||
[replace (UFSGENFILESTATE THISFILE) of GENFILESTATE
|
||||
with (SETQ FILENAME (\UFS.FULLNAME.M
|
||||
(fetch (UFSGENFILESTATE DIRECTORY)
|
||||
of GENFILESTATE)
|
||||
(SETQ NEWNAME (CL:SUBSEQ
|
||||
(fetch (UFSGENFILESTATE
|
||||
NAME) of
|
||||
GENFILESTATE
|
||||
)
|
||||
0 NAMELEN))
|
||||
(fetch (UFSGENFILESTATE DEV) of
|
||||
GENFILESTATE
|
||||
]
|
||||
(COND
|
||||
((= (add FILEID 1)
|
||||
(fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))
|
||||
(* ; "Generator exhausted. ")
|
||||
(\UFS.UNREGISTER.GFS GENFILESTATE T))
|
||||
(T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE
|
||||
with FILEID)))
|
||||
(COND
|
||||
[(AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH)
|
||||
of GENFILESTATE)
|
||||
T)
|
||||
(ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH
|
||||
) of GENFILESTATE)
|
||||
(fetch (UFSGENFILESTATE MAX-DEPTH)
|
||||
of GENFILESTATE)))
|
||||
(IEQP (CHARCODE >)
|
||||
(NTHCHARCODE FILENAME (NCHARS FILENAME)))
|
||||
(DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE)
|
||||
of GENFILESTATE))
|
||||
(fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))
|
||||
|
||||
(* ;; "It's a directory, so let's recurse into it.")
|
||||
|
||||
[replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE
|
||||
with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE)
|
||||
of (CAR FILEGROUP]
|
||||
(replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN
|
||||
with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH)
|
||||
of GENFILESTATE)))
|
||||
(replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN
|
||||
with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))
|
||||
(SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY))
|
||||
(COND
|
||||
(FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP)
|
||||
of GENFILESTATE)
|
||||
(replace (UFSGENFILESTATE LENGTH) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE LENGTH)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE RDATE) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE RDATE)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE WDATE) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE WDATE)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE PROTECTION)
|
||||
of GENFILESTATE with (fetch (
|
||||
UFSGENFILESTATE
|
||||
PROTECTION)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AULEN) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AULEN)
|
||||
of SUBGEN))
|
||||
(replace (UFSGENFILESTATE AUTHOR) of
|
||||
GENFILESTATE
|
||||
with (fetch (UFSGENFILESTATE AUTHOR)
|
||||
of SUBGEN)))
|
||||
FILENAME)
|
||||
(NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of
|
||||
GENFILESTATE
|
||||
with NIL)
|
||||
(\UFS.NEXTFILEFN GENFILESTATE NAMEONLY]
|
||||
(T (COND
|
||||
(NAMEONLY NEWNAME)
|
||||
(T FILENAME]
|
||||
(AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))])
|
||||
|
||||
(\UFS.FILEINFOFN
|
||||
(LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T)))))
|
||||
@@ -574,7 +813,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
\UFS.DIRECTORY.RECOGNIZER DSKP)
|
||||
(RECORDS UFSSTREAM NAME&ALLPROPS)
|
||||
|
||||
(* ;; "File attribute code. For interface between Cfunc and LISPfunc.")
|
||||
(* ;; "File attribute code. For interface between Cfunc and LISPfunc.")
|
||||
|
||||
(CONSTANTS (ATTR-LENGTH 1)
|
||||
(ATTR-WDATE 2)
|
||||
@@ -585,7 +824,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(ATTR-EOL 7)
|
||||
(ATTR-ALL 8))
|
||||
|
||||
(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.")
|
||||
(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.")
|
||||
|
||||
(CONSTANTS (RECOG-OLD 0)
|
||||
(RECOG-OLDEST 1)
|
||||
@@ -594,7 +833,7 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(RECOG-OTHER 4)
|
||||
(RECOG-NON 5))
|
||||
|
||||
(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.")
|
||||
(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.")
|
||||
|
||||
(CONSTANTS (ACCESS-INPUT 0)
|
||||
(ACCESS-OUTPUT 1)
|
||||
@@ -602,95 +841,93 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(ACCESS-APPEND 3)
|
||||
(ACCESS-OTHER 4))
|
||||
|
||||
(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.")
|
||||
(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.")
|
||||
|
||||
(CONSTANTS (MAX-UNAME-LEN 512))
|
||||
|
||||
(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.")
|
||||
(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.")
|
||||
|
||||
(CONSTANTS (MAX-PATHNAME-LEN 256))
|
||||
(FILES (LOADCOMP)
|
||||
PMAP)
|
||||
(* ; "For \devicefile.eoserror")))
|
||||
(* ; "For \devicefile.eoserror")))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \UFS.FULLNAME.M MACRO [LAMBDA (DIR NAME DEV ATOMP)
|
||||
(DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*))
|
||||
(DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*))
|
||||
|
||||
(* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.")
|
||||
(* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.")
|
||||
|
||||
(COND
|
||||
(NAME (* ; "Pass NIL thru transparently")
|
||||
(COND
|
||||
[(DSKP DEV)
|
||||
(SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME))
|
||||
(COND
|
||||
[*DSK-UPPER-CASE-FILE-NAMES*
|
||||
|
||||
(* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.")
|
||||
|
||||
(COND
|
||||
(NAME (* ; "Pass NIL thru transparently")
|
||||
(COND
|
||||
[(DSKP DEV)
|
||||
(SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME))
|
||||
(COND
|
||||
[*DSK-UPPER-CASE-FILE-NAMES*
|
||||
|
||||
(* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.")
|
||||
|
||||
(COND
|
||||
(ATOMP (MKATOM (U-CASE NAME)))
|
||||
(T (U-CASE NAME]
|
||||
(T (COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME]
|
||||
(T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME)
|
||||
)
|
||||
(COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME])
|
||||
(ATOMP (MKATOM (U-CASE NAME)))
|
||||
(T (U-CASE NAME]
|
||||
(T (COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME]
|
||||
(T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME))
|
||||
(COND
|
||||
(ATOMP (MKATOM NAME))
|
||||
(T NAME])
|
||||
|
||||
(PUTPROPS \UFSGetMonitor MACRO ((DEV)
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSKtopMonitor)
|
||||
(UNIX \UFStopMonitor)
|
||||
NIL)))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSKtopMonitor)
|
||||
(UNIX \UFStopMonitor)
|
||||
NIL)))
|
||||
|
||||
(PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV)
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSK.DEFAULT.DIRECTORY)
|
||||
(UNIX \UFS.DEFAULT.DIRECTORY)
|
||||
NIL)))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK \DSK.DEFAULT.DIRECTORY)
|
||||
(UNIX \UFS.DEFAULT.DIRECTORY)
|
||||
NIL)))
|
||||
|
||||
(PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV)
|
||||
|
||||
(* ;;
|
||||
"Return a function that will do name recognition for this device")
|
||||
(* ;;
|
||||
"Return a function that will do name recognition for this device")
|
||||
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK (FUNCTION \DSKGetFileName-C))
|
||||
(UNIX (FUNCTION \UFSGetFileName-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK (FUNCTION \DSKGetFileName-C))
|
||||
(UNIX (FUNCTION \UFSGetFileName-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
|
||||
(PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV)
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of
|
||||
DEV)
|
||||
(DSK (FUNCTION \DSKDirectoryNameP-C))
|
||||
(UNIX (FUNCTION \UFSDirectoryNameP-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
(SELECTQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
(DSK (FUNCTION \DSKDirectoryNameP-C))
|
||||
(UNIX (FUNCTION \UFSDirectoryNameP-C))
|
||||
(FUNCTION SHOULDNT))))
|
||||
|
||||
(PUTPROPS DSKP MACRO ((DEV)
|
||||
(EQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
'DSK)))
|
||||
(EQ (fetch (FDEV DEVICENAME) of DEV)
|
||||
'DSK)))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS UFSSTREAM (
|
||||
(* ;;
|
||||
"Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.")
|
||||
(* ;;
|
||||
"Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.")
|
||||
|
||||
(FILEID (fetch F1 of DATUM)
|
||||
(REPLACE F1 OF DATUM WITH NEWVALUE))
|
||||
(* ; "Unix file handle")
|
||||
(CDATE (fetch F2 of DATUM)
|
||||
(REPLACE F2 OF DATUM WITH NEWVALUE))
|
||||
(* ; "IDate given to openstream")
|
||||
(UNIXNAME (fetch F5 of DATUM)
|
||||
(REPLACE F5 OF DATUM WITH NEWVALUE))
|
||||
(* ;
|
||||
"The name by which Unix knows this file")
|
||||
))
|
||||
(FILEID (fetch F1 of DATUM)
|
||||
(REPLACE F1 OF DATUM WITH NEWVALUE))
|
||||
(* ; "Unix file handle")
|
||||
(CDATE (fetch F2 of DATUM)
|
||||
(REPLACE F2 OF DATUM WITH NEWVALUE))
|
||||
(* ; "IDate given to openstream")
|
||||
(UNIXNAME (fetch F5 of DATUM)
|
||||
(REPLACE F5 OF DATUM WITH NEWVALUE))
|
||||
(* ;
|
||||
"The name by which Unix knows this file")
|
||||
))
|
||||
|
||||
(RECORD NAME&ALLPROPS (NAME . ALLPROPS))
|
||||
)
|
||||
@@ -876,23 +1113,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap
|
||||
(PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000 2021
|
||||
))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (8248 9801 (\UFSCreateDevice 8258 . 8623) (\UFS.CREATE.DEVICE 8625 . 9481) (
|
||||
\UFSOpenDevice 9483 . 9660) (\UFSCloseDevice 9662 . 9799)) (13962 41872 (\UFSOpenFile 13972 . 17266) (
|
||||
\UFS.OPENP 17268 . 17765) (\UFS.RECOGNIZE.FILE 17767 . 18520) (\UFS.DIRECTORY.NAME 18522 . 19265) (
|
||||
\UFSCloseFile 19267 . 20243) (\UFSGetFileName 20245 . 20444) (\UFSDeleteFile 20446 . 20986) (
|
||||
\UFSRenameFile 20988 . 22153) (\UFSReadPages 22155 . 23290) (\UFSWritePages 23292 . 24512) (
|
||||
\UFSTruncateFile 24514 . 26011) (\UFSDirectoryNameP 26013 . 27067) (\UFSEventFn 27069 . 27731) (
|
||||
\UFSGetFileInfo 27733 . 30015) (\UFS.CREATE.PROPS 30017 . 30370) (\UFSSetFileInfo 30372 . 31601) (
|
||||
\UFSGenerateFiles 31603 . 34315) (\UFS.NEXTFILEFN 34317 . 38460) (\UFS.FILEINFOFN 38462 . 39911) (
|
||||
\UFS.VALID.PROPP 39913 . 40205) (\UFS.REGISTER.GFS 40207 . 40462) (\UFS.UNREGISTER.GFS 40464 . 41047)
|
||||
(\UFS.ABORT.DIRECTORY 41049 . 41397) (\UFS.ABORT.CL-DIRECTORY 41399 . 41686) (\UFS.CLEANUP.GFS.TABLE
|
||||
41688 . 41870)) (41907 48591 (\UFSMakeUnixFormatName 41917 . 42938) (\UFSParseNameString 42940 . 43314
|
||||
) (\UFSParse-Directory 43316 . 43857) (\UFS.PARSE.BODY 43859 . 44404) (\UFS.ADJUST.HOST 44406 . 44565)
|
||||
(\UFS.FULLNAME 44567 . 45775) (\UFS.ADD.HOST.FIELD 45777 . 46137) (\UFS.REMOVE.HOST.FIELD 46139 .
|
||||
47809) (\UFS.HANDLE.RELATIVEDIRECTORY 47811 . 48589)) (49407 50020 (CHDIR 49417 . 50018)) (50092 51078
|
||||
(\DEVICEFILE.EOSERROR 50102 . 51076)) (51151 52388 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51161 . 52006)
|
||||
(\UNVISIBLE.FLUSH.OPEN.STREAMS 52008 . 52386)) (52421 54047 (\UFSError 52431 . 54045)) (54091 56338 (
|
||||
\UFSGetFileType 54101 . 54702) (\UFSSetFileType 54704 . 55133) (\UFSeol 55135 . 56336)) (65950 67074 (
|
||||
\UFSGetPrintFileType 65960 . 66372) (\UFSGetFileTypeConfirm 66374 . 66822) (\UFSPrintTypeMenu 66824 .
|
||||
67072)) (67104 68852 (\UFStoOtherCopyMess 67114 . 68105) (\UFStoOtherRenameMess 68107 . 68850)))))
|
||||
(FILEMAP (NIL (8206 9759 (\UFSCreateDevice 8216 . 8581) (\UFS.CREATE.DEVICE 8583 . 9439) (
|
||||
\UFSOpenDevice 9441 . 9618) (\UFSCloseDevice 9620 . 9757)) (14300 52622 (\UFSOpenFile 14310 . 17604) (
|
||||
\UFS.OPENP 17606 . 18103) (\UFS.RECOGNIZE.FILE 18105 . 18858) (\UFS.DIRECTORY.NAME 18860 . 19603) (
|
||||
\UFSCloseFile 19605 . 20581) (\UFSGetFileName 20583 . 20782) (\UFSDeleteFile 20784 . 21324) (
|
||||
\UFSRenameFile 21326 . 22491) (\UFSReadPages 22493 . 23628) (\UFSWritePages 23630 . 24850) (
|
||||
\UFSTruncateFile 24852 . 26349) (\UFSDirectoryNameP 26351 . 27405) (\UFSEventFn 27407 . 28069) (
|
||||
\UFSGetFileInfo 28071 . 30353) (\UFS.CREATE.PROPS 30355 . 30708) (\UFSSetFileInfo 30710 . 31939) (
|
||||
\UFSGenerateFiles 31941 . 38373) (\UFS.NEXTFILEFN 38375 . 49210) (\UFS.FILEINFOFN 49212 . 50661) (
|
||||
\UFS.VALID.PROPP 50663 . 50955) (\UFS.REGISTER.GFS 50957 . 51212) (\UFS.UNREGISTER.GFS 51214 . 51797)
|
||||
(\UFS.ABORT.DIRECTORY 51799 . 52147) (\UFS.ABORT.CL-DIRECTORY 52149 . 52436) (\UFS.CLEANUP.GFS.TABLE
|
||||
52438 . 52620)) (52657 59341 (\UFSMakeUnixFormatName 52667 . 53688) (\UFSParseNameString 53690 . 54064
|
||||
) (\UFSParse-Directory 54066 . 54607) (\UFS.PARSE.BODY 54609 . 55154) (\UFS.ADJUST.HOST 55156 . 55315)
|
||||
(\UFS.FULLNAME 55317 . 56525) (\UFS.ADD.HOST.FIELD 56527 . 56887) (\UFS.REMOVE.HOST.FIELD 56889 .
|
||||
58559) (\UFS.HANDLE.RELATIVEDIRECTORY 58561 . 59339)) (60157 60770 (CHDIR 60167 . 60768)) (60842 61828
|
||||
(\DEVICEFILE.EOSERROR 60852 . 61826)) (61901 63138 (\UNVISIBLE.PAGED.REVALIDATEFILELST 61911 . 62756)
|
||||
(\UNVISIBLE.FLUSH.OPEN.STREAMS 62758 . 63136)) (63171 64797 (\UFSError 63181 . 64795)) (64841 67088 (
|
||||
\UFSGetFileType 64851 . 65452) (\UFSSetFileType 65454 . 65883) (\UFSeol 65885 . 67086)) (76238 77362 (
|
||||
\UFSGetPrintFileType 76248 . 76660) (\UFSGetFileTypeConfirm 76662 . 77110) (\UFSPrintTypeMenu 77112 .
|
||||
77360)) (77392 79140 (\UFStoOtherCopyMess 77402 . 78393) (\UFStoOtherRenameMess 78395 . 79138)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/UFS.LCOM
BIN
sources/UFS.LCOM
Binary file not shown.
Reference in New Issue
Block a user