Compare commits
19 Commits
medley-220
...
medley-220
| Author | SHA1 | Date | |
|---|---|---|---|
|
b791bff070 | ||
|
|
ab8e97ff7b | ||
|
f8e4bbd7cb | ||
|
c7272e78f2 | ||
|
|
f531e89dde | ||
|
|
293c973f1d | ||
|
|
fe62e8e6e2 | ||
|
|
51f0c19ad1 | ||
|
|
1438ddba1f | ||
|
|
ae3851ccf9 | ||
|
|
e3f9a4ca9a | ||
|
|
7966704f1e | ||
|
|
311e4f049c | ||
|
|
e119314a9e | ||
|
|
27d4df45e6 | ||
|
|
312e99b0f4 | ||
|
|
82eaacc542 | ||
|
|
479de87011 | ||
|
|
5445a12b7e |
@@ -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,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.
@@ -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 " 1-Jan-2022 23:55:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;31 189222
|
||||
(FILECREATED "21-Jan-2022 23:14:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;32 189300
|
||||
|
||||
:CHANGES-TO (FNS TEDIT.CREATEW)
|
||||
:CHANGES-TO (FNS TEDIT.GETINPUT)
|
||||
|
||||
:PREVIOUS-DATE " 1-Jan-2022 17:37:20"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;30)
|
||||
:PREVIOUS-DATE " 1-Jan-2022 23:55:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;31)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -1471,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.")
|
||||
@@ -1487,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
|
||||
@@ -2874,25 +2874,25 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(PUTPROPS TEDITWINDOW COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988
|
||||
1989 1990 1991 1993 1994 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7220 95654 (TEDIT.CREATEW 7230 . 9984) (\TEDIT.CREATEW.FROM.REGION 9986 . 10970) (
|
||||
TEDIT.CURSORMOVEDFN 10972 . 22358) (TEDIT.CURSOROUTFN 22360 . 22895) (TEDIT.WINDOW.SETUP 22897 . 24706
|
||||
) (TEDIT.MINIMAL.WINDOW.SETUP 24708 . 32497) (\TEDIT.ACTIVE.WINDOWP 32499 . 33480) (
|
||||
\TEDIT.BUTTONEVENTFN 33482 . 58472) (\TEDIT.WINDOW.OPS 58474 . 62435) (\TEDIT.EXPANDFN 62437 . 62840)
|
||||
(\TEDIT.MAINW 62842 . 64131) (\TEDIT.PRIMARYW 64133 . 65345) (\TEDIT.COPYINSERTFN 65347 . 66318) (
|
||||
\TEDIT.NEWREGIONFN 66320 . 68787) (\TEDIT.SET.WINDOW.EXTENT 68789 . 74891) (\TEDIT.SHRINK.ICONCREATE
|
||||
74893 . 77165) (\TEDIT.SHRINKFN 77167 . 77742) (\TEDIT.SPLITW 77744 . 83845) (\TEDIT.UNSPLITW 83847 .
|
||||
89541) (\TEDIT.WINDOW.SETUP 89543 . 95263) (\SAFE.FIRST 95265 . 95652)) (96984 97891 (TEDITWINDOWP
|
||||
96994 . 97889)) (97928 100424 (TEDIT.GETINPUT 97938 . 99921) (\TEDIT.MAKEFILENAME 99923 . 100422)) (
|
||||
100473 106924 (TEDIT.PROMPTPRINT 100483 . 103387) (TEDIT.PROMPTFLASH 103389 . 105344) (
|
||||
\TEDIT.PROMPT.PAGEFULLFN 105346 . 106922)) (107159 111152 (TEXTSTREAM.TITLE 107169 . 107790) (
|
||||
\TEDIT.ORIGINAL.WINDOW.TITLE 107792 . 109768) (\TEDIT.WINDOW.TITLE 109770 . 110440) (
|
||||
\TEXTSTREAM.FILENAME 110442 . 111150)) (111195 156094 (TEDIT.DEACTIVATE.WINDOW 111205 . 118512) (
|
||||
\TEDIT.REPAINTFN 118514 . 121371) (\TEDIT.RESHAPEFN 121373 . 126993) (\TEDIT.SCROLLFN 126995 . 156092)
|
||||
) (156136 158185 (\TEDIT.PROCIDLEFN 156146 . 157495) (\TEDIT.PROCENTRYFN 157497 . 157790) (
|
||||
\TEDIT.PROCEXITFN 157792 . 158183)) (158264 169264 (\EDIT.DOWNCARET 158274 . 158955) (\EDIT.FLIPCARET
|
||||
158957 . 160492) (TEDIT.FLASHCARET 160494 . 161608) (\EDIT.UPCARET 161610 . 162063) (
|
||||
TEDIT.NORMALIZECARET 162065 . 168016) (\SETCARET 168018 . 168938) (\TEDIT.CARET 168940 . 169262)) (
|
||||
169298 183053 (TEDIT.ADD.MENUITEM 169308 . 171223) (TEDIT.DEFAULT.MENUFN 171225 . 180492) (
|
||||
TEDIT.REMOVE.MENUITEM 180494 . 181495) (\TEDIT.CREATEMENU 181497 . 181950) (\TEDIT.MENU.WHENHELDFN
|
||||
181952 . 182722) (\TEDIT.MENU.WHENSELECTEDFN 182724 . 183051)))))
|
||||
(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.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Dec-2021 18:22:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;116 100755
|
||||
(FILECREATED "27-Jan-2022 17:47:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;160 112621
|
||||
|
||||
:CHANGES-TO (FNS CD-MENUFN)
|
||||
:CHANGES-TO (FNS CD.COMMANDSELECTEDFN)
|
||||
|
||||
:PREVIOUS-DATE "25-Dec-2021 12:59:47"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;114)
|
||||
:PREVIOUS-DATE "26-Jan-2022 15:33:55"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPAREDIRECTORIES.;159)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -19,11 +19,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(
|
||||
(* ;; "Compare the contents of two directories.")
|
||||
|
||||
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME
|
||||
CD.INSURECDVALUE CD.UPDATEWIDTHS)
|
||||
(FNS COMPAREDIRECTORIES COMPAREDIRECTORIES.INFOS CDENTRIES.SELECT
|
||||
COMPAREDIRECTORIES.INFOS.TYPE MATCHNAME CD.INSURECDVALUE CD.UPDATEWIDTHS)
|
||||
(FNS CDFILES CDFILES.MATCH CDFILES.PATS)
|
||||
(FNS CDPRINT CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS CDTEDIT)
|
||||
(FNS CDMAP CDENTRY CDSUBSET)
|
||||
(FNS CDPRINT CDPRINT.HEADER CDPRINT.LINE CDPRINT.MAXWIDTHS CDPRINT.COLHEADERS CDPRINT.COLUMNS
|
||||
CDTEDIT)
|
||||
(FNS CDMAP CDENTRY CDSUBSET CDMERGE CDMERGE.COMMON)
|
||||
(FNS BINCOMP EOLTYPE EOLTYPE.SHOW)
|
||||
(RECORDS CDVALUE CDENTRY CDINFO CDMAXNCHARS)
|
||||
|
||||
@@ -63,13 +64,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(COMPAREDIRECTORIES
|
||||
[LAMBDA (DIR1 DIR2 SELECT INCLUDEDFILES EXCLUDEDFILES USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS
|
||||
FIXDIRECTORYDATES) (* ; "Edited 23-Dec-2021 18:59 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 20:07 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 13:51 by rmk:")
|
||||
(* ; "Edited 23-Nov-2021 12:57 by rmk:")
|
||||
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
|
||||
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
|
||||
(* ; "Edited 7-Jan-2021 23:21 by rmk:")
|
||||
FIXDIRECTORYDATES) (* ; "Edited 26-Jan-2022 13:33 by rmk")
|
||||
(* ; "Edited 4-Jan-2022 12:09 by rmk")
|
||||
(* ; "Edited 31-Oct-2021 11:01 by rmk:")
|
||||
(* ; "Edited 7-Jan-2021 23:21 by rmk:")
|
||||
|
||||
(* ;; "Compare the contents of two directories, e.g., for change-control purposes. Compares files matching FILEPATTERN (or *.*;) on DIR1 and DIR2, listing which is newer, or when one is not found on the other. If SELECT is or contains SAME/=, BEFORE/<, AFTER/>, then files where DIR1 is the same as, earlier than, or later than DIR2 are selected. SELECT= NIL is the same as (< >), T is the same as (< > =). Also allows selection based on file-length criteria.")
|
||||
|
||||
@@ -96,8 +94,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(*- '*-)
|
||||
(~= '~=)
|
||||
(ERROR "UNRECOGNIZED SELECT PARAMETER" S]
|
||||
(PROG (INFOS1 INFOS2 CANDIDATES CDENTRIES COMPAREDATE DEPTH1 DEPTH2 CDVALUE)
|
||||
[SETQ COMPAREDATE (INTERSECTION SELECT '(< > =]
|
||||
(PROG (INFOS1 INFOS2 CANDIDATES CDENTRIES DEPTH1 DEPTH2 CDVALUE (DATE (DATE)))
|
||||
|
||||
(* ;; "DIRECTORYNAME here to get unrelativized specifications for header.")
|
||||
|
||||
@@ -117,8 +114,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(PRINTOUT T "Fixing directory dates" T)
|
||||
(FIX-DIRECTORY-DATES DIR1)
|
||||
(FIX-DIRECTORY-DATES DIR2))
|
||||
(PRINTOUT T "Comparing " DIR1 6 "vs. " DIR2 T "as of " (DATE)
|
||||
" selecting " SELECT " ... ")
|
||||
(CDPRINT.HEADER DIR1 DIR2 SELECT DATE T)
|
||||
(PRINTOUT T " ... ")
|
||||
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS (CDFILES DIR1 INCLUDEDFILES EXCLUDEDFILES
|
||||
ALLVERSIONS DEPTH1)
|
||||
USEDIRECTORYDATE DIR1))
|
||||
@@ -128,7 +125,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(SETQ CDVALUE (CREATE CDVALUE
|
||||
CDDIR1 _ DIR1
|
||||
CDDIR2 _ DIR2
|
||||
CDCOMPAREDATE _ (DATE)
|
||||
CDCOMPAREDATE _ DATE
|
||||
CDSELECT _ SELECT))
|
||||
(CL:UNLESS (OR INFOS2 INFOS1)
|
||||
(RETURN CDVALUE))
|
||||
@@ -166,58 +163,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(* ;; "Do the SELECT filtering and insert the date relation.")
|
||||
|
||||
[SETQ CDENTRIES
|
||||
(for C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP in CANDIDATES
|
||||
eachtime (SETQ MATCHNAME (pop C))
|
||||
(SETQ INFO1 (pop C))
|
||||
(SETQ INFO2 (pop C))
|
||||
(if (AND INFO1 INFO2)
|
||||
then (SETQ IDATE1 (IDATE (fetch DATE of INFO1)))
|
||||
(SETQ IDATE2 (IDATE (fetch DATE of INFO2)))
|
||||
(SETQ DATEREL (if (IGREATERP IDATE1 IDATE2)
|
||||
then '>
|
||||
elseif (ILESSP IDATE1 IDATE2)
|
||||
then '<
|
||||
else '=))
|
||||
else
|
||||
(* ;; "Just for printing--no comparison")
|
||||
|
||||
(SETQ DATEREL '*))
|
||||
when (if (AND INFO1 INFO2)
|
||||
then (CL:WHEN (OR (NULL COMPAREDATE)
|
||||
(SELECTQ DATEREL
|
||||
(> (MEMB '> SELECT))
|
||||
(< (MEMB '< SELECT))
|
||||
(= (MEMB '= SELECT))
|
||||
(SHOULDNT)))
|
||||
(SETQ BINCOMP (BINCOMP (fetch (CDINFO FULLNAME) OF INFO1)
|
||||
(fetch (CDINFO FULLNAME) OF INFO2)
|
||||
T
|
||||
(fetch (CDINFO EOL) OF INFO1)
|
||||
(fetch (CDINFO EOL) OF INFO2)))
|
||||
|
||||
(* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.")
|
||||
|
||||
[NOT (AND (MEMB '~= SELECT)
|
||||
BINCOMP
|
||||
(EQ (fetch (CDINFO EOL) OF INFO1)
|
||||
(fetch (CDINFO EOL) OF INFO2])
|
||||
elseif INFO1
|
||||
then
|
||||
(* ;; "OK if INFO2 is missing?")
|
||||
|
||||
(MEMB '*- SELECT)
|
||||
else
|
||||
(* ;; "OK if INFO1 is missing?")
|
||||
|
||||
(MEMB '-* SELECT))
|
||||
collect (create CDENTRY
|
||||
MATCHNAME _ MATCHNAME
|
||||
INFO1 _ INFO1
|
||||
DATEREL _ DATEREL
|
||||
INFO2 _ INFO2
|
||||
EQUIV _ (CL:UNLESS (EQ DATEREL '*)
|
||||
BINCOMP]
|
||||
(SETQ CDENTRIES (CDENTRIES.SELECT CANDIDATES SELECT))
|
||||
(PRINTOUT T (LENGTH CDENTRIES)
|
||||
" entries" T)
|
||||
(REPLACE CDENTRIES OF CDVALUE WITH CDENTRIES)
|
||||
@@ -227,37 +173,118 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(RETURN (CDPRINT CDVALUE OUTPUTFILE NIL (MEMB 'AUTHOR SELECT])
|
||||
|
||||
(COMPAREDIRECTORIES.INFOS
|
||||
[LAMBDA (FILES USEDIRECTORYDATE DIR) (* ; "Edited 23-Dec-2021 18:59 by rmk")
|
||||
[LAMBDA (FILES USEDIRECTORYDATE DIR) (* ; "Edited 4-Jan-2022 15:23 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 18:59 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(* ; "Edited 23-Nov-2021 12:27 by rmk:")
|
||||
(* ; "Edited 13-Oct-2020 08:42 by rmk:")
|
||||
|
||||
(* ;; "Value is a list of CDINFOS with the match-name consed on to the front")
|
||||
|
||||
(FOR FULLNAME TYPE LDATE (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
|
||||
(FOR FULLNAME TYPE LDATE STREAM (STARTPOS _ (ADD1 (NCHARS DIR))) IN FILES
|
||||
COLLECT
|
||||
|
||||
(* ;; "GDATE/IDATE in case Y2K")
|
||||
|
||||
(SETQ LDATE (OR (FILEDATE FULLNAME T)
|
||||
(FILEDATE FULLNAME))) (* ;
|
||||
(* ;
|
||||
"Is it a Lisp file? Get it's internal filecreated date. ")
|
||||
(CONS (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ FULLNAME
|
||||
DATE _ [GDATE (IDATE (IF USEDIRECTORYDATE
|
||||
THEN (GETFILEINFO FULLNAME 'CREATIONDATE)
|
||||
ELSEIF (OR LDATE (GETFILEINFO FULLNAME
|
||||
'CREATIONDATE]
|
||||
LENGTH _ (GETFILEINFO FULLNAME 'LENGTH)
|
||||
AUTHOR _ (GETFILEINFO FULLNAME 'AUTHOR)
|
||||
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE FULLNAME LDATE)
|
||||
EOL _ (EOLTYPE FULLNAME])
|
||||
(SETQ STREAM (OPENSTREAM FULLNAME 'INPUT)) (* ;
|
||||
"So all the GETFILEINFO's, FILEDATES, etc. don't have to do the directory searching.")
|
||||
(SETQ LDATE (OR (FILEDATE STREAM T)
|
||||
(FILEDATE STREAM)))
|
||||
(PROG1 (CONS (MATCHNAME FULLNAME STARTPOS)
|
||||
(CREATE CDINFO
|
||||
FULLNAME _ FULLNAME
|
||||
DATE _ (GDATE (IDATE (IF (OR USEDIRECTORYDATE (NULL LDATE))
|
||||
THEN (GETFILEINFO STREAM 'CREATIONDATE)
|
||||
ELSE (SETFILEINFO STREAM 'CREATIONDATE LDATE)
|
||||
LDATE)))
|
||||
LENGTH _ (GETFILEINFO STREAM 'LENGTH)
|
||||
AUTHOR _ (GETFILEINFO STREAM 'AUTHOR)
|
||||
TYPE _ (COMPAREDIRECTORIES.INFOS.TYPE STREAM LDATE)
|
||||
EOL _ (EOLTYPE STREAM)))
|
||||
(CLOSEF? STREAM])
|
||||
|
||||
(CDENTRIES.SELECT
|
||||
[LAMBDA (CANDIDATES SELECT) (* ; "Edited 4-Jan-2022 21:31 by rmk")
|
||||
|
||||
(* ;; "Does the pairwise select filter and inserts the date relation")
|
||||
|
||||
(for C MATCHNAME INFO1 INFO2 IDATE1 IDATE2 DATEREL BINCOMP [COMPAREDATE
|
||||
_
|
||||
(INTERSECTION SELECT
|
||||
'(< > =] in CANDIDATES
|
||||
eachtime (SETQ MATCHNAME (pop C))
|
||||
(SETQ INFO1 (pop C))
|
||||
(SETQ INFO2 (pop C))
|
||||
(if (AND INFO1 INFO2)
|
||||
then (SETQ IDATE1 (IDATE (fetch DATE of INFO1)))
|
||||
(SETQ IDATE2 (IDATE (fetch DATE of INFO2)))
|
||||
(SETQ DATEREL (if (IGREATERP IDATE1 IDATE2)
|
||||
then '>
|
||||
elseif (ILESSP IDATE1 IDATE2)
|
||||
then '<
|
||||
else '=))
|
||||
else
|
||||
(* ;; "Just for printing--no comparison")
|
||||
|
||||
(SETQ DATEREL '*))
|
||||
when (if (AND INFO1 INFO2)
|
||||
then (CL:WHEN (OR (NULL COMPAREDATE)
|
||||
(SELECTQ DATEREL
|
||||
(> (MEMB '> COMPAREDATE))
|
||||
(< (MEMB '< COMPAREDATE))
|
||||
(= (MEMB '= COMPAREDATE))
|
||||
(SHOULDNT)))
|
||||
(SETQ BINCOMP (BINCOMP (fetch (CDINFO FULLNAME) OF INFO1)
|
||||
(fetch (CDINFO FULLNAME) OF INFO2)
|
||||
T
|
||||
(fetch (CDINFO EOL) OF INFO1)
|
||||
(fetch (CDINFO EOL) OF INFO2)))
|
||||
(CL:WHEN (EQ T BINCOMP)
|
||||
|
||||
(* ;; "Byte-equivalent files with different dates. Presumably the earlier date is more accurate, move back the date of the later file and make DATEREL be =. Perhaps we should do this even if there is only an EOL difference (BINCOMP non-NIL).;; Byte-equivalent files with different dates. Presumably the earlier date is more accurate, move back the date of the earlier file and make DATEREL be =. Perhaps we should do this even if there is only an EOL difference (BINCOMP non-NIL). ")
|
||||
|
||||
(* ;; "We do this even if FIXDIRECTORYDATES is false, that addresses a property of individual Lisp source files.")
|
||||
|
||||
(SELECTQ DATEREL
|
||||
(> (SETFILEINFO (FETCH (CDINFO FULLNAME) OF INFO1)
|
||||
'CREATIONDATE
|
||||
(REPLACE (CDINFO DATE) OF INFO1 WITH (FETCH (CDINFO DATE)
|
||||
OF INFO2))))
|
||||
(< (SETFILEINFO (FETCH (CDINFO FULLNAME) OF INFO2)
|
||||
'CREATIONDATE
|
||||
(REPLACE (CDINFO DATE) OF INFO2 WITH (FETCH (CDINFO DATE)
|
||||
OF INFO1))))
|
||||
NIL)
|
||||
(SETQ DATEREL '=))
|
||||
|
||||
(* ;; "We want the ~= test to reflect exact byte equivalence, including the same EOL. We use the BINCOMP value below to indicate EOL differences, so we check it here.")
|
||||
|
||||
[NOT (AND (MEMB '~= SELECT)
|
||||
BINCOMP
|
||||
(EQ (fetch (CDINFO EOL) OF INFO1)
|
||||
(fetch (CDINFO EOL) OF INFO2])
|
||||
elseif INFO1
|
||||
then
|
||||
(* ;; "OK if INFO2 is missing?")
|
||||
|
||||
(MEMB '*- SELECT)
|
||||
else
|
||||
(* ;; "OK if INFO1 is missing?")
|
||||
|
||||
(MEMB '-* SELECT))
|
||||
collect (create CDENTRY
|
||||
MATCHNAME _ MATCHNAME
|
||||
INFO1 _ INFO1
|
||||
DATEREL _ DATEREL
|
||||
INFO2 _ INFO2
|
||||
EQUIV _ (CL:UNLESS (EQ DATEREL '*)
|
||||
BINCOMP])
|
||||
|
||||
(COMPAREDIRECTORIES.INFOS.TYPE
|
||||
[LAMBDA (FULLNAME LDATE) (* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(IF (OR LDATE (FILEDATE FULLNAME T)
|
||||
(FILEDATE FULLNAME))
|
||||
[LAMBDA (FULLNAME LDATE) (* ; "Edited 4-Jan-2022 13:10 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 22:50 by rmk")
|
||||
(IF LDATE
|
||||
THEN (CL:IF (MEMB (FILENAMEFIELD FULLNAME 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*)
|
||||
'COMPILED
|
||||
@@ -318,9 +345,12 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(DEFINEQ
|
||||
|
||||
(CDFILES
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 23-Dec-2021 22:49 by rmk")
|
||||
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
|
||||
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
|
||||
[LAMBDA (DIR INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH)(* ; "Edited 26-Jan-2022 15:25 by rmk")
|
||||
(* ; "Edited 21-Jan-2022 22:40 by rmk")
|
||||
(* ; "Edited 5-Jan-2022 15:07 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 22:49 by rmk")
|
||||
(* ; "Edited 6-Nov-2021 12:08 by rmk:")
|
||||
(* ; "Edited 16-Oct-2020 13:42 by rmk:")
|
||||
|
||||
(* ;; "Returns a list of fullnames for files that satisfy the criteria. We generate all candidates that match INCLUDEDFILES but not EXCLUDEDFILES in DIR.")
|
||||
|
||||
@@ -338,7 +368,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(* ;; "EXCLUDEDFILES is a filepattern with * meaning everything, COM means *.LCOM and *.DFASL")
|
||||
|
||||
[SETQ EXCLUDEDFILES `(.DS_Store
|
||||
[SETQ EXCLUDEDFILES `(*>.DS_Store
|
||||
,@(MKLIST EXCLUDEDFILES]
|
||||
(CL:UNLESS (EQMEMB '.* INCLUDEDFILES) (* ;
|
||||
"Excluded dot files unless specifically asked for")
|
||||
@@ -372,9 +402,14 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(CL:UNLESS (OR (EQ SD '*)
|
||||
(EQ SD (CAR P)))
|
||||
(SETQ SD NIL)) FINALLY (CL:WHEN (EQ SD '*)
|
||||
(SETQ SD ""))
|
||||
(SETQ SD ""))
|
||||
|
||||
(* ;;
|
||||
"If We don't prefix TOPDIR with <, then if TOPDIR contains a colon it is interpreted as a device.")
|
||||
|
||||
(SETQ ENUMPAT (PACKFILENAME 'HOST HOST 'DIRECTORY
|
||||
(CONCAT TOPDIR ">" (OR SD ""))
|
||||
(CONCAT "<" TOPDIR ">"
|
||||
(OR SD ""))
|
||||
'NAME N 'EXTENSION E 'VERSION
|
||||
(CL:IF ALLVERSIONS
|
||||
'*
|
||||
@@ -387,48 +422,52 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(* ;; "We enumerate all the files, checking to see that")
|
||||
|
||||
(FOR FULLNAME NAME EXT SUBDIR UNPACK THISDEPTH (STARTPOS _ (ADD1 (NCHARS TOPDIR)))
|
||||
IN (DIRECTORY ENUMPAT) EACHTIME (CL:WHEN (DIRECTORYNAMEP FULLNAME)
|
||||
(* ; "Skip directories")
|
||||
(GO $$ITERATE))
|
||||
(SETQ UNPACK (UNPACKFILENAME FULLNAME))
|
||||
(SETQ NAME (LISTGET UNPACK 'NAME))
|
||||
(SETQ EXT (LISTGET UNPACK 'EXTENSION))
|
||||
(SETQ SUBDIR (SUBATOM (LISTGET UNPACK 'DIRECTORY)
|
||||
STARTPOS))
|
||||
(CL:UNLESS NAME
|
||||
(CL:WHEN EXT (* ; ".XY")
|
||||
(SETQ NAME (PACK* "." EXT))
|
||||
(SETQ EXT NIL)))
|
||||
(SETQ THISDEPTH (FOR I (CNT _ 1) FROM 1
|
||||
DO (SELCHARQ (NTHCHARCODE SUBDIR I)
|
||||
((> /)
|
||||
(ADD CNT 1))
|
||||
(NIL (RETURN CNT))
|
||||
NIL)))
|
||||
IN (DIRECTORY ENUMPAT NIL NIL (CL:IF ALLVERSIONS
|
||||
"*"
|
||||
""))
|
||||
EACHTIME (SETQ UNPACK (UNPACKFILENAME FULLNAME))
|
||||
(SETQ NAME (LISTGET UNPACK 'NAME))
|
||||
(SETQ EXT (LISTGET UNPACK 'EXTENSION))
|
||||
(CL:UNLESS NAME
|
||||
(CL:WHEN EXT (* ; ".XY")
|
||||
(SETQ NAME (PACK* "." EXT))
|
||||
(SETQ EXT NIL)))
|
||||
(CL:UNLESS (OR NAME EXT) (* ; "Must have been a directory")
|
||||
(GO $$ITERATE))
|
||||
(SETQ SUBDIR (SUBATOM (LISTGET UNPACK 'DIRECTORY)
|
||||
STARTPOS))
|
||||
(SETQ THISDEPTH (FOR I (CNT _ 1) FROM 1 DO (SELCHARQ (NTHCHARCODE SUBDIR I)
|
||||
((> /)
|
||||
(ADD CNT 1))
|
||||
(NIL (RETURN CNT))
|
||||
NIL)))
|
||||
WHEN (OR (NULL INCLUDES)
|
||||
(CDFILES.MATCH SUBDIR NAME EXT THISDEPTH INCLUDES))
|
||||
UNLESS (CDFILES.MATCH SUBDIR NAME EXT THISDEPTH EXCLUDES) COLLECT FULLNAME])
|
||||
|
||||
(CDFILES.MATCH
|
||||
[LAMBDA (SUBDIR NAME EXT THISDEPTH PATTERNS) (* ; "Edited 23-Dec-2021 21:47 by rmk")
|
||||
[LAMBDA (SUBDIR NAME EXT THISDEPTH PATTERNS) (* ; "Edited 26-Jan-2022 15:33 by rmk")
|
||||
(* ; "Edited 23-Dec-2021 21:47 by rmk")
|
||||
|
||||
(* ;; "True if the components of the fullname match at least one of the patterns")
|
||||
|
||||
(THEREIS P IN PATTERNS SUCHTHAT (AND [OR (STRING.EQUAL NAME (CAR P))
|
||||
(THEREIS P IN PATTERNS SUCHTHAT (AND [OR (STRING.EQUAL NAME (CAR P)
|
||||
FILEDIRCASEARRAY)
|
||||
(EQ '* (CAR P))
|
||||
(AND (EQ (CHARCODE %.)
|
||||
(CHCON1 (CAR P)))
|
||||
(EQ (EQ (CHARCODE %.)
|
||||
(CHCON1 NAME)))
|
||||
(EQ (CHARCODE %.)
|
||||
(CHCON1 NAME))
|
||||
(OR (STRING.EQUAL NAME (SUBATOM (CAR P)
|
||||
2))
|
||||
(EQ (CHARCODE *1)
|
||||
(EQ (CHARCODE *)
|
||||
(NTHCHARCODE (CAR P)
|
||||
2]
|
||||
(OR (STRING.EQUAL EXT (CADR P))
|
||||
(EQ '* (CADR P)))
|
||||
(OR (STRING.EQUAL SUBDIR (CADDR P))
|
||||
(NULL (CADDR P)))
|
||||
(NULL (CADDR P))
|
||||
(EQ '* (CADDR P)))
|
||||
(ILEQ THISDEPTH (CADDDR P])
|
||||
|
||||
(CDFILES.PATS
|
||||
@@ -479,9 +518,10 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(DEFINEQ
|
||||
|
||||
(CDPRINT
|
||||
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "Edited 19-Dec-2021 20:10 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 20:59 by rmk:")
|
||||
(* ; "Edited 13-Oct-2020 08:38 by rmk:")
|
||||
[LAMBDA (CDVALUE FILE COLHEADINGS PRINTAUTHOR) (* ; "Edited 26-Jan-2022 13:43 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 20:10 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 20:59 by rmk:")
|
||||
(* ; "Edited 13-Oct-2020 08:38 by rmk:")
|
||||
|
||||
(* ;; "Typically CDVALUE will have a provdenance header. If not, we fake one up, at least for the directories and today's date.")
|
||||
|
||||
@@ -502,11 +542,7 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
'(PROGN (CLOSEF? OLDVALUE])
|
||||
(LINELENGTH 1000 STREAM) (* ; "Don't wrap")
|
||||
(CL:WHEN (FETCH (CDVALUE CDDIR1) OF CDVALUE)
|
||||
(PRINTOUT STREAM "Comparing " (FETCH (CDVALUE CDDIR1) OF CDVALUE)
|
||||
6 "vs. " (FETCH (CDVALUE CDDIR2) OF CDVALUE)
|
||||
T "as of " (FETCH (CDVALUE CDCOMPAREDATE) OF CDVALUE))
|
||||
(CL:WHEN (FETCH (CDVALUE CDSELECT) OF CDVALUE)
|
||||
(PRINTOUT STREAM " selecting " (FETCH (CDVALUE CDSELECT) OF CDVALUE)))
|
||||
(CDPRINT.HEADER CDVALUE STREAM)
|
||||
(PRINTOUT STREAM -2 (LENGTH (fetch CDENTRIES of CDVALUE))
|
||||
" entries" T T))
|
||||
(if (fetch CDENTRIES of CDVALUE)
|
||||
@@ -517,6 +553,27 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
else (PRINTOUT T "CDVALUE is empty" T))
|
||||
(AND STREAM (CLOSEF? STREAM))))])
|
||||
|
||||
(CDPRINT.HEADER
|
||||
[LAMBDA (DIR1 DIR2 SELECT DATE STREAM) (* ; "Edited 26-Jan-2022 13:36 by rmk")
|
||||
(CL:WHEN (LISTP DIR1)
|
||||
|
||||
(* ;; "A CDVALUE")
|
||||
|
||||
(CL:UNLESS STREAM (SETQ STREAM DIR2))
|
||||
(SETQ DIR2 (FETCH CDDIR2 OF DIR1))
|
||||
(SETQ SELECT (FETCH CDSELECT OF DIR1))
|
||||
(SETQ DATE (FETCH CDCOMPAREDATE OF DIR1))
|
||||
(SETQ DIR1 (FETCH CDDIR1 OF DIR1)))
|
||||
(CL:WHEN DIR1
|
||||
(PRINTOUT STREAM "Comparing ")
|
||||
(PRINTOUT STREAM DIR1 %# (CL:WHEN (IGREATERP (IPLUS (NCHARS DIR1)
|
||||
(NCHARS DIR2))
|
||||
70)
|
||||
(TAB 5))
|
||||
" vs. " DIR2)
|
||||
(PRINTOUT STREAM T 3 "as of " DATE)
|
||||
(CL:WHEN SELECT (PRINTOUT STREAM " selecting " SELECT)))])
|
||||
|
||||
(CDPRINT.LINE
|
||||
[LAMBDA (STREAM ENTRY PRINTAUTHOR DATE1POS ENDDATE1 NCHARSDIR1 NCHARSDIR2)
|
||||
(* ; "Edited 22-Nov-2021 22:38 by rmk:")
|
||||
@@ -752,6 +809,89 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(SETQ INFO2 (FETCH INFO2 OF CDE))
|
||||
(SETQ EQUIV (FETCH EQUIV OF CDE))
|
||||
WHEN (APPLY* FN CDE) COLLECT CDE])
|
||||
|
||||
(CDMERGE
|
||||
[LAMBDA (CDVALUES) (* ; "Edited 24-Jan-2022 17:01 by rmk")
|
||||
|
||||
(* ;; "This merges a collection of CDVALUES on different directories into a single CDVALUE with the union of the CDENTRIES, provided that they have the same selection criteria. The merged directories will be the minimal common prefix of all of the entries on each side, and the residual of the directory will be packed onto all the names.")
|
||||
|
||||
(IF (CDR CDVALUES)
|
||||
THEN
|
||||
[LET
|
||||
(CDSELECTS)
|
||||
|
||||
(* ;; "Group by selects")
|
||||
|
||||
(FOR CDV TMP IN CDVALUES
|
||||
DO (PUSH [CDR (OR (SASSOC (FETCH CDSELECT OF CDV)
|
||||
CDSELECTS)
|
||||
(CAR (PUSH CDSELECTS (CONS (FETCH CDSELECT OF CDV]
|
||||
CDV))
|
||||
|
||||
(* ;; "For each group, find the longest common directory prefixes")
|
||||
|
||||
(FOR CDS IDATE DIR1 DIR2 MERGEDENTRIES IN CDSELECTS
|
||||
COLLECT (SETQ DIR1 (FETCH CDDIR1 OF (CADR CDS)))
|
||||
(SETQ DIR2 (FETCH CDDIR2 OF (CADR CDS)))
|
||||
[SETQ IDATE (IDATE (FETCH CDCOMPAREDATE OF (CADR CDS]
|
||||
|
||||
(* ;; "Calculate the common directory prefixes and latest date")
|
||||
|
||||
[FOR CDV IN (CDDR CDS) DO (SETQ DIR1 (CDMERGE.COMMON DIR1 (FETCH CDDIR1
|
||||
OF CDV)))
|
||||
(SETQ DIR2 (CDMERGE.COMMON DIR2 (FETCH CDDIR2
|
||||
OF CDV)))
|
||||
(CL:WHEN (IGREATERP IDATE (IDATE (FETCH CDCOMPAREDATE
|
||||
OF CDV)))
|
||||
(SETQ IDATE (IDATE (FETCH CDCOMPAREDATE OF CDV))))]
|
||||
|
||||
(* ;;
|
||||
"Merge the CDENTRIES with matchnames pulled back so that subdirectories show up")
|
||||
|
||||
(SETQ MERGEDENTRIES
|
||||
(SORT [FOR CDV NC1 _ (ADD1 (NCHARS DIR1))
|
||||
NC2 _ (ADD1 (NCHARS DIR2)) IN (CDR CDS)
|
||||
JOIN (FOR CDE IN (FETCH CDENTRIES OF CDV)
|
||||
COLLECT (CREATE CDENTRY
|
||||
USING CDE MATCHNAME _
|
||||
(IF (FETCH INFO1 OF CDE)
|
||||
THEN (MATCHNAME (FETCH (CDINFO FULLNAME)
|
||||
OF (FETCH INFO1
|
||||
OF CDE))
|
||||
NC1)
|
||||
ELSE (MATCHNAME (FETCH (CDINFO FULLNAME)
|
||||
OF (FETCH INFO2
|
||||
OF CDE))
|
||||
NC2]
|
||||
T))
|
||||
(CD.UPDATEWIDTHS (CREATE CDVALUE
|
||||
CDDIR1 _ DIR1
|
||||
CDDIR2 _ DIR2
|
||||
CDCOMPAREDATE _ (GDATE IDATE)
|
||||
CDSELECT _ (CAR CDS)
|
||||
CDENTRIES _ MERGEDENTRIES]
|
||||
ELSE CDVALUES])
|
||||
|
||||
(CDMERGE.COMMON
|
||||
[LAMBDA (DIRX DIRY) (* ; "Edited 24-Jan-2022 16:40 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Returns the longest common prefix of DIRX and DIRY, collapsing brackets, slashes, and case")
|
||||
|
||||
(FOR I CX CY (LASTDIRPOS _ 1) FROM 1 EACHTIME (SETQ CX (NTHCHARCODE DIRX I))
|
||||
(SETQ CY (NTHCHARCODE DIRY I))
|
||||
(CL:WHEN (MEMB CX (CHARCODE (< > /)))
|
||||
(SETQ CX (CHARCODE /)))
|
||||
(CL:WHEN (MEMB CY (CHARCODE (< > /)))
|
||||
(SETQ CY (CHARCODE /)))
|
||||
(CL:WHEN (AND (EQ CX (CHARCODE /))
|
||||
(EQ CY (CHARCODE /)))
|
||||
(SETQ LASTDIRPOS I))
|
||||
UNLESS [AND CX CY (OR (EQ CX CY)
|
||||
(EQ (L-CASECODE CX)
|
||||
(L-CASECODE CY] DO (RETURN (CL:IF (EQ I 1)
|
||||
""
|
||||
(SUBSTRING DIRX 1 LASTDIRPOS))])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -827,40 +967,51 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
FINALLY (RETURN (OR EOLDIFF T]))])
|
||||
|
||||
(EOLTYPE
|
||||
[LAMBDA (FILE SHOWCONTEXT) (* ; "Edited 21-Feb-2021 20:34 by rmk:")
|
||||
[LAMBDA (FILE SHOWCONTEXT)
|
||||
|
||||
(* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")
|
||||
(* ;; "Edited 4-Jan-2022 15:10 by rmk: Allow FILE to be an already open stream")
|
||||
|
||||
(* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.")
|
||||
(* ;; "Edited 21-Feb-2021 20:34 by rmk:")
|
||||
|
||||
(* ;; "Returns the EOLCONVENTION of FILE if it only sees one kind, NIL if it can't decide.")
|
||||
|
||||
(* ;; "If SHOWCONTEXT, it is the number of bytes before and after an EOL inconsistency (e.g. seeing CR after having seen LF) that will be displayed on the TTY. The position of the inconsistency will be marked with ##.")
|
||||
|
||||
(SELECTQ SHOWCONTEXT
|
||||
(NIL)
|
||||
(T (SETQ SHOWCONTEXT 100))
|
||||
(CL:UNLESS (FIXP SHOWCONTEXT)
|
||||
(ERROR "SHOWCONTEXT must be an integer" SHOWCONTEXT)))
|
||||
(CL:WITH-OPEN-FILE
|
||||
(STREAM FILE :DIRECTION :INPUT)
|
||||
(SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
|
||||
(BIND EOLTYPE
|
||||
DO (SELCHARQ (OR (\BIN STREAM)
|
||||
(RETURN EOLTYPE))
|
||||
(CR (IF (EQ (CHARCODE LF)
|
||||
(RESETLST
|
||||
(LET (STREAM)
|
||||
[IF (GETSTREAM FILE 'INPUT T)
|
||||
THEN (SETQ STREAM FILE)
|
||||
[RESETSAVE NIL `(PROGN (SETFILEPTR ,STREAM ,(GETFILEPTR STREAM))
|
||||
(STREAMPROP ,STREAM 'ENDOFSTREAMOP
|
||||
',(STREAMPROP STREAM 'ENDOFSTREAMOP]
|
||||
(SETFILEPTR STREAM 0)
|
||||
ELSE (RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTREAM FILE 'INPUT]
|
||||
(SETFILEINFO STREAM 'ENDOFSTREAMOP (FUNCTION NILL))
|
||||
(BIND EOLTYPE
|
||||
DO (SELCHARQ (OR (\BIN STREAM)
|
||||
(RETURN EOLTYPE))
|
||||
(CR (IF (EQ (CHARCODE LF)
|
||||
(\PEEKBIN STREAM T))
|
||||
THEN (\BIN STREAM)
|
||||
(IF (MEMB EOLTYPE '(LF CR))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE
|
||||
'LF STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'CRLF))
|
||||
ELSEIF (MEMB EOLTYPE '(LF CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM)
|
||||
THEN (\BIN STREAM)
|
||||
(IF (MEMB EOLTYPE '(LF CR))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE
|
||||
'LF STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'CRLF))
|
||||
ELSEIF (MEMB EOLTYPE '(LF CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'CR STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'CR)))
|
||||
(LF (IF (MEMB EOLTYPE '(CR CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM)
|
||||
ELSE (SETQ EOLTYPE 'CR)))
|
||||
(LF (IF (MEMB EOLTYPE '(CR CRLF))
|
||||
THEN (CL:UNLESS (EOLTYPE.SHOW SHOWCONTEXT EOLTYPE 'LF STREAM)
|
||||
(RETURN NIL))
|
||||
ELSE (SETQ EOLTYPE 'LF)))
|
||||
NIL])
|
||||
ELSE (SETQ EOLTYPE 'LF)))
|
||||
NIL))))])
|
||||
|
||||
(EOLTYPE.SHOW
|
||||
[LAMBDA (SHOWCONTEXT OLDTYPE NEWTYPE STREAM) (* ; "Edited 21-Feb-2021 20:20 by rmk:")
|
||||
@@ -1435,18 +1586,16 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
|
||||
(CDBROWSER
|
||||
[LAMBDA (CDVALUE TITLE COLHEADINGS BROWSERPROPS SEPARATEDIRECTIONS MENUITEMS)
|
||||
(* ; "Edited 25-Dec-2021 12:50 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 11:51 by rmk")
|
||||
(* ; "Edited 14-Dec-2021 21:41 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 21:38 by rmk")
|
||||
(* ; "Edited 30-Nov-2021 15:03 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 14:18 by rmk:")
|
||||
|
||||
(* ;; "Edited 25-Jan-2022 13:05 by rmk: a table browser for the differences in CDVALUE.")
|
||||
|
||||
(* ;; "Creates a table browser for the differences in CDVALUE.")
|
||||
|
||||
(SETQ MENUITEMS (IF MENUITEMS
|
||||
THEN (FOR I IN MENUITEMS COLLECT (OR (LISTP I)
|
||||
(SASSOC I CDTABLEBROWSER.MENUITEMS)
|
||||
(AND (STREQUAL I "")
|
||||
"")
|
||||
(ERROR "UNKNOWN CDBROWSER MENU ITEM" I))
|
||||
)
|
||||
ELSE CDTABLEBROWSER.MENUITEMS))
|
||||
@@ -1466,8 +1615,8 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
DEFAULTFONT]
|
||||
[SETQ REGION (GETREGION (PLUS TB.LEFT.MARGIN ITEMWIDTH (TIMES 2 WBorder)
|
||||
MENUWIDTH)
|
||||
(TIMES [IMIN 15 (IMAX (IPLUS 4 (LENGTH STRINGS))
|
||||
(ADD1 (LENGTH MENUITEMS]
|
||||
(TIMES (IMAX (IMIN 15 (LENGTH STRINGS))
|
||||
(ADD1 (LENGTH MENUITEMS)))
|
||||
(FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
|
||||
(* ;; "Promptwindow seems to do its own thing, even if under construction. So we preshrink the main window.")
|
||||
@@ -1476,8 +1625,13 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
OF REGION)
|
||||
(FONTPROP DEFAULTFONT
|
||||
'HEIGHT]
|
||||
(SETQ WINDOW (CREATEW REGION (OR TITLE "Compare directories")
|
||||
(SETQ WINDOW (CREATEW REGION (OR TITLE (CONCAT "Compare directories " (LENGTH
|
||||
STRINGS)
|
||||
" files"))
|
||||
NIL T))
|
||||
[WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (W)
|
||||
(FOR W INSIDE (WINDOWPROP W 'SUBWINDOWS)
|
||||
DO (CLOSEW (WFROMDS W]
|
||||
(WINDOWPROP WINDOW 'UNDERCONSTRUCTION T)
|
||||
|
||||
(* ;; "TABLEBROWSER is odd: USERDATA is a single recognized property. But it allows for other unrecognized properties in the list, it pushes them on to a list USERPROPS...and then throws it away. So here I'm using USERDATA to hold the directory lengths so they can be stripped off for display. It may actually be better to have a field name in CDVALUE for all of the shared stuff in front of the entries, and keep it all.")
|
||||
@@ -1610,105 +1764,153 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
'DON'T])
|
||||
|
||||
(CD.COMMANDSELECTEDFN
|
||||
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 25-Dec-2021 11:20 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 13:45 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 17:13 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 21:36 by rmk")
|
||||
(* ; "Edited 8-Dec-2021 11:27 by rmk")
|
||||
(* ; "Edited 5-Dec-2021 13:28 by rmk")
|
||||
(* ; "Edited 3-Dec-2021 00:21 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 23:08 by rmk:")
|
||||
[LAMBDA (MENUITEM MENU KEY) (* ; "Edited 27-Jan-2022 17:46 by rmk")
|
||||
(* ; "Edited 10-Jan-2022 22:51 by rmk")
|
||||
(* ; "Edited 25-Dec-2021 11:20 by rmk")
|
||||
(* ; "Edited 12-Jan-87 12:57 by bvm:")
|
||||
|
||||
(* ;; "Cobbled from FB.COMMANDSELECTEDFN. But here we assume that the menu item is of the form (display-string FN . EXTRAS), we peel out the FN to apply, leave the rest alone.")
|
||||
|
||||
(DECLARE (SPECVARS MENUITEM MENU KEY))
|
||||
(RESETLST
|
||||
[LET* [(WINDOW (WINDOWPROP (WFROMMENU MENU)
|
||||
'MAINWINDOW))
|
||||
(PROMPTWINDOW (GETPROMPTWINDOW WINDOW))
|
||||
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
|
||||
(USERDATA (TB.USERDATA CDBROWSER))
|
||||
(CDVALUE (LISTGET USERDATA 'CDVALUE))
|
||||
(FN (CADR (LISTP MENUITEM]
|
||||
(DECLARE (SPECVARS WINDOW PROMPTWINDOW CDVALUE USERDATA))
|
||||
(GIVE.TTY.PROCESS PROMPTWINDOW)
|
||||
(TTYDISPLAYSTREAM PROMPTWINDOW) (* ; "Pwindow")
|
||||
(IF (EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
|
||||
THEN (FLASHWINDOW PROMPTWINDOW)
|
||||
(PRIN3 "Please make a selection" T)
|
||||
ELSE (TB.MAP.SELECTED.ITEMS CDBROWSER
|
||||
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
|
||||
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
|
||||
(FILE1 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO1) OF CDENTRY)))
|
||||
(FILE2 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO2) OF CDENTRY)))
|
||||
(TYPE (FETCH (CDINFO TYPE) OF (FETCH (CDENTRY INFO1)
|
||||
OF CDENTRY)))
|
||||
(LABELS (APPLY* (OR (LISTGET USERDATA 'LABELFN)
|
||||
(FUNCTION NILL))
|
||||
FILE1 FILE2 USERDATA))
|
||||
(LABEL1 (OR (CAR LABELS)
|
||||
FILE1))
|
||||
(LABEL2 (OR (CADR LABELS)
|
||||
FILE2)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
(CL:UNLESS (STREQUAL MENUITEM "") (* ; "For blank lines")
|
||||
(RESETLST
|
||||
[LET* [(WINDOW (WINDOWPROP (WFROMMENU MENU)
|
||||
'MAINWINDOW))
|
||||
(PWINDOW (GETPROMPTWINDOW WINDOW))
|
||||
(CDBROWSER (WINDOWPROP WINDOW 'TABLEBROWSER))
|
||||
(USERDATA (TB.USERDATA CDBROWSER))
|
||||
(CDVALUE (LISTGET USERDATA 'CDVALUE))
|
||||
(FN (CADR (LISTP MENUITEM]
|
||||
(DECLARE (SPECVARS WINDOW PWINDOW CDVALUE USERDATA))
|
||||
(GIVE.TTY.PROCESS PWINDOW)
|
||||
(TTYDISPLAYSTREAM PWINDOW) (* ; "Pwindow")
|
||||
(COND
|
||||
((EQ 0 (TB.NUMBER.OF.ITEMS CDBROWSER 'SELECTED))
|
||||
(FLASHWINDOW PWINDOW)
|
||||
(PRIN3 "Please make a selection" T))
|
||||
(T (TB.MAP.SELECTED.ITEMS
|
||||
CDBROWSER
|
||||
[FUNCTION (LAMBDA (CDBROWSER TBITEM)
|
||||
(LET* ((CDENTRY (CADR (FETCH TIDATA OF TBITEM)))
|
||||
(FILE1 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO1) OF CDENTRY)))
|
||||
(FILE2 (FETCH (CDINFO FULLNAME)
|
||||
(FETCH (CDENTRY INFO2) OF CDENTRY)))
|
||||
(TYPE (FETCH (CDINFO TYPE) OF (FETCH (CDENTRY INFO1)
|
||||
OF CDENTRY)))
|
||||
(LABELS (APPLY* (OR (LISTGET USERDATA 'LABELFN)
|
||||
(FUNCTION NILL))
|
||||
FILE1 FILE2 USERDATA))
|
||||
(LABEL1 (OR (CAR LABELS)
|
||||
FILE1))
|
||||
(LABEL2 (OR (CADR LABELS)
|
||||
FILE2)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
|
||||
(* ;; "If USERDATA contains a LABELFN, then it is applied to the files and the rest of the USERDATA to produce abbreviated labels for titles and headers.")
|
||||
|
||||
(CLEARW T)
|
||||
(CL:FUNCALL FN TBITEM MENUITEM CDBROWSER KEY]
|
||||
(FUNCTION NILL])])
|
||||
(CLEARW T)
|
||||
(CL:FUNCALL FN TBITEM MENUITEM CDBROWSER KEY]
|
||||
(FUNCTION NILL]))])
|
||||
|
||||
(CD-MENUFN
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY) (* ; "Edited 30-Dec-2021 18:21 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 09:56 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 13:30 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 22:11 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 21:42 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 21:24 by rmk")
|
||||
[LAMBDA (TBITEM MENUITEM CDBROWSER KEY)
|
||||
|
||||
(* ;; "Edited 25-Jan-2022 10:19 by rmk: FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
|
||||
|
||||
(* ;; "The FILELABELFN, if provided, can be used to calculate abbreviated labels for the file, for example, to strip off any long common prefixes.")
|
||||
|
||||
(* ;; "MENUITEM is of the form (display-atom <this function> . extrainfo). The selector for the selectq is either the CAR of the extrainfo or the display atom.")
|
||||
|
||||
(SELECTQ (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
(Compare (IF (AND FILE1 FILE2)
|
||||
THEN (SELECTQ TYPE
|
||||
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2))
|
||||
(COMPILED (PRIN3 "Cannot compare compiled files" T))
|
||||
((TEXT TEDIT)
|
||||
(* ;;
|
||||
(LET
|
||||
(SUBWINDOWS)
|
||||
(CL:WHEN (MEMB (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
'(Compare See% right See% both See% left))
|
||||
(FOR W IN (WINDOWPROP WINDOW 'SUBWINDOWS) WHEN (OPENWP W) DO (CLOSEW W)))
|
||||
(SELECTQ (OR (CADDR MENUITEM)
|
||||
(CAR MENUITEM))
|
||||
(Compare (IF (AND FILE1 FILE2)
|
||||
THEN [SETQ SUBWINDOWS
|
||||
(SELECTQ TYPE
|
||||
(SOURCE (CSBROWSER FILE1 FILE2 NIL LABEL1 LABEL2
|
||||
(RELCREATEREGION
|
||||
[FIXR (TIMES 0.75 (FETCH (REGION WIDTH)
|
||||
OF (WINDOWPROP WINDOW
|
||||
'REGION]
|
||||
200
|
||||
'LEFT
|
||||
'TOP
|
||||
`(,WINDOW 0.125)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
20)
|
||||
T)))
|
||||
(COMPILED (FLASHWINDOW T)
|
||||
(PRIN3 "Cannot compare compiled files" T))
|
||||
((TEXT TEDIT)
|
||||
(* ;;
|
||||
"Works for TEDIT, but doesn't detect image object differences")
|
||||
|
||||
(COMPARETEXT FILE1 FILE2 'LINE NIL (LIST LABEL1 LABEL2)))
|
||||
(PROGN (PRIN3 "Unable to compare, showing both" T)
|
||||
(TEDIT-SEE-VERSIONS FILE1 FILE2 LABEL1 LABEL2)))
|
||||
ELSE (PRIN3 "Only one file" T)))
|
||||
(See% left (IF FILE1
|
||||
THEN (TEDIT-SEE FILE1 NIL NIL (CONCAT "SEE window for " LABEL1))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% right (IF FILE2
|
||||
THEN (TEDIT-SEE FILE2 NIL NIL (CONCAT "SEE window for " LABEL2))
|
||||
(COMPARETEXT FILE1 FILE2 'LINE
|
||||
(RELCREATEPOSITION `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
20))
|
||||
(LIST LABEL1 LABEL2)))
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(PRIN3 "Unable to compare, showing both" T)
|
||||
(TEDIT-SEE-VERSIONS FILE1 FILE2 LABEL1 LABEL2]
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "Only one file" T)))
|
||||
(See% left (IF FILE1
|
||||
THEN (SETQ SUBWINDOWS (TEDIT-SEE FILE1
|
||||
(RELCREATEREGION
|
||||
700 700 'RIGHT 'TOP `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
T)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL1)))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% both (IF (AND FILE1 FILE2)
|
||||
THEN (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2)
|
||||
ELSE (PRIN3 "Only one file" T)))
|
||||
(Copy% -> (LET [(DEST (COPYFILE FILE1 (PACKFILENAME 'VERSION NIL FILE2]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(CONCAT FILE2 " could not be copied"))
|
||||
T)))
|
||||
(Copy% <- (LET [(DEST (COPYFILE FILE2 (PACKFILENAME 'VERSION NIL FILE1]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(CONCAT FILE1 " could not be copied"))
|
||||
T)))
|
||||
(SHOULDNT])
|
||||
(See% right (IF FILE2
|
||||
THEN (SETQ SUBWINDOWS (TEDIT-SEE FILE2
|
||||
(RELCREATEREGION
|
||||
700 700 'LEFT 'TOP `(,WINDOW 0.5)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
T)
|
||||
NIL
|
||||
(CONCAT "SEE window for " LABEL2)))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "No file to print" T)))
|
||||
(See% both (IF (AND FILE1 FILE2)
|
||||
THEN (SETQ SUBWINDOWS (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2
|
||||
(RELCREATEREGION
|
||||
1400 700 'LEFT 'TOP `(,WINDOW 0.5 -701)
|
||||
(IPLUS (FETCH (REGION BOTTOM)
|
||||
OF (WINDOWPROP WINDOW 'REGION))
|
||||
-1)
|
||||
T)))
|
||||
ELSE (FLASHWINDOW T)
|
||||
(PRIN3 "Only one file" T)))
|
||||
(Copy% -> (LET [(DEST (COPYFILE FILE1 (PACKFILENAME 'VERSION NIL FILE2]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(CONCAT FILE2 " could not be copied")))
|
||||
T)))
|
||||
(Copy% <- (LET [(DEST (COPYFILE FILE2 (PACKFILENAME 'VERSION NIL FILE1]
|
||||
(PRIN3 (CL:IF DEST
|
||||
(CONCAT "Copied to " DEST)
|
||||
(PROGN (FLASHWINDOW T)
|
||||
(CONCAT FILE1 " could not be copied")))
|
||||
T)))
|
||||
(SHOULDNT))
|
||||
(FOR W INSIDE SUBWINDOWS DO (WINDOWADDPROP WINDOW 'SUBWINDOWS (WFROMDS W])
|
||||
)
|
||||
|
||||
(RPAQQ CDTABLEBROWSER.MENUITEMS ((Compare CD-MENUFN)
|
||||
@@ -1723,21 +1925,23 @@ Copyright (c) 1985-1988, 1990, 1994, 1998, 2018, 2020-2021 by Venue & Xerox Corp
|
||||
(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994 1998
|
||||
2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2418 17067 (COMPAREDIRECTORIES 2428 . 12186) (COMPAREDIRECTORIES.INFOS 12188 . 13867) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 13869 . 14451) (MATCHNAME 14453 . 14983) (CD.INSURECDVALUE 14985 . 16599
|
||||
) (CD.UPDATEWIDTHS 16601 . 17065)) (17068 26728 (CDFILES 17078 . 23061) (CDFILES.MATCH 23063 . 24449)
|
||||
(CDFILES.PATS 24451 . 26726)) (26729 41174 (CDPRINT 26739 . 29343) (CDPRINT.LINE 29345 . 31901) (
|
||||
CDPRINT.MAXWIDTHS 31903 . 36018) (CDPRINT.COLHEADERS 36020 . 36658) (CDPRINT.COLUMNS 36660 . 40539) (
|
||||
CDTEDIT 40541 . 41172)) (41175 44371 (CDMAP 41185 . 42617) (CDENTRY 42619 . 42928) (CDSUBSET 42930 .
|
||||
44369)) (44372 51313 (BINCOMP 44382 . 48671) (EOLTYPE 48673 . 50638) (EOLTYPE.SHOW 50640 . 51311)) (
|
||||
51841 65048 (FIND-UNCOMPILED-FILES 51851 . 55494) (FIND-UNSOURCED-FILES 55496 . 58305) (
|
||||
FIND-SOURCE-FILES 58307 . 60011) (FIND-COMPILED-FILES 60013 . 62091) (FIND-UNLOADED-FILES 62093 .
|
||||
62837) (FIND-LOADED-FILES 62839 . 63393) (FIND-MULTICOMPILED-FILES 63395 . 65046)) (65049 73251 (
|
||||
CREATED-AS 65059 . 69856) (SOURCE-FOR-COMPILED-P 69858 . 72556) (COMPILE-SOURCE-DATE-DIFF 72558 .
|
||||
73249)) (73252 83558 (FIX-DIRECTORY-DATES 73262 . 76255) (FIX-EQUIV-DATES 76257 . 77782) (
|
||||
COPY-COMPARED-FILES 77784 . 79605) (COPY-MISSING-FILES 79607 . 81764) (COMPILED-ON-SAME-SOURCE 81766
|
||||
. 83556)) (83752 91440 (CDBROWSER 83762 . 88335) (CDBROWSER.STRINGS 88337 . 91438)) (91602 92874 (
|
||||
CD.TABLEITEM 91612 . 91832) (CD.TABLEITEM.PRINTFN 91834 . 92033) (CD.TABLEITEM.COPYFN 92035 . 92629) (
|
||||
CDTABLEBROWSER.HEADING.REPAINTFN 92631 . 92872)) (92875 100220 (CDTABLEBROWSER.WHENSELECTEDFN 92885 .
|
||||
93353) (CD.COMMANDSELECTEDFN 93355 . 97161) (CD-MENUFN 97163 . 100218)))))
|
||||
(FILEMAP (NIL (2497 19012 (COMPAREDIRECTORIES 2507 . 8956) (COMPAREDIRECTORIES.INFOS 8958 . 11078) (
|
||||
CDENTRIES.SELECT 11080 . 15766) (COMPAREDIRECTORIES.INFOS.TYPE 15768 . 16396) (MATCHNAME 16398 . 16928
|
||||
) (CD.INSURECDVALUE 16930 . 18544) (CD.UPDATEWIDTHS 18546 . 19010)) (19013 29285 (CDFILES 19023 .
|
||||
25379) (CDFILES.MATCH 25381 . 27006) (CDFILES.PATS 27008 . 29283)) (29286 44371 (CDPRINT 29296 . 31641
|
||||
) (CDPRINT.HEADER 31643 . 32540) (CDPRINT.LINE 32542 . 35098) (CDPRINT.MAXWIDTHS 35100 . 39215) (
|
||||
CDPRINT.COLHEADERS 39217 . 39855) (CDPRINT.COLUMNS 39857 . 43736) (CDTEDIT 43738 . 44369)) (44372
|
||||
52741 (CDMAP 44382 . 45814) (CDENTRY 45816 . 46125) (CDSUBSET 46127 . 47566) (CDMERGE 47568 . 51422) (
|
||||
CDMERGE.COMMON 51424 . 52739)) (52742 60280 (BINCOMP 52752 . 57041) (EOLTYPE 57043 . 59605) (
|
||||
EOLTYPE.SHOW 59607 . 60278)) (60808 74015 (FIND-UNCOMPILED-FILES 60818 . 64461) (FIND-UNSOURCED-FILES
|
||||
64463 . 67272) (FIND-SOURCE-FILES 67274 . 68978) (FIND-COMPILED-FILES 68980 . 71058) (
|
||||
FIND-UNLOADED-FILES 71060 . 71804) (FIND-LOADED-FILES 71806 . 72360) (FIND-MULTICOMPILED-FILES 72362
|
||||
. 74013)) (74016 82218 (CREATED-AS 74026 . 78823) (SOURCE-FOR-COMPILED-P 78825 . 81523) (
|
||||
COMPILE-SOURCE-DATE-DIFF 81525 . 82216)) (82219 92525 (FIX-DIRECTORY-DATES 82229 . 85222) (
|
||||
FIX-EQUIV-DATES 85224 . 86749) (COPY-COMPARED-FILES 86751 . 88572) (COPY-MISSING-FILES 88574 . 90731)
|
||||
(COMPILED-ON-SAME-SOURCE 90733 . 92523)) (92719 100458 (CDBROWSER 92729 . 97353) (CDBROWSER.STRINGS
|
||||
97355 . 100456)) (100620 101892 (CD.TABLEITEM 100630 . 100850) (CD.TABLEITEM.PRINTFN 100852 . 101051)
|
||||
(CD.TABLEITEM.COPYFN 101053 . 101647) (CDTABLEBROWSER.HEADING.REPAINTFN 101649 . 101890)) (101893
|
||||
112086 (CDTABLEBROWSER.WHENSELECTEDFN 101903 . 102371) (CD.COMMANDSELECTEDFN 102373 . 105764) (
|
||||
CD-MENUFN 105766 . 112084)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,13 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 3-Jan-2022 08:40:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;106 42666
|
||||
(FILECREATED "25-Jan-2022 16:05:14" {MM}<lispusers>COMPARESOURCES.;115 41781
|
||||
|
||||
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN CSOBJ.COPYBUTTONEVENTINFN)
|
||||
(VARS COMPARESOURCESCOMS)
|
||||
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN)
|
||||
|
||||
:PREVIOUS-DATE "27-Dec-2021 11:56:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;105)
|
||||
:PREVIOUS-DATE "24-Jan-2022 23:12:17" {MM}<lispusers>COMPARESOURCES.;113)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -143,15 +140,17 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
'SAME])
|
||||
|
||||
(\CS.COMPARE.MASTERS
|
||||
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 19-Dec-2021 21:05 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 23:26 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 10:00 by rmk")
|
||||
(* ; "Edited 2-Dec-2021 14:25 by rmk:")
|
||||
(* ; "Edited 27-Nov-2021 12:31 by rmk:")
|
||||
[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))
|
||||
@@ -555,50 +554,52 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
ELSE (ADD LINELENGTH (CHARWIDTH C FONT])
|
||||
|
||||
(CSOBJ.BUTTONEVENTINFN
|
||||
[LAMBDA (OBJ WINDOW) (* ; "Edited 26-Dec-2021 16:28 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 14:09 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 11:01 by rmk")
|
||||
(* ; "Edited 12-Dec-2021 21:30 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 10:21 by rmk")
|
||||
(* ; "Edited 7-Dec-2021 17:49 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 20:05 by rmk")
|
||||
[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)))
|
||||
(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.")
|
||||
(* ;; "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 (OBJ.FIND.REGION WINDOW OBJ))
|
||||
(FETCH (REGION HEIGHT)
|
||||
OBJREGION))
|
||||
(FETCH (REGION TOP) OF (WINDOWREGION WINDOW]
|
||||
(IF (IMAGEOBJPROP OBJ 'ONLYONE)
|
||||
THEN [SEDIT:SEDIT
|
||||
(OR DEF1 DEF2)
|
||||
`(:REGION ,(RELGETREGION 600 (CL:IF (ILESSP (COUNT (OR DEF1 DEF2))
|
||||
100)
|
||||
150
|
||||
400)
|
||||
'LEFT
|
||||
'TOP NIL NIL T]
|
||||
ELSE (* ; "Spread the arguments")
|
||||
(EXAMINEDEFS NAME TYPE DEF1 DEF2 TITLE1 TITLE2
|
||||
(RELGETREGION 800 (CL:IF (ILESSP (IMAX (COUNT DEF1)
|
||||
(COUNT DEF2))
|
||||
100)
|
||||
150
|
||||
400)
|
||||
'LEFT
|
||||
'TOP NIL NIL T])])
|
||||
[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")
|
||||
@@ -625,14 +626,14 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(CSBROWSER
|
||||
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION) (* ; "Edited 26-Dec-2021 21:06 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 22:48 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 09:55 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:38 by rmk")
|
||||
(* ; "Edited 10-Dec-2021 12:03 by rmk")
|
||||
[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))
|
||||
@@ -651,24 +652,24 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
" and "
|
||||
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY]
|
||||
(SELECTQ COMPARESOURCES-BROWSER-TYPE
|
||||
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL NIL TITLE NIL T (FONTPROP
|
||||
DEFAULTFONT
|
||||
'HEIGHT]
|
||||
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T
|
||||
(FONTPROP DEFAULTFONT 'HEIGHT]
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
|
||||
(GETPROMPTWINDOW WINDOW T)
|
||||
(WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
|
||||
(PROG1 (COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
|
||||
DW? WINDOW)
|
||||
(OPENW WINDOW))))
|
||||
(TEDIT [LET ((TSTREAM (OPENTEXTSTREAM)))
|
||||
(COMPARESOURCES FILEX FILEY '(T 2WINDOWS)
|
||||
DW? WINDOW)
|
||||
(OPENW WINDOW)
|
||||
WINDOW))
|
||||
(TEDIT (LET ((TSTREAM (OPENTEXTSTREAM)))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(PROG1 (COMPARESOURCES FILEX FILEY EXAMINE DW? TSTREAM)
|
||||
[TEDIT TSTREAM NIL NIL `(READONLY T WINDOWTYPE COMPARESOURCES-TEDIT
|
||||
TITLE ,TITLE]
|
||||
(CL:WHEN NIL
|
||||
EXAMINE
|
||||
(COMPARESOURCES FILEX FILEY EXAMINE DW? (OPENSTREAM '{NULL}
|
||||
'OUTPUT))))])
|
||||
(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])
|
||||
)
|
||||
|
||||
@@ -689,16 +690,16 @@ Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1920 27703 (COMPARESOURCES 1930 . 8443) (\CS.COMPARE.MASTERS 8445 . 16581) (
|
||||
\CS.COMPARE.TYPES 16583 . 19721) (\CS.EXAMINE 19723 . 23950) (\CS.FIXFNS 23952 . 25454) (
|
||||
\CS.SORT.DECLARES 25456 . 25799) (\CS.SORT.DECLARE1 25801 . 27221) (\CS.FILTER.GARBAGE 27223 . 27701))
|
||||
(27704 31684 (\CS.ISFNFORM 27714 . 27982) (\CS.COMPARE.FNS 27984 . 28226) (\CS.FNSID 28228 . 28372) (
|
||||
\CS.ISVARFORM 28374 . 28479) (\CS.COMPARE.VARS 28481 . 29143) (\CS.ISMACROFORM 29145 . 29283) (
|
||||
\CS.ISRECFORM 29285 . 29378) (\CS.ISCOURIERFORM 29380 . 29480) (\CS.ISTEMPLATEFORM 29482 . 29580) (
|
||||
\CS.COMPARE.TEMPLATES 29582 . 29947) (\CS.ISPROPFORM 29949 . 30104) (\CS.PROP.NAME 30106 . 30251) (
|
||||
\CS.COMPARE.PROPS 30253 . 30410) (\CS.ISADDVARFORM 30412 . 30505) (\CS.COMPARE.ADDVARS 30507 . 30672)
|
||||
(\CS.ISFPKGCOMFORM 30674 . 30881) (\CS.COMPARE.FPKGCOMS 30883 . 31090) (\CS.COMPARE.DEFINE-FILE-INFO
|
||||
31092 . 31682)) (31685 38243 (CSOBJ.CREATE 31695 . 32108) (CSOBJ.DISPLAYFN 32110 . 32863) (
|
||||
CSOBJ.IMAGEBOXFN 32865 . 35026) (CSOBJ.BUTTONEVENTINFN 35028 . 37993) (CSOBJ.COPYBUTTONEVENTINFN 37995
|
||||
. 38241)) (39107 42184 (CSBROWSER 39117 . 42182)))))
|
||||
(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.
@@ -1,22 +1,28 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 2-Jan-2022 23:15:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;19 6871
|
||||
(FILECREATED "25-Jan-2022 10:20:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;31 11252
|
||||
|
||||
:CHANGES-TO (FNS EXAMINEFILES)
|
||||
|
||||
:PREVIOUS-DATE "30-Dec-2021 21:49:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;18)
|
||||
: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 EXAMINEFILES)
|
||||
(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 24-Dec-2021 22:39 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.")
|
||||
@@ -30,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?)")
|
||||
|
||||
@@ -68,65 +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])
|
||||
|
||||
(EXAMINEFILES
|
||||
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "Edited 2-Jan-2022 23:15 by rmk")
|
||||
[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")
|
||||
|
||||
(* ;; "We get a region, then split it in half. Should we attach or at least co-move and co-close the 2 windows?")
|
||||
|
||||
(CL:UNLESS REGION
|
||||
(SETQ REGION (GETREGION)))
|
||||
(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])
|
||||
(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 (510 6809 (EXAMINEDEFS 520 . 5811) (EXAMINEFILES 5813 . 6807)))))
|
||||
(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.
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.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 2-Jan-2022 16:01:26"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;99 31663
|
||||
(FILECREATED "27-Jan-2022 13:24:29"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;106 34264
|
||||
|
||||
:CHANGES-TO (FNS SET-TYPED-REGIONS \RELCREATEREGION.REF \RELCREATEREGION.SIZE)
|
||||
:CHANGES-TO (FNS RELCREATEREGION \RELCREATEREGION.SIZE RELGETREGION)
|
||||
|
||||
:PREVIOUS-DATE " 1-Jan-2022 23:14:42"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;95)
|
||||
:PREVIOUS-DATE "25-Jan-2022 15:38:10"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;105)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT REGIONMANAGERCOMS)
|
||||
@@ -30,7 +30,7 @@
|
||||
|
||||
(* ;; "Relative regions")
|
||||
|
||||
(COMS (FNS RELCREATEREGION RELGETREGION)
|
||||
(COMS (FNS RELCREATEREGION RELGETREGION RELCREATEPOSITION)
|
||||
(FNS \RELCREATEREGION.REF \RELCREATEREGION.SIZE))
|
||||
|
||||
(* ;; "Composite application construction")
|
||||
@@ -250,7 +250,11 @@
|
||||
(DEFINEQ
|
||||
|
||||
(RELCREATEREGION
|
||||
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) (* ; "Edited 30-Dec-2021 20:54 by rmk")
|
||||
[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. ")
|
||||
@@ -274,99 +278,129 @@
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Resolve the width and height, if based on a region or window ")
|
||||
(* ;; "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.")
|
||||
|
||||
(SETQ WIDTH (\RELCREATEREGION.SIZE WIDTH 'X))
|
||||
(SETQ HEIGHT (\RELCREATEREGION.SIZE HEIGHT 'Y))
|
||||
(IF (AND (LISTP WIDTH)
|
||||
(NOT (REGIONP WIDTH))
|
||||
(NULL HEIGHT)
|
||||
(IGREATERP (LENGTH WIDTH)
|
||||
3))
|
||||
THEN
|
||||
(* ;; "If less than 3, presumably a relative width")
|
||||
|
||||
(* ;; "Resolve the corner")
|
||||
(APPLY (FUNCTION RELCREATEREGION)
|
||||
WIDTH)
|
||||
ELSE
|
||||
(* ;; "Resolve the width and height, if based on a region or window ")
|
||||
|
||||
(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)))
|
||||
(SETQ WIDTH (\RELCREATEREGION.SIZE WIDTH 'X))
|
||||
(SETQ HEIGHT (\RELCREATEREGION.SIZE HEIGHT 'Y))
|
||||
|
||||
(* ;; "Resolve the reference point")
|
||||
(* ;; "Resolve the corner")
|
||||
|
||||
[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]
|
||||
(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)))
|
||||
|
||||
(* ;; "Align the new-region corner with the reference point")
|
||||
(* ;; "Resolve 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. ")
|
||||
(CL:WHEN (ILESSP LEFT 0)
|
||||
(ADD WIDTH LEFT)
|
||||
(SETQ LEFT 0))
|
||||
(CL:WHEN (ILESSP BOTTOM 0)
|
||||
(ADD HEIGHT 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])
|
||||
[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 28-Dec-2021 23:13 by rmk")
|
||||
[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.")
|
||||
|
||||
(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)))
|
||||
(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)")
|
||||
(* ;; "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])
|
||||
(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 2-Jan-2022 11:01 by rmk")
|
||||
[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")
|
||||
(* ; "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")
|
||||
@@ -386,7 +420,8 @@
|
||||
ELSEIF [AND (LISTP REF)
|
||||
(SETQ ANCHOR (OR (REGIONP (CAR REF))
|
||||
(AND (WINDOWP (CAR REF))
|
||||
(WINDOWREGION (CAR REF)))
|
||||
(WINDOWPROP (CAR REF)
|
||||
'REGION))
|
||||
(AND (EQ (CAR REF)
|
||||
'SCREEN)
|
||||
'SCREEN]
|
||||
@@ -417,7 +452,7 @@
|
||||
ELSE (\ILLEGAL.ARG REF])
|
||||
|
||||
(\RELCREATEREGION.SIZE
|
||||
[LAMBDA (PARAM WHICH) (* ; "Edited 2-Jan-2022 11:00 by rmk")
|
||||
[LAMBDA (PARAM WHICH) (* ; "Edited 2-Jan-2022 11:00 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 17:51 by rmk")
|
||||
|
||||
(* ;;
|
||||
@@ -591,8 +626,9 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1602 3789 (SET-TYPED-REGIONS 1612 . 3787)) (3790 10791 (RM-CREATEW 3800 . 6307) (
|
||||
RM-CLOSEW 6309 . 7710) (RM-GETREGION 7712 . 10298) (CLOSE-TYPED-W 10300 . 10789)) (11707 16778 (
|
||||
RELCREATEREGION 11717 . 14876) (RELGETREGION 14878 . 16776)) (16779 21898 (\RELCREATEREGION.REF 16789
|
||||
. 19646) (\RELCREATEREGION.SIZE 19648 . 21896)) (21951 31293 (RM-ATTACHWINDOW 21961 . 31291)))))
|
||||
(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
|
||||
|
||||
Binary file not shown.
@@ -37,10 +37,12 @@ NIL: LASTMOUSEX/LASTMOUSEY
|
||||
(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.
|
||||
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.
|
||||
@@ -56,4 +58,4 @@ TIMESROMAN $ TERMINAL MODERN MODERN
|
||||
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 ÿü
|
||||
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,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 2-Jan-2022 22:03:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104 6489
|
||||
(FILECREATED "12-Jan-2022 13:16:00"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;110 7695
|
||||
|
||||
:CHANGES-TO (VARS TEDIT-PF-SEECOMS)
|
||||
:CHANGES-TO (FNS PF-TEDIT)
|
||||
|
||||
:PREVIOUS-DATE "30-Dec-2021 23:17:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;103)
|
||||
: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)
|
||||
@@ -22,7 +22,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(PF-TEDIT
|
||||
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 30-Dec-2021 23:17 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.")
|
||||
|
||||
@@ -76,13 +77,27 @@
|
||||
THEN (SETFILEPTR ISTREAM (POP LOC))
|
||||
(SETQ EXPR (WITH-READER-ENVIRONMENT ENV (READ ISTREAM))
|
||||
)
|
||||
(IF (EQ FN (CAR EXPR))
|
||||
THEN (DSPFONT BOLDFONT TSTREAM)
|
||||
(PRINT FN TSTREAM)
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(SETQ EXPR (CADR EXPR))
|
||||
(PRINTDEF EXPR 3 NIL NIL NIL TSTREAM)
|
||||
ELSE (PRINTDEF EXPR NIL NIL NIL NIL TSTREAM))
|
||||
(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)
|
||||
@@ -127,5 +142,5 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (956 6010 (PF-TEDIT 966 . 6008)))))
|
||||
(FILEMAP (NIL (947 7216 (PF-TEDIT 957 . 7214)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "30-Dec-2021 21:22:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;100 48929
|
||||
(FILECREATED "27-Jan-2022 13:20:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;109 49971
|
||||
|
||||
:CHANGES-TO (FNS COMPARETEXT.TEXTOBJ)
|
||||
|
||||
:PREVIOUS-DATE "27-Dec-2021 15:56:54"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;98)
|
||||
:PREVIOUS-DATE "23-Jan-2022 20:22:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;108)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -33,11 +33,9 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARETEXT
|
||||
[LAMBDA (FILE1 FILE2 HASH.TYPE REGION FILELABELS) (* ; "Edited 22-Dec-2021 23:49 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 REGION. If REGION = NIL, the user is asked to specify a region. If REGION = T, a standard region is used.")
|
||||
|
||||
@@ -45,8 +43,10 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
((PARA LINE WORD))
|
||||
(NIL (SETQ HASH.TYPE 'PARA))
|
||||
(ERROR (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)))
|
||||
(LET ((FULLFILE1 (FINDFILE FILE1 T))
|
||||
(FULLFILE2 (FINDFILE FILE2 T)))
|
||||
(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
|
||||
@@ -55,17 +55,22 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(create IMCOMPARE.CHUNK
|
||||
FILENAME _ FULLFILE2
|
||||
FILEPTR _ 0)
|
||||
HASH.TYPE NIL FILELABELS])
|
||||
HASH.TYPE REGION FILELABELS TITLE])
|
||||
|
||||
(COMPARETEXT.WINDOW
|
||||
[LAMBDA (GRAPH REGION) (* ; "Edited 27-Dec-2021 13:47 by rmk")
|
||||
(* ; "Edited 25-Dec-2021 11:40 by rmk")
|
||||
[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 GWIDTH (FILEPREFIX (CAR (GRAPHERPROP GRAPH 'FILELABELS]
|
||||
[SETQ REGION
|
||||
(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
|
||||
@@ -73,35 +78,38 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif (REGIONP REGION)
|
||||
else (CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please specify a region for the comparison graph" T)
|
||||
(SETQ GRAPHREGION (GRAPHREGION GRAPH))
|
||||
(SETQ GWIDTH (FETCH (REGION WIDTH) OF GRAPHREGION))
|
||||
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")
|
||||
|
||||
(SETQ REGION (RELGETREGION (IPLUS (TIMES 2 WBorder)
|
||||
GWIDTH)
|
||||
[IMIN 200 (IPLUS (FETCH (REGION HEIGHT) OF GRAPHREGION)
|
||||
(ITIMES 2 (FONTHEIGHT DEFAULTFONT]
|
||||
'RIGHT
|
||||
'TOP]
|
||||
[SETQ WINDOW (CREATEW REGION (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]
|
||||
(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 GWIDTH (FETCH (REGION WIDTH) OF (WINDOWREGION WINDOW)))
|
||||
(WINDOWPROP WINDOW 'MAXSIZE (CONS GWIDTH MAX.SMALLP)))
|
||||
(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)
|
||||
@@ -122,41 +130,37 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
WINDOW])
|
||||
|
||||
(COMPARETEXT.TEXTOBJ
|
||||
[LAMBDA (NODE WINDOW INCOL1) (* ; "Edited 30-Dec-2021 21:21 by rmk")
|
||||
[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 (NODEID (FETCH (GRAPHNODE NODEID) OF NODE)))
|
||||
(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 REGION (RELCREATEREGION 475 600 (CL:IF INCOL1
|
||||
'RIGHT
|
||||
'LEFT)
|
||||
'TOP
|
||||
(CL:IF INCOL1
|
||||
`(,WINDOW 0.5 -1)
|
||||
`(,WINDOW 0.5 1))
|
||||
`(,WINDOW BOTTOM -2)
|
||||
T))
|
||||
(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)
|
||||
(IF COMPARETEXT.AUTOTEDIT
|
||||
THEN
|
||||
(* ;;
|
||||
"Just use it as created, don't prompt for adjustments")
|
||||
|
||||
REGION
|
||||
ELSE (RELGETREGION REGION NIL (CL:IF INCOL1
|
||||
'RIGHT
|
||||
'LEFT)
|
||||
'TOP))
|
||||
NIL
|
||||
`(READONLY T LEAVETTY T]
|
||||
REGION NIL `(READONLY T LEAVETTY T]
|
||||
(SETQ TWINDOW (WFROMDS TSTREAM))
|
||||
(SETQ TEXTOBJ (TEXTOBJ TSTREAM))
|
||||
(WINDOWPROP WINDOW (CL:IF INCOL1
|
||||
@@ -173,20 +177,24 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
WINDOWPOSITION
|
||||
W)))
|
||||
TOBJ TW)
|
||||
(CL:WHEN (SETQ TOBJ (WINDOWPROP
|
||||
W
|
||||
'COL1TEXTOBJ))
|
||||
(MOVEW (SETQ TW (WFROMDS (TEXTSTREAM
|
||||
TOBJ)))
|
||||
(PTPLUS DELTA (WINDOWPOSITION
|
||||
TW))))
|
||||
(CL:WHEN (SETQ TOBJ (WINDOWPROP
|
||||
W
|
||||
'COL2TEXTOBJ))
|
||||
(MOVEW (SETQ TW (WFROMDS (TEXTSTREAM
|
||||
TOBJ)))
|
||||
(PTPLUS DELTA (WINDOWPOSITION
|
||||
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])
|
||||
|
||||
@@ -246,7 +254,7 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(WINDOWPROP WINDOW 'LASTNODES (LIST NODE1 NODE2])
|
||||
|
||||
(IMCOMPARE.CHUNKS
|
||||
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION FILELABELS) (* ; "Edited 25-Dec-2021 13:02 by rmk")
|
||||
[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")
|
||||
|
||||
@@ -302,11 +310,13 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
|
||||
(* ;; "The file comparison is complete. Format and display the file difference graph")
|
||||
|
||||
(IMCOMPARE.DISPLAYGRAPH CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS])
|
||||
(IMCOMPARE.DISPLAYGRAPH CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS
|
||||
TITLE])
|
||||
|
||||
(IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 24-Dec-2021 22:30 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")
|
||||
|
||||
@@ -338,11 +348,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH)
|
||||
of CHUNK)))
|
||||
WHILE (SETQ CHUNK (IMCOMPARE.HASH STREAM HASH.TYPE ENDPOS))
|
||||
COLLECT (REPLACE FILENAME OF CHUNK WITH FILENAME)
|
||||
COLLECT (REPLACE (IMCOMPARE.CHUNK FILENAME) OF CHUNK WITH FILENAME)
|
||||
CHUNK))])
|
||||
|
||||
(IMCOMPARE.DISPLAYGRAPH
|
||||
[LAMBDA (CHUNK1 CHUNK2 HASH.TYPE REGION CHUNKLIST1 CHUNKLIST2 FILELABELS)
|
||||
[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")
|
||||
@@ -459,7 +470,7 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
COL1X
|
||||
,COL1X COL2X ,COL2X ALLCHUNKS
|
||||
,COMPARETEXT.ALLCHUNKS]
|
||||
(SHOWGRAPH GRAPH (COMPARETEXT.WINDOW GRAPH REGION)
|
||||
(SHOWGRAPH GRAPH (COMPARETEXT.WINDOW GRAPH REGION TITLE)
|
||||
(FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
|
||||
T NIL])
|
||||
@@ -770,12 +781,12 @@ Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1344 41549 (COMPARETEXT 1354 . 2933) (COMPARETEXT.WINDOW 2935 . 7132) (
|
||||
COMPARETEXT.TEXTOBJ 7134 . 12023) (COMPARETEXT.SETSEL 12025 . 12815) (CHUNKNODELABEL 12817 . 13938) (
|
||||
IMCOMPARE.BOXNODE 13940 . 14707) (IMCOMPARE.CHUNKS 14709 . 19062) (IMCOMPARE.COLLECT.HASH.CHUNKS 19064
|
||||
. 21842) (IMCOMPARE.DISPLAYGRAPH 21844 . 29570) (IMCOMPARE.HASH 29572 . 33759) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 33761 . 37257) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 37259 . 39214) (
|
||||
IMCOMPARE.SHOW.DIST 39216 . 39662) (IMCOMPARE.UPDATE.SYMBOL.TABLE 39664 . 41547)) (41550 47707 (
|
||||
IMCOMPARE.LEFTBUTTONFN 41560 . 44137) (IMCOMPARE.MIDDLEBUTTONFN 44139 . 47255) (IMCOMPARE.COPYBUTTONFN
|
||||
47257 . 47705)) (47760 48451 (TAIL1 47770 . 48124) (TAIL2 48126 . 48449)))))
|
||||
(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.
@@ -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.
120
sources/COREIO
120
sources/COREIO
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 3-Jan-2022 20:02:51" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;4 55136
|
||||
(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 "22-Nov-2021 09:25:42"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;3)
|
||||
: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")
|
||||
@@ -710,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")
|
||||
|
||||
@@ -729,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)
|
||||
@@ -955,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 (1707 44342 (\CORE.CLOSEFILE 1717 . 2490) (\CORE.DELETEFILE 2492 . 4478) (
|
||||
\CORE.DIRECTORYNAMEP 4480 . 4741) (\CORE.FINDPAGE 4743 . 7972) (\CORE.GENERATEFILES 7974 . 10561) (
|
||||
\CORE.NEXTFILEFN 10563 . 11062) (\CORE.FILEINFOFN 11064 . 11293) (\CORE.GETFILEHANDLE 11295 . 13449) (
|
||||
\CORE.GETFILEINFO 13451 . 14414) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14416 . 15953) (\CORE.GETFILENAME
|
||||
15955 . 18244) (\CORE.GETINFOBLOCK 18246 . 20869) (\CORE.NAMESCAN 20871 . 22638) (\CORE.NAMESEGMENT
|
||||
22640 . 23077) (\CORE.OPENFILE 23079 . 26198) (\COREFILE.SETPARAMETERS 26200 . 28381) (
|
||||
\CORE.PACKFILENAME 28383 . 28778) (\CORE.RELEASEPAGES 28780 . 29381) (\CORE.SETFILEPTR 29383 . 30482)
|
||||
(\CORE.UPDATEOF 30484 . 32113) (\CORE.BACKFILEPTR 32115 . 34323) (\CORE.SETEOFPTR 34325 . 36194) (
|
||||
\CORE.SETACCESSTIME 36196 . 36821) (\CORE.SETFILEINFO 36823 . 39125) (\CORE.GETNEXTBUFFER 39127 .
|
||||
43083) (\CORE.UNPACKFILENAME 43085 . 44340)) (44343 47976 (COREDEVICE 44353 . 44524) (
|
||||
\CREATECOREDEVICE 44526 . 47974)) (47977 50278 (\NODIRCOREFDEV 47987 . 48584) (\NODIRCORE.OPENFILE
|
||||
48586 . 50276)))))
|
||||
(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