Compare commits
67 Commits
medley-211
...
medley-220
| Author | SHA1 | Date | |
|---|---|---|---|
|
ab8e97ff7b | ||
|
f8e4bbd7cb | ||
|
c7272e78f2 | ||
|
|
f531e89dde | ||
|
|
293c973f1d | ||
|
|
fe62e8e6e2 | ||
|
|
51f0c19ad1 | ||
|
|
1438ddba1f | ||
|
|
ae3851ccf9 | ||
|
|
e3f9a4ca9a | ||
|
|
7966704f1e | ||
|
|
311e4f049c | ||
|
|
e119314a9e | ||
|
|
27d4df45e6 | ||
|
|
312e99b0f4 | ||
|
|
82eaacc542 | ||
|
|
479de87011 | ||
|
|
5445a12b7e | ||
|
|
fadf81012b | ||
|
|
792edfdad5 | ||
|
fd2e5ed93e | ||
|
|
e3e9156452 | ||
|
|
f0feca759b | ||
|
|
5fadc6c083 | ||
|
|
2dcfac5350 | ||
|
|
dcd83c3753 | ||
|
|
cde5c9018d | ||
|
|
1108a00b90 | ||
|
|
d9e445ad8c | ||
|
|
5b690d39d1 | ||
|
2573e4351f | ||
|
|
936bdd84b5 | ||
|
|
c2915bf5d3 | ||
|
|
40c10a7841 | ||
|
|
362fac9389 | ||
|
|
db082b37e1 | ||
|
|
c0e020f033 | ||
|
|
9af86df169 | ||
|
|
6c26fe958a | ||
|
|
339bd47107 | ||
|
|
3a04303d93 | ||
|
|
68f1e7efe1 | ||
|
|
993bdb2e00 | ||
|
7a27c26f01 | ||
|
|
75a031de39 | ||
|
|
7d656006a6 | ||
|
|
1f8c123184 | ||
|
|
50ce484c1b | ||
|
|
e3f043b40d | ||
|
|
945df5fbe8 | ||
|
|
3d8066b7e8 | ||
|
|
b303e0affa | ||
|
|
869b3a2e32 | ||
|
|
f19d9cc5e2 | ||
|
|
237f3aa6bf | ||
|
|
89a8fe183d | ||
|
|
8266980c22 | ||
|
|
c385039c42 | ||
|
|
1ff0018772 | ||
|
|
6611f96702 | ||
|
|
824e0f20b2 | ||
|
|
d479ef2ef9 | ||
|
|
98aa15455e | ||
|
|
ca069578c3 | ||
|
|
23731b05d1 | ||
|
|
a315e6926f | ||
|
|
1c9c1da257 |
8
.github/workflows/buildDocker.yml
vendored
8
.github/workflows/buildDocker.yml
vendored
@@ -50,6 +50,8 @@ jobs:
|
||||
echo ::set-output name=docker_image::${DOCKER_IMAGE}
|
||||
echo ::set-output name=build_time::$(date -u +'%Y-%m-%dT%H:%M:%SZ')
|
||||
echo ::set-output name=version::${VERSION}
|
||||
echo ::set-output name=maiko_release::${MAIKO_RELEASE}
|
||||
echo ::set-output name=medley_release::${MEDLEY_RELEASE}
|
||||
|
||||
# Download Medley Release Assets
|
||||
- name: Download Release Assets
|
||||
@@ -103,4 +105,8 @@ jobs:
|
||||
# Push the created image
|
||||
push: true
|
||||
# tags to assign to the Docker image
|
||||
tags: ${{ steps.prep.outputs.tags }}
|
||||
tags: ${{ steps.prep.outputs.tags }}
|
||||
build-args: |
|
||||
medley_release=${{steps.prep.outputs.medley_release}}
|
||||
maiko_release=${{steps.prep.outputs.maiko_release}}
|
||||
build_date=${{steps.prep.outputs.build_time}}
|
||||
|
||||
2
.github/workflows/buildLoadup.yml
vendored
2
.github/workflows/buildLoadup.yml
vendored
@@ -103,4 +103,4 @@ jobs:
|
||||
tag: ${{ env.tag }}
|
||||
draft: true
|
||||
bodyfile: tmp/release-notes.md
|
||||
token: ${{ secrets.GITHUB_TOKEN }}
|
||||
token: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
15
Dockerfile
15
Dockerfile
@@ -1,20 +1,25 @@
|
||||
FROM ubuntu:focal
|
||||
ARG BUILD_DATE
|
||||
ARG build_date
|
||||
ARG medley_release
|
||||
ARG maiko_release
|
||||
LABEL name="Medley"
|
||||
# LABEL tags=${tags}
|
||||
LABEL description="The Medley Interlisp environment"
|
||||
LABEL url="https://github.com/Interlisp/medley"
|
||||
LABEL build-time=$BUILD_DATE
|
||||
LABEL build-time=$build_date
|
||||
ENV BUILD_DATE=$build_date
|
||||
ENV MEDLEY_RELEASE=$medley_release
|
||||
ENV MAIKO_RELEASE=$maiko_release
|
||||
|
||||
RUN apt-get update && apt-get install -y tightvncserver
|
||||
|
||||
EXPOSE 5900
|
||||
|
||||
# Copy and uncompress loadup and required source files.
|
||||
ADD *.tgz /app
|
||||
ADD *.tgz /home
|
||||
|
||||
WORKDIR /app/medley
|
||||
WORKDIR /home/medley
|
||||
|
||||
RUN adduser --disabled-password --gecos "" medley
|
||||
USER medley
|
||||
ENTRYPOINT USER=medley Xvnc -geometry 1280x720 :0 & DISPLAY=:0 PATH="/app/maiko:$PATH" ./run-medley -full -g 1280x720 -sc 1280x720
|
||||
ENTRYPOINT USER=medley Xvnc -geometry 1280x720 :0 & DISPLAY=:0 PATH="/app/maiko:$PATH" ./run-medley -full -g 1280x720 -sc 1280x720
|
||||
|
||||
@@ -14,7 +14,7 @@ There (soon) will also be Docker containers with the latest, and a way to try ou
|
||||
|
||||
### Getting releases
|
||||
|
||||
Get the Maiko release [here](https://github.com/Interlisp/maiko/releases). You'll need the one corresponding to your operating system and processor (for Windows with WSL or Intel linux, use `linux.x86_64`; for Macs use `darwin.x86_64` for Intel and `darwin.aarch64` for M1.)
|
||||
Get the Maiko release [here](https://github.com/Interlisp/maiko/releases). You'll need the one corresponding to your operating system and processor (for Windows with WSL or Intel Linux, use `linux.x86_64`; for Macs use `darwin.x86_64` for Intel and `darwin.aarch64` for M1.)
|
||||
|
||||
Or, build your own maiko (the binaries `lde` `ldex` and `ldeinit`.) We can build for other OS arch pairs depending on what is available for GitHub actions.
|
||||
|
||||
@@ -99,7 +99,7 @@ Or from the Common Lisp prompt with:
|
||||
```
|
||||
(IL:LOGOUT)
|
||||
```
|
||||
When you logout of the system, Medley automatically creates a binary
|
||||
When you log out of the system, Medley automatically creates a binary
|
||||
dump of your system located in your home directory named
|
||||
`lisp.virtualmem`. The next time you run the system, if you don't
|
||||
specify a specific image to run, Medley restores that image so that
|
||||
|
||||
Binary file not shown.
@@ -1,18 +1,21 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Nov-2021 22:34:49" {DSK}<home>larry>medley>greetfiles>MEDLEYDIR-INIT.;2 2303
|
||||
(FILECREATED " 2-Dec-2021 21:13:55" {DSK}<home>larry>medley>greetfiles>MEDLEYDIR-INIT.;3 2392
|
||||
|
||||
changes to%: (VARS MEDLEYDIR-INITCOMS)
|
||||
(FNS INTERLISPMODE)
|
||||
|
||||
previous date%: "14-Nov-2021 22:10:37" {DSK}<home>larry>medley>greetfiles>medleydir-INIT.;1)
|
||||
previous date%: "14-Nov-2021 22:34:49" {DSK}<home>larry>medley>greetfiles>MEDLEYDIR-INIT.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEYDIR-INITCOMS)
|
||||
|
||||
(RPAQQ MEDLEYDIR-INITCOMS
|
||||
((P (LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
|
||||
([P (LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
|
||||
"")
|
||||
"/sources/MEDLEYDIR.LCOM")))
|
||||
"/sources/MEDLEYDIR.LCOM"))
|
||||
(MEDLEY-INIT-VARS)
|
||||
(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
|
||||
(FILES BACKGROUND-YIELD)
|
||||
(VARS (FILING.ENUMERATION.DEPTH 1)
|
||||
[LOGINDIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
|
||||
@@ -20,13 +23,16 @@
|
||||
[USERGREETFILES `((,LOGINDIR "INIT" COM)
|
||||
(,LOGINDIR "INIT"]
|
||||
(COPYRIGHTSRESERVED NIL))
|
||||
[P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
|
||||
(FNS INTERLISPMODE)))
|
||||
|
||||
(LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
|
||||
"")
|
||||
"/sources/MEDLEYDIR.LCOM"))
|
||||
|
||||
(MEDLEY-INIT-VARS)
|
||||
|
||||
(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE))
|
||||
|
||||
(FILESLOAD BACKGROUND-YIELD)
|
||||
|
||||
(RPAQQ FILING.ENUMERATION.DEPTH 1)
|
||||
@@ -38,8 +44,6 @@
|
||||
(,LOGINDIR "INIT")))
|
||||
|
||||
(RPAQQ COPYRIGHTSRESERVED NIL)
|
||||
|
||||
(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE))
|
||||
(DEFINEQ
|
||||
|
||||
(INTERLISPMODE
|
||||
@@ -56,5 +60,5 @@
|
||||
:PACKAGE "INTERLISP"])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1455 2280 (INTERLISPMODE 1465 . 2278)))))
|
||||
(FILEMAP (NIL (1544 2369 (INTERLISPMODE 1554 . 2367)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -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
|
||||
1193
library/FILEBROWSER
1193
library/FILEBROWSER
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED "18-Aug-2021 12:13:11" {DSK}<home>larry>medley>library>MSANALYZE.;5 62745
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS MSPRGMACRO MSFINDP)
|
||||
(VARS MSMACROPROPS)
|
||||
(FILECREATED "26-Dec-2021 10:10:02" {DSK}<home>larry>medley>library>MSANALYZE.;6 62468
|
||||
|
||||
previous date%: "18-Aug-2021 10:56:25" {DSK}<home>larry>medley>library>MSANALYZE.;4)
|
||||
:CHANGES-TO (FNS MSPRGTEMPLATE)
|
||||
|
||||
:PREVIOUS-DATE "18-Aug-2021 12:13:11" {DSK}<home>larry>medley>library>MSANALYZE.;5)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -269,7 +269,7 @@ DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS MSVBNOTICED MACRO [OPENLAMBDA (VERB MOD)
|
||||
(CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED])
|
||||
(CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED])
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -752,19 +752,18 @@ DONTCOPY
|
||||
(CDR TEMPLATE])
|
||||
|
||||
(MSPRGTEMPLATE
|
||||
(LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* lmm "23-Jul-86 00:15")
|
||||
(BLOCK) (*
|
||||
"Masterscope should block every once and a while. This is one place to do it.")
|
||||
[LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* ; "Edited 26-Dec-2021 10:09 by larry")
|
||||
(* lmm "23-Jul-86 00:15")
|
||||
(PROG ((VARS VARS)
|
||||
TEM)
|
||||
(COND
|
||||
((EQ TEMPLATE 'MACRO)
|
||||
[(EQ TEMPLATE 'MACRO)
|
||||
(COND
|
||||
((SETQ TEM (GETMACROPROP (CAR PARENT)
|
||||
MSMACROPROPS))
|
||||
(MSPRGMACRO PARENT TEM))
|
||||
(T (MSPRGTEMPLATE1 PARENT '(CALL .. EVAL)))))
|
||||
(T (MSPRGTEMPLATE1 PARENT TEMPLATE))))))
|
||||
(T (MSPRGTEMPLATE1 PARENT '(CALL |..| EVAL]
|
||||
(T (MSPRGTEMPLATE1 PARENT TEMPLATE])
|
||||
|
||||
(MSPRGLAMBDA
|
||||
[LAMBDA (EXPR FLG TYPE) (* ; "Edited 3-Jun-88 10:23 by jrb:")
|
||||
@@ -1036,22 +1035,21 @@ DONTCOPY
|
||||
|
||||
(RPAQQ MSRECORDTRANFLG NIL)
|
||||
|
||||
(ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16
|
||||
$$17)
|
||||
(ADDTOVAR INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS INCLISP MACRO ((.X.)
|
||||
(COND
|
||||
((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.)))
|
||||
INCLISP)
|
||||
(T .X.))))
|
||||
(COND
|
||||
((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.)))
|
||||
INCLISP)
|
||||
(T .X.))))
|
||||
|
||||
(PUTPROPS LTEMPLATE MACRO [LAMBDA (Y)
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
|
||||
@@ -1265,10 +1263,10 @@ DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(PUTPROPS LTEMPLATE MACRO [LAMBDA (Y)
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
(DECLARE (LOCALVARS Y))
|
||||
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
|
||||
(GETHASH Y MSTEMPLATES]
|
||||
Y])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -1288,11 +1286,11 @@ DONTCOPY
|
||||
)
|
||||
(PUTPROPS MSANALYZE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1988 1990 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3820 11339 (VARS 3830 . 3971) (FREEVARS 3973 . 4126) (CALLS 4128 . 10469) (
|
||||
COLLECTFNDATA 10471 . 10850) (CALLS3 10852 . 11337)) (13596 52783 (ALLCALLS 13606 . 14285) (
|
||||
MSINITFNDATA 14287 . 14531) (MSPRGE 14533 . 21607) (MSPRGMACRO 21609 . 22205) (MSPRGCALL 22207 . 22531
|
||||
) (MSBINDVAR 22533 . 23052) (MSPRGRECORD 23054 . 29967) (MSPRGERR 29969 . 30137) (MSPRGTEMPLATE1 30139
|
||||
. 39300) (MSPRGTEMPLATE 39302 . 39982) (MSPRGLAMBDA 39984 . 49579) (MSPRGLST 49581 . 49749) (ADDTO
|
||||
49751 . 50542) (NLAMBDAFNP 50544 . 51296) (MSPRGDWIM 51298 . 52117) (MSDWIMTRAN 52119 . 52781)) (62109
|
||||
62541 (MSFINDP 62119 . 62539)))))
|
||||
(FILEMAP (NIL (3759 11278 (VARS 3769 . 3910) (FREEVARS 3912 . 4065) (CALLS 4067 . 10408) (
|
||||
COLLECTFNDATA 10410 . 10789) (CALLS3 10791 . 11276)) (13527 52635 (ALLCALLS 13537 . 14216) (
|
||||
MSINITFNDATA 14218 . 14462) (MSPRGE 14464 . 21538) (MSPRGMACRO 21540 . 22136) (MSPRGCALL 22138 . 22462
|
||||
) (MSBINDVAR 22464 . 22983) (MSPRGRECORD 22985 . 29898) (MSPRGERR 29900 . 30068) (MSPRGTEMPLATE1 30070
|
||||
. 39231) (MSPRGTEMPLATE 39233 . 39834) (MSPRGLAMBDA 39836 . 49431) (MSPRGLST 49433 . 49601) (ADDTO
|
||||
49603 . 50394) (NLAMBDAFNP 50396 . 51148) (MSPRGDWIM 51150 . 51969) (MSDWIMTRAN 51971 . 52633)) (61832
|
||||
62264 (MSFINDP 61842 . 62262)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,17 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED " 4-May-92 13:10:53" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;3| 23489
|
||||
|
||||
|changes| |to:| (TEMPLATES CL:DECF CL:INCF CL:PUSH)
|
||||
(FILECREATED "15-Jan-2022 20:17:21" |{DSK}<home>larry>medley>library>MSCOMMON.;4| 24053
|
||||
|
||||
|previous| |date:| "12-Jun-90 10:17:31" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;2|)
|
||||
:CHANGES-TO (TEMPLATES ADD-EXEC CL:ASSOC CL:COMPILE-FILE EXEC CL:IN-PACKAGE CL:MAKE-STRING OPEN
|
||||
CL:PUSH CL:PUSHNEW CL:RASSOC CL:WRITE-LINE CL:WRITE-STRING CL:WHEN CL:UNLESS
|
||||
)
|
||||
(FNS FUNCTIONSMSGETDEF FUNCTIONSMSMC VARIABLESMSGETDEF)
|
||||
(VARS MSCOMMONCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 4-May-92 13:10:53" |{DSK}<home>larry>medley>library>MSCOMMON.;3|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT MSCOMMONCOMS)
|
||||
|
||||
@@ -37,8 +42,8 @@
|
||||
CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP
|
||||
CL:STRING-UPCASE CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>=
|
||||
CL:SUBLIS CL:SUBSETP CL:SUBST CL:SUBST-IF CL:SUBST-IF-NOT CL:SUBSTITUTE
|
||||
CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:VECTOR-PUSH
|
||||
CL:VECTOR-PUSH-EXTEND WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING)
|
||||
CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:UNLESS CL:VECTOR-PUSH
|
||||
CL:VECTOR-PUSH-EXTEND CL:WHEN WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING)
|
||||
(P
|
||||
(* |;;| "First tell Masterscope how to find FUNCTIONS and VARIABLES")
|
||||
|
||||
@@ -46,7 +51,7 @@
|
||||
(MSADDANALYZE 'FUNCTIONS 'FUNCTION 'FUNCTIONS 'FUNCTIONSMSGETDEF 'FUNCTIONSMSMC)
|
||||
|
||||
(* |;;|
|
||||
"Then add KEYWORD support. Templates may now contain the following as their last element:")
|
||||
"Then add KEYWORD support. Templates may now contain the following as their last element:")
|
||||
|
||||
|
||||
(* |;;| "... KEYWORDS list of keywords accepted)")
|
||||
@@ -65,7 +70,7 @@
|
||||
(MSADDMODIFIER 'SPECIFY 'KEYWORDS 'KEYSPECIFY)
|
||||
|
||||
(* |;;|
|
||||
"Stuff for locally-defined things. We don't attempt to handle them (*sigh*), just record them.")
|
||||
"Stuff for locally-defined things. We don't attempt to handle them (*sigh*), just record them.")
|
||||
|
||||
(MSADDRELATION '(FLET FLETS FLETTING FLET))
|
||||
(MSADDRELATION '(LABEL LABELS LABELLING LABELLED))
|
||||
@@ -87,42 +92,48 @@
|
||||
(DEFINEQ
|
||||
|
||||
(FUNCTIONSMSGETDEF
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 31-Mar-88 17:31 by jrb:")
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 31-Mar-88 17:31 by jrb:")
|
||||
(LET ((BODY (REMOVE-COMMENTS (GETDEF NAME 'FUNCTIONS SOURCE OPTIONS))))
|
||||
(AND BODY (SELECTQ (CAR BODY)
|
||||
(DEFMACRO (OR (GETTEMPLATE NAME)
|
||||
(SETTEMPLATE NAME 'MACRO))
|
||||
NIL)
|
||||
(CL:DEFUN
|
||||
(* |;;| "Body is of the form:")
|
||||
(* |;;| "(DEFUN name (args...) bodies...)")
|
||||
(* |;;| "We want to hand Masterscope a massaged form it will understand.")
|
||||
(* |;;| "Which I believe is of this form:")
|
||||
(* |;;| "Body is of the form:")
|
||||
|
||||
`(CL:LAMBDA ,(CADDR BODY) ,@(CDDDR BODY)))
|
||||
(* |;;| "(DEFUN name (args...) bodies...)")
|
||||
|
||||
(* |;;|
|
||||
"We want to hand Masterscope a massaged form it will understand.")
|
||||
|
||||
(* |;;| "Which I believe is of this form:")
|
||||
|
||||
`(CL:LAMBDA ,(CADDR BODY)
|
||||
,@(CDDDR BODY)))
|
||||
NIL)))))
|
||||
|
||||
(FUNCTIONSMSMC
|
||||
(LAMBDA (NAME TYPE REASON) (* \; "Edited 1-Apr-88 13:47 by jrb:")
|
||||
(* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them")
|
||||
(LAMBDA (NAME TYPE REASON) (* \; "Edited 1-Apr-88 13:47 by jrb:")
|
||||
|
||||
(* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them")
|
||||
|
||||
(|if| (EQ (CAR (GETDEF NAME 'FUNCTIONS NIL '(NOERROR)))
|
||||
'DEFMACRO)
|
||||
'DEFMACRO)
|
||||
|then| (CHANGEMACRO NAME TYPE REASON)
|
||||
NIL
|
||||
|else| T)))
|
||||
|
||||
(VARIABLESMSGETDEF
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 19-Feb-88 19:46 by jrb:")
|
||||
|
||||
(LAMBDA (NAME TYPE SOURCE OPTIONS) (* \; "Edited 19-Feb-88 19:46 by jrb:")
|
||||
(LET ((BODY (GETDEF NAME 'VARIABLES SOURCE OPTIONS))
|
||||
SPECVARP)
|
||||
(AND BODY
|
||||
|
||||
(* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things")
|
||||
|
||||
(* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things")
|
||||
|
||||
`(CL:LAMBDA NIL ,(IF (CADDR BODY)
|
||||
THEN `(SETQ ,(CADR BODY) ,(CADDR BODY))))))))
|
||||
THEN `(SETQ ,(CADR BODY)
|
||||
,(CADDR BODY))))))))
|
||||
)
|
||||
|
||||
|
||||
@@ -162,9 +173,9 @@
|
||||
:LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE))
|
||||
|
||||
(SETTEMPLATE 'CL:COMPILER-LET '(! NIL (BOTH (|..| (IF LISTP (NIL EVAL |..| EFFECT)
|
||||
NIL))
|
||||
NIL))
|
||||
(|..| (IF LISTP ((BOTH BIND COMPILER-LET))
|
||||
(BOTH BIND COMPILER-LET))))
|
||||
(BOTH BIND COMPILER-LET))))
|
||||
|..| EFFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'CL:COUNT '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY))
|
||||
@@ -179,10 +190,10 @@
|
||||
|
||||
(SETTEMPLATE 'DECLARE '(|..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR))
|
||||
(LOCALVARS '(IF LISTP (|..| LOCALVARS)
|
||||
LOCALVARS))
|
||||
LOCALVARS))
|
||||
((SPECVARS CL:SPECIAL)
|
||||
'(IF LISTP (|..| SPECVARS)
|
||||
SPECVARS))
|
||||
SPECVARS))
|
||||
NIL)))))
|
||||
|
||||
(SETTEMPLATE 'CL:DELETE '(EVAL SMASH KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY))
|
||||
@@ -391,7 +402,7 @@
|
||||
(SETTEMPLATE 'CL:REPLACE '(SMASH EVAL KEYWORDS :START1 :END1 :START2 :END2))
|
||||
|
||||
(SETTEMPLATE 'CL:ROTATEF '(|..| (IF (ATOM EXPR)
|
||||
SET SMASH)))
|
||||
SET SMASH)))
|
||||
|
||||
(SETTEMPLATE 'CL:SEARCH '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1
|
||||
:END2))
|
||||
@@ -401,7 +412,7 @@
|
||||
(SETTEMPLATE 'CL:SET-EXCLUSIVE-OR '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
|
||||
|
||||
(SETTEMPLATE 'CL:SHIFTF '(|..| (IF (ATOM EXPR)
|
||||
SET SMASH)
|
||||
SET SMASH)
|
||||
EVAL))
|
||||
|
||||
(SETTEMPLATE 'CL:SORT '(EVAL FUNCTION KEYWORDS :KEY))
|
||||
@@ -459,10 +470,14 @@
|
||||
|
||||
(SETTEMPLATE 'CL:UNION '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
|
||||
|
||||
(SETTEMPLATE 'CL:UNLESS '(TEST |..| EFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'CL:VECTOR-PUSH '(EVAL SMASH))
|
||||
|
||||
(SETTEMPLATE 'CL:VECTOR-PUSH-EXTEND '(EVAL SMASH EVAL))
|
||||
|
||||
(SETTEMPLATE 'CL:WHEN '(TEST |..| EFECT RETURN))
|
||||
|
||||
(SETTEMPLATE 'WRITE '(EVAL KEYWORDS :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE
|
||||
:GENSYM :ARRAY))
|
||||
|
||||
@@ -539,6 +554,6 @@
|
||||
(CLRHASH USERTEMPLATES)
|
||||
(PUTPROPS MSCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (5000 6811 (FUNCTIONSMSGETDEF 5010 . 5804) (FUNCTIONSMSMC 5806 . 6286) (
|
||||
VARIABLESMSGETDEF 6288 . 6809)))))
|
||||
(FILEMAP (NIL (5280 7291 (FUNCTIONSMSGETDEF 5290 . 6258) (FUNCTIONSMSMC 6260 . 6731) (
|
||||
VARIABLESMSGETDEF 6733 . 7289)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
414
library/SPY
414
library/SPY
@@ -1,22 +1,22 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "29-Apr-94 14:13:52" {DSK}<king>export>lispcore>library>SPY.;4 64372
|
||||
|
||||
changes to%: (FILES GRAPHER)
|
||||
(FNS SPY.GRAPH.EDITOR SPY.UPDATE.TITLE SPY.MERGEINFO SPY.MAKEGRAPHNODES SPY.MAX
|
||||
SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.MAKE.TREE
|
||||
SPY.DELETE SPY.DUMP.BUFFER SPY.ORIGINAL SPY.MERGE.CALLEES)
|
||||
(FILECREATED " 4-Jan-2022 14:09:48" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>SPY.;2 63314
|
||||
|
||||
previous date%: "28-Apr-94 15:56:32" {DSK}<king>export>lispcore>library>SPY.;3)
|
||||
:CHANGES-TO (VARS SPYCOMS)
|
||||
(FNS SPY.MAKE.TREE)
|
||||
|
||||
:PREVIOUS-DATE "29-Apr-94 14:13:52" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>SPY.;1
|
||||
)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1984-1985, 1987-1988, 1990-1991, 1993-1994 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SPYCOMS)
|
||||
|
||||
(RPAQQ SPYCOMS
|
||||
((VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
|
||||
(RPAQQ SPYCOMS
|
||||
[(VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
|
||||
(SPY.GRAPH.MENU)
|
||||
SPY.SHOW.PERCENTAGES SPY.SMALLGHOSTS SPY.ICON)
|
||||
(INITVARS (SPY.NEXT 0)
|
||||
@@ -42,38 +42,41 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
(MACROS WITH-SPY WITH.SPY)
|
||||
(DECLARE%: DONTCOPY (RECORDS SPYRECORD SPYDATA))
|
||||
(INITRECORDS SPYRECORD)
|
||||
(DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))))
|
||||
(DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))
|
||||
(P (MOVD? 'NILL 'MODERNWINDOW])
|
||||
|
||||
(RPAQQ SPY.BORDERS ((NORMAL "Normal" 2 -1)
|
||||
(GHOST "Shown elsewhere" 2 8840)
|
||||
(RECURSIVEGHOST "End of recursive chain" 2 0 -1)
|
||||
(MERGED "Includes other branches" 4 42405)
|
||||
(SELFRECURSIVE "Includes self-recursive calls" 2 61375)
|
||||
(RECURSIVE "Head of recursive chain" 4 28086)
|
||||
(ENDOFLINE "exceeded depth limit" 6 64510)))
|
||||
(RPAQQ SPY.BORDERS
|
||||
((NORMAL "Normal" 2 -1)
|
||||
(GHOST "Shown elsewhere" 2 8840)
|
||||
(RECURSIVEGHOST "End of recursive chain" 2 0 -1)
|
||||
(MERGED "Includes other branches" 4 42405)
|
||||
(SELFRECURSIVE "Includes self-recursive calls" 2 61375)
|
||||
(RECURSIVE "Head of recursive chain" 4 28086)
|
||||
(ENDOFLINE "exceeded depth limit" 6 64510)))
|
||||
|
||||
(RPAQQ SPY.BUFFER.SIZE 5120)
|
||||
|
||||
(RPAQQ SPY.FRAGMENTS T)
|
||||
|
||||
(RPAQQ SPY.NOMERGEFNS (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER
|
||||
\INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
|
||||
(RPAQQ SPY.NOMERGEFNS (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER
|
||||
\INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
|
||||
|
||||
(RPAQQ SPY.MERGEINFO ((EXEC :EXEC)
|
||||
(EXEC-READ-LINE :EXEC)
|
||||
(EXEC-READ :EXEC)
|
||||
(XCL-USER::LEX-DO-EVENT :EXEC)
|
||||
(DO-EVENT :EXEC)
|
||||
(EVAL-INPUT :EXEC)
|
||||
(SI::*UNWIND-PROTECT* :ANY)
|
||||
(\MAKE.PROCESS0 T)
|
||||
(\PROC.REPEATEDLYEVALQT T)
|
||||
(\EVALFORM T :EVAL)
|
||||
(PROGN PROGN :EVAL T)
|
||||
(TTYIN1 TTYIN)
|
||||
(TTBIN TTYIN)
|
||||
(TTWAITFORINPUT TTYIN)
|
||||
(\PROGV :ANY)))
|
||||
(RPAQQ SPY.MERGEINFO
|
||||
((EXEC :EXEC)
|
||||
(EXEC-READ-LINE :EXEC)
|
||||
(EXEC-READ :EXEC)
|
||||
(XCL-USER::LEX-DO-EVENT :EXEC)
|
||||
(DO-EVENT :EXEC)
|
||||
(EVAL-INPUT :EXEC)
|
||||
(SI::*UNWIND-PROTECT* :ANY)
|
||||
(\MAKE.PROCESS0 T)
|
||||
(\PROC.REPEATEDLYEVALQT T)
|
||||
(\EVALFORM T :EVAL)
|
||||
(PROGN PROGN :EVAL T)
|
||||
(TTYIN1 TTYIN)
|
||||
(TTBIN TTYIN)
|
||||
(TTWAITFORINPUT TTYIN)
|
||||
(\PROGV :ANY)))
|
||||
|
||||
(RPAQQ SPY.HASH NIL)
|
||||
|
||||
@@ -102,19 +105,19 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
|
||||
(RPAQ? SPY.TREE )
|
||||
|
||||
(RPAQQ SPYOBJCOMS ((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX
|
||||
SPYOBJ.DISPLAY SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON
|
||||
SPY.MERGEINFO)
|
||||
[VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE]
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
|
||||
(INITRECORDS SPYOBJDATA)))
|
||||
(RPAQQ SPYOBJCOMS
|
||||
((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX SPYOBJ.DISPLAY
|
||||
SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON SPY.MERGEINFO)
|
||||
[VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE]
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
|
||||
(INITRECORDS SPYOBJDATA)))
|
||||
(DEFINEQ
|
||||
|
||||
(SPYOBJ
|
||||
@@ -176,148 +179,145 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
then '(:INTERPRETER CL:EVAL])
|
||||
)
|
||||
|
||||
(RPAQ SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE))
|
||||
(RPAQ SPYOBJ.IMAGEFNS
|
||||
(IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
|
||||
(FUNCTION SPYOBJ.IMAGEBOX)
|
||||
(FUNCTION SPYOBJ.SAVE)
|
||||
(FUNCTION SPYOBJ.GET)
|
||||
(FUNCTION SPYOBJ.COPY)
|
||||
(FUNCTION SPYOBJ.BUTTON)
|
||||
(FUNCTION SPYOBJ.COPYIN)
|
||||
NIL NIL NIL NIL NIL NIL 'SPYNODE))
|
||||
(DECLARE%: DONTCOPY DOEVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index")
|
||||
(BLOCKRECORD FXBLOCK ((FLAGS BITS 3) (* ; "= \STK.FX")
|
||||
(FAST FLAG)
|
||||
(NIL FLAG)
|
||||
(INCALL FLAG) (* ;
|
||||
"set when fncall microcode has to punt")
|
||||
(VALIDNAMETABLE FLAG)(* ;
|
||||
"if on, NAMETABLE field is filled in. If off, is same as FNHEADER")
|
||||
(NOPUSH FLAG) (* ;
|
||||
"when returning to this frame, don't push a value. Set by interrupt code")
|
||||
(USECNT BITS 8)
|
||||
(%#ALINK WORD) (* ; "low bit is SLOWP")
|
||||
(FNHEADER FULLXPOINTER)
|
||||
(NEXTBLOCK WORD)
|
||||
(PC WORD)
|
||||
(NAMETABLE# FULLXPOINTER)
|
||||
(%#BLINK WORD)
|
||||
(%#CLINK WORD)))
|
||||
(BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
|
||||
(NIL BYTE)
|
||||
(NIL BITS 15) (* ; "most of the bits of #ALINK")
|
||||
(SLOWP FLAG) (* ;
|
||||
"if on, then BLINK and CLINK fields are valid. If off, they are implicit")
|
||||
(NIL FULLXPOINTER 2)
|
||||
(NAMETABHI WORD)
|
||||
(NAMETABLO WORD)))
|
||||
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
|
||||
\STK.FX))
|
||||
[ACCESSFNS FX ((NAMETABLE (COND
|
||||
((fetch (FX VALIDNAMETABLE) of DATUM)
|
||||
(fetch (FX NAMETABLE#) of DATUM))
|
||||
(T (fetch (FX FNHEADER) of DATUM)))
|
||||
(PROGN (replace (FX FAST) of DATUM with NIL)
|
||||
(replace (FX NAMETABLE#) of DATUM with
|
||||
NEWVALUE)
|
||||
(replace (FX VALIDNAMETABLE) of DATUM
|
||||
with T)))
|
||||
(FRAMENAME (fetch (FNHEADER FRAMENAME)
|
||||
of (fetch (FX NAMETABLE) of DATUM)))
|
||||
(INVALIDP (EQ DATUM 0)) (* ;
|
||||
"true when A/CLink points at nobody, i.e. FX is bottom of stack")
|
||||
[FASTP (NOT (fetch (FX SLOWP) of DATUM))
|
||||
(PROGN (CHECK (NULL NEWVALUE))
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with
|
||||
T]
|
||||
[BLINK (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX DUMMYBF) of DATUM))
|
||||
(T (fetch (FX %#BLINK) of DATUM)))
|
||||
(PROGN (replace (FX %#BLINK) of DATUM with
|
||||
NEWVALUE)
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with
|
||||
T]
|
||||
[CLINK (IDIFFERENCE (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX %#ALINK) of DATUM))
|
||||
(T (fetch (FX %#CLINK) of DATUM)))
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN (replace (FX %#CLINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET))
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with
|
||||
T]
|
||||
[ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM)
|
||||
WORDSPERCELL)
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM]
|
||||
(replace (FX %#ALINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET
|
||||
(SUB1 WORDSPERCELL]
|
||||
[ACLINK (SHOULDNT)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM]
|
||||
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index")
|
||||
(BLOCKRECORD FXBLOCK ((FLAGS BITS 3) (* ; "= \STK.FX")
|
||||
(FAST FLAG)
|
||||
(NIL FLAG)
|
||||
(INCALL FLAG) (* ;
|
||||
"set when fncall microcode has to punt")
|
||||
(VALIDNAMETABLE FLAG) (* ;
|
||||
"if on, NAMETABLE field is filled in. If off, is same as FNHEADER")
|
||||
(NOPUSH FLAG) (* ;
|
||||
"when returning to this frame, don't push a value. Set by interrupt code")
|
||||
(USECNT BITS 8)
|
||||
(%#ALINK WORD) (* ; "low bit is SLOWP")
|
||||
(FNHEADER FULLXPOINTER)
|
||||
(NEXTBLOCK WORD)
|
||||
(PC WORD)
|
||||
(NAMETABLE# FULLXPOINTER)
|
||||
(%#BLINK WORD)
|
||||
(%#CLINK WORD)))
|
||||
(BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
|
||||
(NIL BYTE)
|
||||
(NIL BITS 15) (* ; "most of the bits of #ALINK")
|
||||
(SLOWP FLAG) (* ;
|
||||
"if on, then BLINK and CLINK fields are valid. If off, they are implicit")
|
||||
(NIL FULLXPOINTER 2)
|
||||
(NAMETABHI WORD)
|
||||
(NAMETABLO WORD)))
|
||||
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
|
||||
\STK.FX))
|
||||
[ACCESSFNS FX ((NAMETABLE (COND
|
||||
((fetch (FX VALIDNAMETABLE) of DATUM)
|
||||
(fetch (FX NAMETABLE#) of DATUM))
|
||||
(T (fetch (FX FNHEADER) of DATUM)))
|
||||
(PROGN (replace (FX FAST) of DATUM with NIL)
|
||||
(replace (FX NAMETABLE#) of DATUM with NEWVALUE)
|
||||
(replace (FX VALIDNAMETABLE) of DATUM with T)))
|
||||
(FRAMENAME (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE)
|
||||
of DATUM)))
|
||||
(INVALIDP (EQ DATUM 0)) (* ;
|
||||
"true when A/CLink points at nobody, i.e. FX is bottom of stack")
|
||||
[FASTP (NOT (fetch (FX SLOWP) of DATUM))
|
||||
(PROGN (CHECK (NULL NEWVALUE))
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET))
|
||||
(replace (FX %#ALINK) of DATUM
|
||||
with (IPLUS NEWVALUE \#ALINK.OFFSET
|
||||
(SUB1 WORDSPERCELL]
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with T]
|
||||
[BLINK (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX DUMMYBF) of DATUM))
|
||||
(T (fetch (FX %#BLINK) of DATUM)))
|
||||
(PROGN (replace (FX %#BLINK) of DATUM with NEWVALUE)
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with T]
|
||||
[CLINK (IDIFFERENCE (COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(fetch (FX %#ALINK) of DATUM))
|
||||
(T (fetch (FX %#CLINK) of DATUM)))
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN (replace (FX %#CLINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET)
|
||||
)
|
||||
(COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX SLOWP) of DATUM with T]
|
||||
[ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM)
|
||||
WORDSPERCELL)
|
||||
\#ALINK.OFFSET)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM))
|
||||
(replace (FX %#CLINK) of DATUM
|
||||
with (fetch (FX %#ALINK) of DATUM]
|
||||
(replace (FX %#ALINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET
|
||||
(SUB1
|
||||
WORDSPERCELL
|
||||
]
|
||||
[ACLINK (SHOULDNT)
|
||||
(PROGN [COND
|
||||
((fetch (FX FASTP) of DATUM)
|
||||
(replace (FX %#BLINK) of DATUM
|
||||
with (fetch (FX DUMMYBF) of DATUM]
|
||||
(replace (FX %#CLINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET)
|
||||
)
|
||||
(replace (FX %#ALINK) of DATUM with (IPLUS NEWVALUE
|
||||
\#ALINK.OFFSET
|
||||
(SUB1
|
||||
WORDSPERCELL
|
||||
]
|
||||
(* ;
|
||||
"replaces A & C Links at once more efficiently than separately")
|
||||
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
|
||||
"replaces A & C Links at once more efficiently than separately")
|
||||
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
|
||||
|
||||
(* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too.")
|
||||
(* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too.")
|
||||
|
||||
(IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF)
|
||||
of DATUM)))
|
||||
[CHECKED (AND (type? FX DATUM)
|
||||
(OR (IEQ (fetch (FX DUMMYBF) of DATUM)
|
||||
(fetch (FX BLINK) of DATUM))
|
||||
(AND (fetch (BF RESIDUAL)
|
||||
of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(IEQ (fetch (BF IVAR)
|
||||
of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(fetch (BF IVAR)
|
||||
of (fetch (FX BLINK)
|
||||
of DATUM]
|
||||
(FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T)))
|
||||
(IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF) of DATUM)))
|
||||
[CHECKED (AND (type? FX DATUM)
|
||||
(OR (IEQ (fetch (FX DUMMYBF) of DATUM)
|
||||
(fetch (FX BLINK) of DATUM))
|
||||
(AND (fetch (BF RESIDUAL) of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(IEQ (fetch (BF IVAR) of (fetch (FX DUMMYBF)
|
||||
of DATUM))
|
||||
(fetch (BF IVAR) of (fetch (FX BLINK)
|
||||
of DATUM]
|
||||
(FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T)))
|
||||
(* ; "stack offset of PVAR0")
|
||||
(FXSIZE (PROGN 10)) (* ;
|
||||
"fixed overhead from flags thru clink")
|
||||
(PADDING (PROGN 4)) (* ;
|
||||
"doublecell of garbage for microcode use")
|
||||
(FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM)
|
||||
(fetch (FX NPVARWORDS) of DATUM)
|
||||
(fetch (FX PADDING) of DATUM)))
|
||||
(FXSIZE (PROGN 10)) (* ;
|
||||
"fixed overhead from flags thru clink")
|
||||
(PADDING (PROGN 4)) (* ;
|
||||
"doublecell of garbage for microcode use")
|
||||
(FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM)
|
||||
(fetch (FX NPVARWORDS) of DATUM)
|
||||
(fetch (FX PADDING) of DATUM)))
|
||||
(* ;
|
||||
"note that NPVARWORDS is obtained from the FNHEADER")
|
||||
(SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM)
|
||||
DATUM])
|
||||
"note that NPVARWORDS is obtained from the FNHEADER")
|
||||
(SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM)
|
||||
DATUM])
|
||||
|
||||
(RECORD SPYOBJDATA (CACHEDLABEL PERCENT LABEL))
|
||||
)
|
||||
@@ -745,7 +745,9 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
", " TOPCOUNT " samples"])
|
||||
|
||||
(SPY.MAKE.TREE
|
||||
[LAMBDA (TREES SPYDATA WINDOW) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
|
||||
[LAMBDA (TREES SPYDATA WINDOW) (* ; "Edited 4-Jan-2022 14:08 by rmk")
|
||||
(* ;
|
||||
"Edited 28-Apr-94 13:59 by sybalsky")
|
||||
(PROG (GRAPH IDS W H THRSH TOPCOUNT (*PACKAGE* (fetch (SPYDATA PACKAGE) of SPYDATA))
|
||||
(*READTABLE* (fetch (SPYDATA READTABLE) of SPYDATA))
|
||||
(*PRINT-CASE* (fetch (SPYDATA PRINT-CASE) of SPYDATA)))
|
||||
@@ -755,8 +757,7 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
(SETQ THRSH (QUOTIENT (TIMES TOPCOUNT (fetch (SPYDATA THRESHOLD) of SPYDATA))
|
||||
100))
|
||||
(SETQ SPY.NODES)
|
||||
(SETQ SPY.TOPNODES (for X in TREES collect (SPY.MAKEGRAPHNODES X THRSH
|
||||
SPYDATA)))
|
||||
(SETQ SPY.TOPNODES (for X in TREES collect (SPY.MAKEGRAPHNODES X THRSH SPYDATA)))
|
||||
(SETQ TITLE (SPY.TITLE (CAR SPY.TOPNODES)
|
||||
TOPCOUNT SPYDATA))
|
||||
(SETQ SPY.WINDOW (SHOWGRAPH (LAYOUTGRAPH (REVERSE SPY.NODES)
|
||||
@@ -773,7 +774,8 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
(WINDOWPROP SPY.WINDOW 'SPYDATA SPYDATA)
|
||||
(WINDOWPROP SPY.WINDOW 'TREES TREES)
|
||||
(WINDOWPROP SPY.WINDOW 'SPYTITLE TITLE)
|
||||
(WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT])
|
||||
(WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT)
|
||||
(MODERNWINDOW SPY.WINDOW])
|
||||
|
||||
(SPY.UPDATE.TITLE
|
||||
[LAMBDA (W) (* ; "Edited 29-Apr-94 14:03 by sybalsky")
|
||||
@@ -965,23 +967,23 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS WITH-SPY MACRO ((FORM)
|
||||
(PUTPROPS WITH-SPY MACRO [(FORM)
|
||||
(PROGN (SPY.START)
|
||||
(PROG1 FORM (SPY.END]
|
||||
(PROG1 FORM (SPY.END])
|
||||
|
||||
[PUTPROPS WITH.SPY MACRO ((FORM)
|
||||
(PUTPROPS WITH.SPY MACRO [(FORM)
|
||||
(PROGN (SPY.START)
|
||||
(PROG1 FORM (SPY.END]
|
||||
(PROG1 FORM (SPY.END])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE SPYRECORD (NAME COUNT SUM CALLEES STATUS TREEFROM)
|
||||
STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT)))
|
||||
STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT)))
|
||||
|
||||
(PROPRECORD SPYDATA (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE
|
||||
READTABLE PRINT-CASE MERGEINFO PENDING)
|
||||
CUMULATIVE _ T)
|
||||
(PROPRECORD SPYDATA (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE READTABLE
|
||||
PRINT-CASE MERGEINFO PENDING)
|
||||
CUMULATIVE _ T)
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'SPYRECORD '(POINTER POINTER POINTER POINTER POINTER POINTER)
|
||||
@@ -1010,19 +1012,21 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
|
||||
|
||||
(FILESLOAD GRAPHER READNUMBER IMAGEOBJ)
|
||||
)
|
||||
|
||||
(MOVD? 'NILL 'MODERNWINDOW)
|
||||
(PUTPROPS SPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1987 1988 1990 1991 1993 1994))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5474 8081 (SPYOBJ 5484 . 5773) (SPYOBJ.BUTTON 5775 . 5885) (SPYOBJ.SAVE 5887 . 6006) (
|
||||
SPYOBJ.COPY 6008 . 6070) (SPYOBJ.GET 6072 . 6201) (SPYOBJ.IMAGEBOX 6203 . 6727) (SPYOBJ.DISPLAY 6729
|
||||
. 7028) (SPYOBJ.LABEL 7030 . 7166) (SPYOBJ.HEIGHT 7168 . 7381) (SPYOBJ.COPYIN 7383 . 7426) (
|
||||
SPY.COPYBUTTON 7428 . 7520) (SPY.MERGEINFO 7522 . 8079)) (19431 60601 (SPY.FIND.TREE 19441 . 19850) (
|
||||
SPY.TOGGLE 19852 . 20042) (SPY.TREE 20044 . 21156) (SPY.LEGEND 21158 . 21508) (SPY.GRAPH.EDITOR 21510
|
||||
. 31075) (SPY.END 31077 . 31319) (SPY.MAKEGRAPHNODES 31321 . 33421) (SPY.MAX 33423 . 34306) (
|
||||
SPY.MERGE 34308 . 35739) (SPY.MERGE1 35741 . 42224) (SPY.MERGETREE 42226 . 45156) (SPY.NEXT.TREE 45158
|
||||
. 45832) (SPY.SUM 45834 . 46523) (SPY.TITLE 46525 . 46742) (SPY.MAKE.TREE 46744 . 48632) (
|
||||
SPY.UPDATE.TITLE 48634 . 51210) (SPY.DELETE 51212 . 51747) (SPY.DRAWBOX 51749 . 52274) (
|
||||
SPY.BUFFER.ENTRY 52276 . 52514) (SPY.BUTTON 52516 . 53085) (SPY.END.ENTRY 53087 . 53167) (SPY.START
|
||||
53169 . 53453) (SPY.INIT 53455 . 53690) (\SPY.INTERRUPT 53692 . 54328) (SPY.DUMP.BUFFER 54330 . 55790)
|
||||
(SPY.START.ENTRY 55792 . 55920) (SPY.ADD.ENTRY 55922 . 56304) (SPY.ORIGINAL 56306 . 57133) (
|
||||
SPY.OVERFLOW 57135 . 57236) (SPY.MERGE.CALLEES 57238 . 60274) (SPY.PRINT 60276 . 60599)))))
|
||||
(FILEMAP (NIL (4753 7360 (SPYOBJ 4763 . 5052) (SPYOBJ.BUTTON 5054 . 5164) (SPYOBJ.SAVE 5166 . 5285) (
|
||||
SPYOBJ.COPY 5287 . 5349) (SPYOBJ.GET 5351 . 5480) (SPYOBJ.IMAGEBOX 5482 . 6006) (SPYOBJ.DISPLAY 6008
|
||||
. 6307) (SPYOBJ.LABEL 6309 . 6445) (SPYOBJ.HEIGHT 6447 . 6660) (SPYOBJ.COPYIN 6662 . 6705) (
|
||||
SPY.COPYBUTTON 6707 . 6799) (SPY.MERGEINFO 6801 . 7358)) (18202 59509 (SPY.FIND.TREE 18212 . 18621) (
|
||||
SPY.TOGGLE 18623 . 18813) (SPY.TREE 18815 . 19927) (SPY.LEGEND 19929 . 20279) (SPY.GRAPH.EDITOR 20281
|
||||
. 29846) (SPY.END 29848 . 30090) (SPY.MAKEGRAPHNODES 30092 . 32192) (SPY.MAX 32194 . 33077) (
|
||||
SPY.MERGE 33079 . 34510) (SPY.MERGE1 34512 . 40995) (SPY.MERGETREE 40997 . 43927) (SPY.NEXT.TREE 43929
|
||||
. 44603) (SPY.SUM 44605 . 45294) (SPY.TITLE 45296 . 45513) (SPY.MAKE.TREE 45515 . 47540) (
|
||||
SPY.UPDATE.TITLE 47542 . 50118) (SPY.DELETE 50120 . 50655) (SPY.DRAWBOX 50657 . 51182) (
|
||||
SPY.BUFFER.ENTRY 51184 . 51422) (SPY.BUTTON 51424 . 51993) (SPY.END.ENTRY 51995 . 52075) (SPY.START
|
||||
52077 . 52361) (SPY.INIT 52363 . 52598) (\SPY.INTERRUPT 52600 . 53236) (SPY.DUMP.BUFFER 53238 . 54698)
|
||||
(SPY.START.ENTRY 54700 . 54828) (SPY.ADD.ENTRY 54830 . 55212) (SPY.ORIGINAL 55214 . 56041) (
|
||||
SPY.OVERFLOW 56043 . 56144) (SPY.MERGE.CALLEES 56146 . 59182) (SPY.PRINT 59184 . 59507)))))
|
||||
STOP
|
||||
|
||||
BIN
library/SPY.LCOM
BIN
library/SPY.LCOM
Binary file not shown.
149
library/TEDIT
149
library/TEDIT
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "13-Oct-2021 10:00:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;19 142287
|
||||
(FILECREATED "30-Dec-2021 20:50:54" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;30 142870
|
||||
|
||||
changes to%: (FNS TEDIT-SEE)
|
||||
:CHANGES-TO (FNS TEDIT TEDIT-SEE)
|
||||
|
||||
previous date%: "11-Oct-2021 14:03:12"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;18)
|
||||
:PREVIOUS-DATE "28-Dec-2021 11:02:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;24)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -27,9 +26,9 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP))
|
||||
(TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU))
|
||||
(* ;
|
||||
"Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")
|
||||
"Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")
|
||||
(* ;
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
)
|
||||
(GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
|
||||
(FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT-SEE TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE
|
||||
@@ -40,10 +39,10 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
\TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1)
|
||||
(P (MOVD? 'NILL 'OBJECTOUTOFTEDIT))
|
||||
(* ;
|
||||
"HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
|
||||
"HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
|
||||
(COMS (FNS \CREATE.TEDIT.RESTART.MENU))
|
||||
(* ;
|
||||
"Added by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Added by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
(COMS (* ; "Debugging functions")
|
||||
(FNS PLCHAIN PRINTLINE SEEFILE))
|
||||
(COMS (* ; "Object-oriented editing")
|
||||
@@ -56,10 +55,10 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(VARS TEDITSYSTEMDATE (TEDITSUPPORT "TEditSupport.PA"))
|
||||
(FNS MAKETEDITFORM)
|
||||
(P (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM
|
||||
"Report a problem with TEdit"))
|
||||
"Report a problem with TEdit"))
|
||||
(SETQ LAFITEFORMSMENU NIL)))
|
||||
(COMS (* ;
|
||||
"LISTFILES Interface, so the system can decide if a file is a TEdit file.")
|
||||
"LISTFILES Interface, so the system can decide if a file is a TEdit file.")
|
||||
(ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
|
||||
(EXTENSION (TEDIT])
|
||||
|
||||
@@ -251,21 +250,29 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
NIL])
|
||||
|
||||
(TEDIT
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 11-Jun-99 14:14 by rmk:")
|
||||
(* ; "Edited 11-Jun-99 14:13 by rmk:")
|
||||
(* ; "Edited 11-Jun-99 14:08 by rmk:")
|
||||
(* ; "Edited 3-Jun-88 14:27 by jds")
|
||||
[LAMBDA (TEXT WINDOW DONTSPAWN PROPS) (* ; "Edited 30-Dec-2021 20:50 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 00:12 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
(* ; "Edited 11-Jun-99 14:14 by rmk:")
|
||||
(* ; "Edited 3-Jun-88 14:27 by jds")
|
||||
|
||||
(* ;; "User entry to the text editor. Takes an optional window to be used for editing")
|
||||
(* ;; "User entry to the text editor. Takes an optional window to be used for editing")
|
||||
|
||||
(* ;; "DONTSPAWN => Don't try to create a new process for this edit.")
|
||||
(* ;; "DONTSPAWN => Don't try to create a new process for this edit.")
|
||||
|
||||
(PROG (PROC TEDITCREATEDWINDOW) (* ;
|
||||
"Include the default properties in the list.")
|
||||
(PROG (PROC TEDITCREATEDWINDOW) (* ;
|
||||
"Include the default properties in the list.")
|
||||
[COND
|
||||
((AND TEXT (ATOM TEXT)) (* ;
|
||||
"Make sure the file exists before trying to open the window.")
|
||||
((AND TEXT (ATOM TEXT)) (* ;
|
||||
"Make sure the file exists before trying to open the window.")
|
||||
(SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD '((TYPE TEXT]
|
||||
(CL:WHEN (AND WINDOW (OR (LITATOM WINDOW)
|
||||
(REGIONP WINDOW)))
|
||||
|
||||
(* ;; "Pass specified and typed regions to TEDIT.CREATEW")
|
||||
|
||||
(PUSH PROPS 'REGION-TYPE WINDOW)
|
||||
(SETQ WINDOW NIL))
|
||||
(RESETLST
|
||||
[RESETSAVE NIL `(AND ,WINDOW (WINDOWPROP ,WINDOW 'TEXTOBJ NIL]
|
||||
(WITH.MONITOR TEDIT.STARTUP.MONITORLOCK
|
||||
@@ -273,7 +280,8 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
((NOT WINDOW)
|
||||
(SETQ TEDITCREATEDWINDOW T)
|
||||
(SETQ WINDOW (COND
|
||||
[(OR (NOT TEDIT.DEFAULT.WINDOW)
|
||||
[(OR (LISTGET PROPS 'REGION-TYPE)
|
||||
(NOT TEDIT.DEFAULT.WINDOW)
|
||||
(\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW))
|
||||
(TEDIT.CREATEW (COND
|
||||
((AND TEXT (ATOM TEXT))
|
||||
@@ -289,28 +297,27 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
'REGION)
|
||||
TEXT
|
||||
(APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)))
|
||||
(* ; "Replace the old title")
|
||||
(* ; "Replace the old title")
|
||||
TEDIT.DEFAULT.WINDOW)))
|
||||
|
||||
(* ;;
|
||||
"Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")
|
||||
(* ;;
|
||||
"Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")
|
||||
|
||||
(* ;;
|
||||
"mark that we created the window so that we know we can update the title, etc.")
|
||||
(* ;;
|
||||
"mark that we created the window so that we know we can update the title, etc.")
|
||||
|
||||
(WINDOWPROP WINDOW 'TEXTOBJ T)))))
|
||||
[SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL (APPEND PROPS '(BEING-EDITED T]
|
||||
(* ;
|
||||
"Connect the editor to the window")
|
||||
(* ; "Connect the editor to the window")
|
||||
(replace (TEXTOBJ TXTEDITING) of (TEXTOBJ TEXT) with T)
|
||||
(* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")
|
||||
(* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")
|
||||
[COND
|
||||
(TEDITCREATEDWINDOW (TEXTPROP TEXT 'TEDITCREATEDWINDOW 'T]
|
||||
(COND
|
||||
(DONTSPAWN (* ;
|
||||
"Either no processes running, or specifically not to spawn one.")
|
||||
(DONTSPAWN (* ;
|
||||
"Either no processes running, or specifically not to spawn one.")
|
||||
(RETURN (\TEDIT2 TEXT WINDOW T)))
|
||||
(T (* ; "Spawn a process to do the edit.")
|
||||
(T (* ; "Spawn a process to do the edit.")
|
||||
[SETQ PROC (ADD.PROCESS (LIST '\TEDIT2 (KWOTE TEXT)
|
||||
WINDOW NIL)
|
||||
'NAME
|
||||
@@ -324,14 +331,16 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PROCESSPROP PROC 'WINDOW WINDOW)
|
||||
(COND
|
||||
((NOT (LISTGET (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS))
|
||||
'LEAVETTY)) (* ;
|
||||
"Unless he asked us to leave the tty where it is, TEdit should get it.")
|
||||
'LEAVETTY)) (* ;
|
||||
"Unless he asked us to leave the tty where it is, TEdit should get it.")
|
||||
(TTY.PROCESS PROC)))
|
||||
(RETURN PROC])
|
||||
|
||||
(TEDIT-SEE
|
||||
[LAMBDA (FILE WINDOW FORMAT) (* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
[LAMBDA (FILE WINDOW FORMAT TITLE) (* ; "Edited 30-Dec-2021 18:03 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:33 by rmk")
|
||||
(* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
(* ; "Edited 1-Feb-88 19:00 by bvm:")
|
||||
|
||||
(* ;; "See FILE in a scrollable READONLY TEDIT window. If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.")
|
||||
@@ -347,29 +356,27 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(IF (\TEDIT.FORMATTEDP1 STREAM)
|
||||
ELSEIF (LISPSOURCEFILEP STREAM)
|
||||
THEN
|
||||
(* ;; "Lisp source file")
|
||||
|
||||
(* ;; "Lisp source file")
|
||||
|
||||
(SETQ SEESTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT SEESTREAM)
|
||||
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
|
||||
(SETQ SEESTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT SEESTREAM)
|
||||
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
|
||||
ELSE
|
||||
(* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.")
|
||||
|
||||
(* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.")
|
||||
(* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")
|
||||
|
||||
(* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")
|
||||
|
||||
(SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
|
||||
:DEFAULT))
|
||||
(CL:UNLESS (RANDACCESSP STREAM)
|
||||
(SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
|
||||
(COPYCHARS STREAM SEESTREAM)))
|
||||
(SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
|
||||
:DEFAULT))
|
||||
(CL:UNLESS (RANDACCESSP STREAM)
|
||||
(SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
|
||||
(COPYCHARS STREAM SEESTREAM)))
|
||||
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL
|
||||
`(READONLY T FONT ,DEFAULTFONT]
|
||||
(WINDOWPROP (WFROMDS TSTREAM)
|
||||
`(READONLY T LEAVETTY T FONT ,DEFAULTFONT]
|
||||
[WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TITLE
|
||||
(CONCAT "SEE window for " (FULLNAME STREAM)))
|
||||
(FULLNAME STREAM])
|
||||
(OR TITLE (CONCAT "SEE window for " (FULLNAME STREAM]
|
||||
TSTREAM])
|
||||
|
||||
(TEDIT.CHARWIDTH
|
||||
[LAMBDA (CH FONT TERMSA) (* jds "22-OCT-83 19:32")
|
||||
@@ -2236,7 +2243,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* ; "TEDIT Support information")
|
||||
|
||||
|
||||
(RPAQQ TEDITSYSTEMDATE "13-Oct-2021 10:00:40")
|
||||
(RPAQQ TEDITSYSTEMDATE "30-Dec-2021 20:50:54")
|
||||
|
||||
(RPAQ TEDITSUPPORT "TEditSupport.PA")
|
||||
(DEFINEQ
|
||||
@@ -2258,23 +2265,23 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
|
||||
(EXTENSION (TEDIT))))
|
||||
(EXTENSION (TEDIT))))
|
||||
(PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1992 1993 1995 1999 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4330 117453 (\TEDIT2 4340 . 7091) (COERCETEXTOBJ 7093 . 15869) (TEDIT 15871 . 20840) (
|
||||
TEDIT-SEE 20842 . 23129) (TEDIT.CHARWIDTH 23131 . 25155) (TEDIT.COPY 25157 . 33593) (TEDIT.DELETE
|
||||
33595 . 34285) (TEDIT.DO.BLUEPENDINGDELETE 34287 . 37354) (TEDIT.INSERT 37356 . 42886) (TEDIT.KILL
|
||||
42888 . 44445) (TEDIT.MAPLINES 44447 . 45846) (TEDIT.MAPPIECES 45848 . 46804) (TEDIT.MOVE 46806 .
|
||||
56590) (TEDIT.QUIT 56592 . 58592) (TEDIT.STRINGWIDTH 58594 . 59265) (TEDIT.\INSERT 59267 . 61292) (
|
||||
TEXTOBJ 61294 . 62419) (TEXTSTREAM 62421 . 64036) (\TEDIT.INCLUDE 64038 . 67938) (\TEDIT.INSERT.PIECES
|
||||
67940 . 77855) (\TEDIT.MOVE.PIECEMAPFN 77857 . 79936) (\TEDIT.OBJECT.SHOWSEL 79938 . 83567) (
|
||||
\TEDIT.RESTARTFN 83569 . 85564) (\TEDIT.CHARDELETE 85566 . 89528) (\TEDIT.COPY.PIECEMAPFN 89530 .
|
||||
92755) (\TEDIT.DELETE 92757 . 100275) (\TEDIT.DIFFUSE.PARALOOKS 100277 . 103041) (\TEDIT.FOREIGN.COPY?
|
||||
103043 . 106770) (\TEDIT.QUIT 106772 . 109918) (\TEDIT.WORDDELETE 109920 . 114753) (\TEDIT1 114755 .
|
||||
117451)) (117567 117683 (\CREATE.TEDIT.RESTART.MENU 117577 . 117681)) (117782 121471 (PLCHAIN 117792
|
||||
. 118066) (PRINTLINE 118068 . 120832) (SEEFILE 120834 . 121469)) (121512 141155 (TEDIT.INSERT.OBJECT
|
||||
121522 . 130599) (TEDIT.EDIT.OBJECT 130601 . 132857) (TEDIT.FIND.OBJECT 132859 . 133752) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 133754 . 134560) (TEDIT.PUT.OBJECT 134562 . 136221) (TEDIT.GET.OBJECT 136223
|
||||
. 139422) (TEDIT.OBJECT.CHANGED 139424 . 141153)) (141433 141796 (MAKETEDITFORM 141443 . 141794)))))
|
||||
(FILEMAP (NIL (4336 118040 (\TEDIT2 4346 . 7097) (COERCETEXTOBJ 7099 . 15875) (TEDIT 15877 . 21230) (
|
||||
TEDIT-SEE 21232 . 23716) (TEDIT.CHARWIDTH 23718 . 25742) (TEDIT.COPY 25744 . 34180) (TEDIT.DELETE
|
||||
34182 . 34872) (TEDIT.DO.BLUEPENDINGDELETE 34874 . 37941) (TEDIT.INSERT 37943 . 43473) (TEDIT.KILL
|
||||
43475 . 45032) (TEDIT.MAPLINES 45034 . 46433) (TEDIT.MAPPIECES 46435 . 47391) (TEDIT.MOVE 47393 .
|
||||
57177) (TEDIT.QUIT 57179 . 59179) (TEDIT.STRINGWIDTH 59181 . 59852) (TEDIT.\INSERT 59854 . 61879) (
|
||||
TEXTOBJ 61881 . 63006) (TEXTSTREAM 63008 . 64623) (\TEDIT.INCLUDE 64625 . 68525) (\TEDIT.INSERT.PIECES
|
||||
68527 . 78442) (\TEDIT.MOVE.PIECEMAPFN 78444 . 80523) (\TEDIT.OBJECT.SHOWSEL 80525 . 84154) (
|
||||
\TEDIT.RESTARTFN 84156 . 86151) (\TEDIT.CHARDELETE 86153 . 90115) (\TEDIT.COPY.PIECEMAPFN 90117 .
|
||||
93342) (\TEDIT.DELETE 93344 . 100862) (\TEDIT.DIFFUSE.PARALOOKS 100864 . 103628) (\TEDIT.FOREIGN.COPY?
|
||||
103630 . 107357) (\TEDIT.QUIT 107359 . 110505) (\TEDIT.WORDDELETE 110507 . 115340) (\TEDIT1 115342 .
|
||||
118038)) (118154 118270 (\CREATE.TEDIT.RESTART.MENU 118164 . 118268)) (118369 122058 (PLCHAIN 118379
|
||||
. 118653) (PRINTLINE 118655 . 121419) (SEEFILE 121421 . 122056)) (122099 141742 (TEDIT.INSERT.OBJECT
|
||||
122109 . 131186) (TEDIT.EDIT.OBJECT 131188 . 133444) (TEDIT.FIND.OBJECT 133446 . 134339) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 134341 . 135147) (TEDIT.PUT.OBJECT 135149 . 136808) (TEDIT.GET.OBJECT 136810
|
||||
. 140009) (TEDIT.OBJECT.CHANGED 140011 . 141740)) (142020 142383 (MAKETEDITFORM 142030 . 142381)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Sep-2021 15:33:24"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;10 106458
|
||||
|
||||
changes to%: (FNS TEDIT.HARDCOPYFN)
|
||||
(VARS TEDITHCPYCOMS)
|
||||
(FILECREATED "26-Jan-2022 23:03:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITHCPY.;15 106802
|
||||
|
||||
previous date%: "21-Sep-2021 12:54:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;7)
|
||||
:CHANGES-TO (VARS TEDITHCPYCOMS)
|
||||
|
||||
:PREVIOUS-DATE "27-Sep-2021 23:28:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITHCPY.;14)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -35,18 +34,18 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(VARS (TEDIT.DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 23495)))
|
||||
(* ;
|
||||
"0.75 inches from bottom, 1 from top")
|
||||
)
|
||||
"0.75 inches from bottom, 1 from top"))
|
||||
[COMS
|
||||
(* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.")
|
||||
|
||||
(FNS TEDIT.HARDCOPYFN \TEDIT.HARDCOPY \TEDIT.PRESS.HARDCOPY)
|
||||
(P (LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
|
||||
'TEDIT
|
||||
(FUNCTION \TEDIT.HARDCOPY)))
|
||||
[P (LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
|
||||
(COND (IPVALUES (* ;
|
||||
"Only install INTERPRESS printing if INTERPRESS is loaded.")
|
||||
(LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
|
||||
(P (LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
|
||||
(COND (PRESSVALUES (* ;
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
(LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
[COMS
|
||||
(* ;; "vars for Japanese Line Break")
|
||||
@@ -1568,14 +1567,16 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
PFILE)])
|
||||
)
|
||||
|
||||
(LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
|
||||
'TEDIT
|
||||
(FUNCTION \TEDIT.HARDCOPY))
|
||||
[LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
|
||||
(COND
|
||||
(IPVALUES (* ;
|
||||
"Only install INTERPRESS printing if INTERPRESS is loaded.")
|
||||
(LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
|
||||
|
||||
[LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
|
||||
(COND
|
||||
(PRESSVALUES (* ;
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
"Only install PRESS printing if PRESS is loaded.")
|
||||
(LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
|
||||
|
||||
|
||||
@@ -1616,11 +1617,11 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS TEDITHCPY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||
1991 1992 1993 1994 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3655 100373 (TEDIT.HARDCOPY 3665 . 4916) (TEDIT.HCPYFILE 4918 . 6992) (
|
||||
\TEDIT.HARDCOPY.DISPLAYLINE 6994 . 21139) (\TEDIT.HARDCOPY.FORMATLINE 21141 . 68463) (
|
||||
\DOFORMATTING.HARDCOPY 68465 . 81758) (\TEDIT.HARDCOPY.MODIFYLOOKS 81760 . 84167) (
|
||||
\TEDIT.HCPYLOOKS.UPDATE 84169 . 94777) (\TEDIT.HCPYFMTSPEC 94779 . 99799) (\TEDIT.INTEGER.IMAGEBOX
|
||||
99801 . 100371)) (100462 101546 (\TEDIT.SCALE 100472 . 100766) (\TEDIT.SCALEREGION 100768 . 101544)) (
|
||||
101789 104340 (TEDIT.HARDCOPYFN 101799 . 102704) (\TEDIT.HARDCOPY 102706 . 103615) (
|
||||
\TEDIT.PRESS.HARDCOPY 103617 . 104338)) (105405 106308 (TEDIT-BOOK 105415 . 106306)))))
|
||||
(FILEMAP (NIL (3784 100502 (TEDIT.HARDCOPY 3794 . 5045) (TEDIT.HCPYFILE 5047 . 7121) (
|
||||
\TEDIT.HARDCOPY.DISPLAYLINE 7123 . 21268) (\TEDIT.HARDCOPY.FORMATLINE 21270 . 68592) (
|
||||
\DOFORMATTING.HARDCOPY 68594 . 81887) (\TEDIT.HARDCOPY.MODIFYLOOKS 81889 . 84296) (
|
||||
\TEDIT.HCPYLOOKS.UPDATE 84298 . 94906) (\TEDIT.HCPYFMTSPEC 94908 . 99928) (\TEDIT.INTEGER.IMAGEBOX
|
||||
99930 . 100500)) (100591 101675 (\TEDIT.SCALE 100601 . 100895) (\TEDIT.SCALEREGION 100897 . 101673)) (
|
||||
101918 104469 (TEDIT.HARDCOPYFN 101928 . 102833) (\TEDIT.HARDCOPY 102835 . 103744) (
|
||||
\TEDIT.PRESS.HARDCOPY 103746 . 104467)) (105749 106652 (TEDIT-BOOK 105759 . 106650)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "29-Apr-2021 22:44:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;5 275764
|
||||
|
||||
changes to%: (FNS \TEDIT.MENU.INIT)
|
||||
(FILECREATED "26-Oct-2021 08:44:02"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;3 276285
|
||||
|
||||
previous date%: "29-Apr-2021 22:40:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;4)
|
||||
changes to%: (FNS \TEXTMENU.START)
|
||||
|
||||
previous date%: "29-Apr-2021 22:44:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -19,7 +20,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
|
||||
(FILES (LOADCOMP)
|
||||
TEDITDCL))
|
||||
[COMS (* ; "Simple Menu Button support")
|
||||
[COMS (* ; "Simple Menu Button support")
|
||||
(FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN
|
||||
MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MBUTTON.CREATE MBUTTON.CHANGENAME
|
||||
MBUTTON.FIND.BUTTON MBUTTON.FIND.NEXT.BUTTON MBUTTON.FIND.NEXT.FIELD MBUTTON.INIT
|
||||
@@ -31,13 +32,13 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN]
|
||||
[COMS
|
||||
(* ;;
|
||||
"Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")
|
||||
(* ;;
|
||||
"Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")
|
||||
|
||||
(FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN
|
||||
MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (THREESTATE.INIT]
|
||||
[COMS (* ; "One-of-N Menu button sets")
|
||||
[COMS (* ; "One-of-N Menu button sets")
|
||||
(FNS MB.CREATE.NWAYBUTTON MB.NB.DISPLAYFN MB.NB.WHENOPERATEDFN MB.NB.SIZEFN
|
||||
MB.NWAYBUTTON.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS
|
||||
MB.NWAYBUTTON.ADDITEM)
|
||||
@@ -45,7 +46,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN]
|
||||
[COMS
|
||||
(* ;; "Two-state, toggling menu buttons.")
|
||||
(* ;; "Two-state, toggling menu buttons.")
|
||||
|
||||
(FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN
|
||||
\TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT
|
||||
@@ -54,7 +55,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN]
|
||||
[COMS
|
||||
(* ;; "Margin Setting and display")
|
||||
(* ;; "Margin Setting and display")
|
||||
|
||||
(FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN
|
||||
MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK
|
||||
@@ -66,11 +67,11 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN]
|
||||
(COMS
|
||||
(* ;; "Text menu creation and support")
|
||||
(* ;; "Text menu creation and support")
|
||||
|
||||
(FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN)
|
||||
(BITMAPS TEXTMENUICON TEXTMENUICONMASK))
|
||||
[COMS (* ; "TEdit-specific support")
|
||||
[COMS (* ; "TEdit-specific support")
|
||||
(FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN
|
||||
\TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN)
|
||||
(FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS
|
||||
@@ -82,7 +83,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
\TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS)
|
||||
(FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING
|
||||
TEDIT.UNPARSE.PAGEFORMAT)
|
||||
(COMS (* ; "Initialization Code")
|
||||
(COMS (* ; "Initialization Code")
|
||||
(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU
|
||||
TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC
|
||||
TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU)
|
||||
@@ -2067,11 +2068,14 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(\TEXTMENU.START
|
||||
[LAMBDA (MENU MAINWINDOW TITLE HEIGHT) (* ;
|
||||
[LAMBDA (MENU MAINWINDOW TITLE HEIGHT) (* ; "Edited 26-Oct-2021 08:43 by rmk:")
|
||||
(* ;
|
||||
"Edited 4-Jun-93 11:59 by sybalsky:mv:envos")
|
||||
|
||||
(* ;; "Create a TEdit-based menu for a given main window.")
|
||||
|
||||
(* ;; "RMK: Add MAX/MINSIZE so menus don't grow vertically when the main window is reshaped. Not sure why HEIGHT is passed in or defaults to 133, but either way, the original window height should persist")
|
||||
|
||||
(PROG ([WREG (COND
|
||||
(MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION))
|
||||
(T (GETREGION]
|
||||
@@ -2104,6 +2108,9 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(* ;
|
||||
"Mark this as a TEDIT MENU window")
|
||||
(ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE)
|
||||
[SETQ HEIGHT (FETCH (REGION HEIGHT) OF (WINDOWPROP MENUW 'REGION]
|
||||
(WINDOWPROP MENUW 'MAXSIZE (CONS 64000 HEIGHT))
|
||||
(WINDOWPROP MENUW 'MINSIZE (CONS 0 HEIGHT))
|
||||
(SETQ MENUTEXT MENU)
|
||||
(replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
|
||||
with T)
|
||||
@@ -4524,20 +4531,20 @@ MB.CREATE.NWAYBUTTON 43946 . 47914) (MB.NB.DISPLAYFN 47916 . 50188) (MB.NB.WHENO
|
||||
85254 . 88164) (MB.MARGINBAR.SELFN 88166 . 100760) (MB.MARGINBAR.SIZEFN 100762 . 101124) (
|
||||
MB.MARGINBAR.DISPLAYFN 101126 . 103811) (MDESCALE 103813 . 104252) (MSCALE 104254 . 104588) (
|
||||
MB.MARGINBAR.SHOWTAB 104590 . 106761) (MB.MARGINBAR.TABTRACK 106763 . 108098) (\TEDIT.TABTYPE.SET
|
||||
108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130317 (\TEXTMENU.START 112725 . 115917) (
|
||||
\TEXTMENU.DOC.CREATE 115919 . 127443) (TEXTMENU.CLOSEFN 127445 . 130315)) (130627 150691 (
|
||||
\TEDITMENU.CREATE 130637 . 130937) (\TEDIT.EXPANDED.MENU 130939 . 131643) (MB.DEFAULTBUTTON.FN 131645
|
||||
. 134517) (\TEDITMENU.RECORD.UNFORMATTED 134519 . 134857) (MB.DEFAULTBUTTON.ACTIONFN 134859 . 150689)
|
||||
) (150692 178075 (\TEDIT.CHARLOOKSMENU.CREATE 150702 . 152842) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152844
|
||||
. 153218) (\TEDIT.APPLY.BOLDNESS 153220 . 153505) (\TEDIT.APPLY.CHARLOOKS 153507 . 155438) (
|
||||
\TEDIT.APPLY.OLINE 155440 . 155721) (\TEDIT.SHOW.CHARLOOKS 155723 . 157636) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS 157638 . 158564) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158566 . 166219) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166221 . 169104) (\TEDIT.PARSE.CHARLOOKS.MENU 169106 . 177214) (
|
||||
\TEDIT.APPLY.SLOPE 177216 . 177499) (\TEDIT.APPLY.STRIKEOUT 177501 . 177788) (\TEDIT.APPLY.ULINE
|
||||
177790 . 178073)) (178076 210142 (\TEDITPARAMENU.CREATE 178086 . 178466) (\TEDIT.EXPANDEDPARA.MENU
|
||||
178468 . 178788) (\TEDIT.APPLY.PARALOOKS 178790 . 191020) (\TEDIT.SHOW.PARALOOKS 191022 . 202549) (
|
||||
\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202551 . 208622) (\TEDIT.RECORD.TABLEADERS 208624 . 210140)) (210143
|
||||
248145 (\TEDIT.SHOW.PAGEFORMATTING 210153 . 226693) (\TEDITPAGEMENU.CREATE 226695 . 227738) (
|
||||
\TEDIT.APPLY.PAGEFORMATTING 227740 . 240111) (TEDIT.UNPARSE.PAGEFORMAT 240113 . 248143)) (248450
|
||||
275299 (\TEDIT.MENU.INIT 248460 . 275297)))))
|
||||
108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130838 (\TEXTMENU.START 112725 . 116438) (
|
||||
\TEXTMENU.DOC.CREATE 116440 . 127964) (TEXTMENU.CLOSEFN 127966 . 130836)) (131148 151212 (
|
||||
\TEDITMENU.CREATE 131158 . 131458) (\TEDIT.EXPANDED.MENU 131460 . 132164) (MB.DEFAULTBUTTON.FN 132166
|
||||
. 135038) (\TEDITMENU.RECORD.UNFORMATTED 135040 . 135378) (MB.DEFAULTBUTTON.ACTIONFN 135380 . 151210)
|
||||
) (151213 178596 (\TEDIT.CHARLOOKSMENU.CREATE 151223 . 153363) (\TEDIT.EXPANDEDCHARLOOKS.MENU 153365
|
||||
. 153739) (\TEDIT.APPLY.BOLDNESS 153741 . 154026) (\TEDIT.APPLY.CHARLOOKS 154028 . 155959) (
|
||||
\TEDIT.APPLY.OLINE 155961 . 156242) (\TEDIT.SHOW.CHARLOOKS 156244 . 158157) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS 158159 . 159085) (\TEDIT.FILL.IN.CHARLOOKS.MENU 159087 . 166740) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166742 . 169625) (\TEDIT.PARSE.CHARLOOKS.MENU 169627 . 177735) (
|
||||
\TEDIT.APPLY.SLOPE 177737 . 178020) (\TEDIT.APPLY.STRIKEOUT 178022 . 178309) (\TEDIT.APPLY.ULINE
|
||||
178311 . 178594)) (178597 210663 (\TEDITPARAMENU.CREATE 178607 . 178987) (\TEDIT.EXPANDEDPARA.MENU
|
||||
178989 . 179309) (\TEDIT.APPLY.PARALOOKS 179311 . 191541) (\TEDIT.SHOW.PARALOOKS 191543 . 203070) (
|
||||
\TEDIT.NEUTRALIZE.PARALOOKS.MENU 203072 . 209143) (\TEDIT.RECORD.TABLEADERS 209145 . 210661)) (210664
|
||||
248666 (\TEDIT.SHOW.PAGEFORMATTING 210674 . 227214) (\TEDITPAGEMENU.CREATE 227216 . 228259) (
|
||||
\TEDIT.APPLY.PAGEFORMATTING 228261 . 240632) (TEDIT.UNPARSE.PAGEFORMAT 240634 . 248664)) (248971
|
||||
275820 (\TEDIT.MENU.INIT 248981 . 275818)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "29-Sep-2021 22:03:57"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;8 214517
|
||||
(FILECREATED "12-Jan-2022 18:56:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITSCREEN.;11 214540
|
||||
|
||||
changes to%: (FNS \DISPLAYLINE)
|
||||
:CHANGES-TO (FNS \SHOWTEXT)
|
||||
|
||||
previous date%: "21-Sep-2021 12:53:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITSCREEN.;7)
|
||||
:PREVIOUS-DATE "12-Jan-2022 18:27:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITSCREEN.;10)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -1409,14 +1409,13 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS MI-TEDIT.BLTCHAR MACRO [(CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT
|
||||
CLIPRIGHT)
|
||||
(COND
|
||||
((EQ 'MAIKO (MACHINETYPE))
|
||||
(SUBRCALL TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
|
||||
(T (\TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT])
|
||||
(PUTPROPS MI-TEDIT.BLTCHAR MACRO [(CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT)
|
||||
(COND
|
||||
((EQ 'MAIKO (MACHINETYPE))
|
||||
(SUBRCALL TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX DISPLAYDATA
|
||||
DDPILOTBBT CLIPRIGHT))
|
||||
(T (\TEDIT.BLTCHAR CHARCODE DISPLAYSTREAM CURX DISPLAYDATA
|
||||
DDPILOTBBT CLIPRIGHT])
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -2212,53 +2211,58 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
(\TEDIT.FIXINSSEL SEL TEXTOBJ CH#1 DCH])
|
||||
|
||||
(\SHOWTEXT
|
||||
[LAMBDA (TEXTOBJ LINES WINDOW) (* ; "Edited 12-Jun-90 19:22 by mitani")
|
||||
(* Fill the editor window with text,
|
||||
starting from the top of the file.)
|
||||
[LAMBDA (TEXTOBJ LINES WINDOW)
|
||||
|
||||
(* ;; "Edited 12-Jan-2022 18:56 by rmk: I took out the WAITINGCURSOR, the resetsave wasn't working for some reason, and it really isn't necessary for modern machines.")
|
||||
|
||||
(* ;; "Edited 12-Jun-90 19:22 by mitani")
|
||||
|
||||
(* ;; "Fill the editor window with text, starting from the top of the file.")
|
||||
|
||||
(COND
|
||||
((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (* If there is no edit window, just
|
||||
return.)
|
||||
(PROG (WREG)
|
||||
(SETQ WINDOW (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ)))
|
||||
(DSPFILL (PROG1 (DSPCLIPPINGREGION NIL WINDOW) (* For region within a window%:)
|
||||
(* (CREATEREGION (fetch
|
||||
(TEXTOBJ WLEFT) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)
|
||||
(IDIFFERENCE (fetch
|
||||
(TEXTOBJ WRIGHT) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ WLEFT) of TEXTOBJ))
|
||||
(IDIFFERENCE (fetch
|
||||
(TEXTOBJ WTOP) of TEXTOBJ)
|
||||
(fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))))
|
||||
)
|
||||
WHITESHADE
|
||||
'REPLACE WINDOW) (* Clear the window.)
|
||||
(RETURN (RESETLST
|
||||
(RESETSAVE (CURSOR WAITINGCURSOR)) (* Display the hourglass cursor as
|
||||
we work)
|
||||
(SETQ LINES
|
||||
(create LINEDESCRIPTOR
|
||||
YBOT _ (WINDOWPROP WINDOW 'HEIGHT)
|
||||
CHAR1 _ 0
|
||||
CHARLIM _ 0
|
||||
SPACELEFT _ -1
|
||||
RIGHTMARGIN _ (SUB1 (fetch (TEXTOBJ WRIGHT) of TEXTOBJ))
|
||||
NEXTLINE _ NIL
|
||||
CHARTOP _ -1
|
||||
LHEIGHT _ 0
|
||||
LXLIM _ (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)
|
||||
CR\END _ T
|
||||
ASCENT _ 0
|
||||
DESCENT _ 0
|
||||
LTRUEASCENT _ 0
|
||||
LFMTSPEC _ TEDIT.DEFAULT.FMTSPEC))
|
||||
(* Make sure we have the anchor
|
||||
pseudo-line)
|
||||
(WINDOWPROP WINDOW 'LINES LINES)
|
||||
(\FILLWINDOW (WINDOWPROP WINDOW 'HEIGHT)
|
||||
LINES TEXTOBJ NIL WINDOW) (* Fill the window as usual)
|
||||
(\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW)
|
||||
LINES)])
|
||||
((fetch (TEXTOBJ \WINDOW) of TEXTOBJ) (* ;
|
||||
"If there is no edit window, just return.")
|
||||
(PROG1 (PROG (WREG)
|
||||
(SETQ WINDOW (OR WINDOW (\TEDIT.PRIMARYW TEXTOBJ)))
|
||||
(DSPFILL (PROG1 (DSPCLIPPINGREGION NIL WINDOW)
|
||||
(* ; "For region within a window:")
|
||||
|
||||
(* ;; "(CREATEREGION (fetch (TEXTOBJ WLEFT) of TEXTOBJ) (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ) (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) of TEXTOBJ) (fetch (TEXTOBJ WLEFT) of TEXTOBJ)) (IDIFFERENCE (fetch (TEXTOBJ WTOP) of TEXTOBJ) (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ)))")
|
||||
|
||||
)
|
||||
WHITESHADE
|
||||
'REPLACE WINDOW) (* ; "Clear the window.")
|
||||
(RETURN (RESETLST
|
||||
|
||||
(* ;; "RMK: For reasons unknown, the original cursor is not restored when this exits. But there is presumably no need for this waiting indicator in modern times. This only fills lines visible within a window, and machines are really fast.")
|
||||
|
||||
(* ;; "Display the hourglass cursor as we work")
|
||||
|
||||
(AND NIL (RESETSAVE (CURSOR WAITINGCURSOR)))
|
||||
(SETQ LINES
|
||||
(create LINEDESCRIPTOR
|
||||
YBOT _ (WINDOWPROP WINDOW 'HEIGHT)
|
||||
CHAR1 _ 0
|
||||
CHARLIM _ 0
|
||||
SPACELEFT _ -1
|
||||
RIGHTMARGIN _ (SUB1 (fetch (TEXTOBJ WRIGHT) of TEXTOBJ))
|
||||
NEXTLINE _ NIL
|
||||
CHARTOP _ -1
|
||||
LHEIGHT _ 0
|
||||
LXLIM _ (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)
|
||||
CR\END _ T
|
||||
ASCENT _ 0
|
||||
DESCENT _ 0
|
||||
LTRUEASCENT _ 0
|
||||
LFMTSPEC _ TEDIT.DEFAULT.FMTSPEC))
|
||||
(* ;
|
||||
"Make sure we have the anchor pseudo-line")
|
||||
(WINDOWPROP WINDOW 'LINES LINES)
|
||||
(\FILLWINDOW (WINDOWPROP WINDOW 'HEIGHT)
|
||||
LINES TEXTOBJ NIL WINDOW)
|
||||
(* ; "Fill the window as usual")
|
||||
(\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW)
|
||||
LINES)])
|
||||
|
||||
(\TEDIT.ADJUST.LINES
|
||||
[LAMBDA (TEXTOBJ FIRSTLINE WINDOW LINETOP DY) (* ; "Edited 30-May-91 15:59 by jds")
|
||||
@@ -2979,25 +2983,25 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
|
||||
|
||||
(* (VARS (TEDIT.DONT.BREAK.CHARS (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" "41,115"
|
||||
"41,133" "41,131" "41,127" "Hira,41" "Hira,43" "Hira,45" "Hira,47" "Hira,51" "Hira,103" "Hira,143"
|
||||
"Hira,145" "Hira,147" "Hira,156" "Kata,41" "Kata,43" "Kata,45" "Kata,47" "Kata,51" "Kata,103"
|
||||
"Kata,143" "Kata,145" "Kata,147" "Kata,156"))) (TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132"
|
||||
"41,130" "41,126"))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)))
|
||||
(* (VARS (TEDIT.DONT.BREAK.CHARS (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" "41,115" "41,133"
|
||||
"41,131" "41,127" "Hira,41" "Hira,43" "Hira,45" "Hira,47" "Hira,51" "Hira,103" "Hira,143" "Hira,145"
|
||||
"Hira,147" "Hira,156" "Kata,41" "Kata,43" "Kata,45" "Kata,47" "Kata,51" "Kata,103" "Kata,143"
|
||||
"Kata,145" "Kata,147" "Kata,156"))) (TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132" "41,130"
|
||||
"41,126"))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)))
|
||||
|
||||
(PUTPROPS TEDITSCREEN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||
1991 1992 1993 1994 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2767 76759 (\FORMATLINE 2777 . 56505) (\TEDIT.NSCHAR.RUN 56507 . 63324) (
|
||||
\TEDIT.PURGE.SPACES 63326 . 63784) (\DOFORMATTING 63786 . 76757)) (76760 98628 (\DISPLAYLINE 76770 .
|
||||
94628) (\TEDIT.LINECACHE 94630 . 95381) (\TEDIT.CREATE.LINECACHE 95383 . 96127) (\TEDIT.BLTCHAR 96129
|
||||
. 98626)) (99342 213797 (TEDIT.CR.UPDATESCREEN 99352 . 100603) (TEDIT.DELETELINE 100605 . 101639) (
|
||||
TEDIT.INSERT.DISPLAYTEXT 101641 . 116880) (TEDIT.INSERT.UPDATESCREEN 116882 . 123634) (
|
||||
TEDIT.UPDATE.SCREEN 123636 . 124854) (\BACKFORMAT 124856 . 129167) (\FILLWINDOW 129169 . 144273) (
|
||||
\FIXDLINES 144275 . 151512) (\FIXILINES 151514 . 159489) (\SHOWTEXT 159491 . 162747) (
|
||||
\TEDIT.ADJUST.LINES 162749 . 170216) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170218 . 170948) (
|
||||
\TEDIT.CLOSEUPLINES 170950 . 179466) (\TEDIT.COPY.LINEDESCRIPTOR 179468 . 185034) (
|
||||
\TEDIT.FIXCHANGEDLINE 185036 . 196215) (\TEDIT.FIXCHANGEDPART 196217 . 208644) (\TEDIT.INSERTLINE
|
||||
208646 . 209466) (\TEDIT.LINE.LIST 209468 . 209794) (\TEDIT.MARK.LINES.DIRTY 209796 . 211482) (
|
||||
\TEDIT.NEXT.LINE.BOTTOM 211484 . 213795)))))
|
||||
(FILEMAP (NIL (2761 76753 (\FORMATLINE 2771 . 56499) (\TEDIT.NSCHAR.RUN 56501 . 63318) (
|
||||
\TEDIT.PURGE.SPACES 63320 . 63778) (\DOFORMATTING 63780 . 76751)) (76754 98622 (\DISPLAYLINE 76764 .
|
||||
94622) (\TEDIT.LINECACHE 94624 . 95375) (\TEDIT.CREATE.LINECACHE 95377 . 96121) (\TEDIT.BLTCHAR 96123
|
||||
. 98620)) (99237 213820 (TEDIT.CR.UPDATESCREEN 99247 . 100498) (TEDIT.DELETELINE 100500 . 101534) (
|
||||
TEDIT.INSERT.DISPLAYTEXT 101536 . 116775) (TEDIT.INSERT.UPDATESCREEN 116777 . 123529) (
|
||||
TEDIT.UPDATE.SCREEN 123531 . 124749) (\BACKFORMAT 124751 . 129062) (\FILLWINDOW 129064 . 144168) (
|
||||
\FIXDLINES 144170 . 151407) (\FIXILINES 151409 . 159384) (\SHOWTEXT 159386 . 162770) (
|
||||
\TEDIT.ADJUST.LINES 162772 . 170239) (\TEDIT.CLEAR.SCREEN.BELOW.LINE 170241 . 170971) (
|
||||
\TEDIT.CLOSEUPLINES 170973 . 179489) (\TEDIT.COPY.LINEDESCRIPTOR 179491 . 185057) (
|
||||
\TEDIT.FIXCHANGEDLINE 185059 . 196238) (\TEDIT.FIXCHANGEDPART 196240 . 208667) (\TEDIT.INSERTLINE
|
||||
208669 . 209489) (\TEDIT.LINE.LIST 209491 . 209817) (\TEDIT.MARK.LINES.DIRTY 209819 . 211505) (
|
||||
\TEDIT.NEXT.LINE.BOTTOM 211507 . 213818)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Oct-2021 18:52:11"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;18 187780
|
||||
(FILECREATED "21-Jan-2022 23:14:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;32 189300
|
||||
|
||||
changes to%: (FNS TEDIT.DEACTIVATE.WINDOW)
|
||||
:CHANGES-TO (FNS TEDIT.GETINPUT)
|
||||
|
||||
previous date%: "12-Oct-2021 15:10:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;17)
|
||||
:PREVIOUS-DATE " 1-Jan-2022 23:55:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITWINDOW.;31)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -34,7 +34,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(INITVARS (TEDIT.DEFAULT.WINDOW NIL))
|
||||
(GLOBALVARS TEDIT.DEFAULT.WINDOW)
|
||||
(COMS (* ;
|
||||
"User-level %"is this a TEdit window?%" function.")
|
||||
"User-level %"is this a TEdit window?%" function.")
|
||||
(FNS TEDITWINDOWP))
|
||||
(COMS (* ; "User-typein support")
|
||||
(FNS TEDIT.GETINPUT \TEDIT.MAKEFILENAME))
|
||||
@@ -51,8 +51,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(COMS (* ; "Process-world interfaces")
|
||||
(FNS \TEDIT.PROCIDLEFN \TEDIT.PROCENTRYFN \TEDIT.PROCEXITFN))
|
||||
(COMS (INITVARS (\CARETRATE 333))
|
||||
(* ;
|
||||
"Caret handler; stolen from CHAT.")
|
||||
(* ; "Caret handler; stolen from CHAT.")
|
||||
(FNS \EDIT.DOWNCARET \EDIT.FLIPCARET TEDIT.FLASHCARET \EDIT.UPCARET
|
||||
TEDIT.NORMALIZECARET \SETCARET \TEDIT.CARET))
|
||||
[COMS (* ; "Menu interfacing")
|
||||
@@ -89,15 +88,15 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(INITVARS (TEDIT.ICON.FONT (FONTCREATE 'HELVETICA 8 'BOLD))
|
||||
[TEDIT.ICON.TITLE.REGION (CONS 16 (CONS 4 (CONS 64 (CONS 77 NIL]
|
||||
(* ;
|
||||
"Original was (create REGION BOTTOM _ 4 LEFT _ 16 WIDTH _ 64 HEIGHT _ 77).")
|
||||
"Original was (create REGION BOTTOM _ 4 LEFT _ 16 WIDTH _ 64 HEIGHT _ 77).")
|
||||
(* ;
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
[TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS
|
||||
TEDIT.ICON.TITLE.REGION
|
||||
NIL]
|
||||
(* ; "Original was (create TITLEDICON ICON _ TEDITICON MASK _ TEDITMASK TITLEREG _ TEDIT.ICON.TITLE.REGION).")
|
||||
(* ;
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
])
|
||||
|
||||
(FILESLOAD TEDITDCL)
|
||||
@@ -119,27 +118,53 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(DEFINEQ
|
||||
|
||||
(TEDIT.CREATEW
|
||||
[LAMBDA (PROMPT FILE PROPS) (* jds "23-May-85 15:19")
|
||||
[LAMBDA (PROMPT FILE PROPS) (* ; "Edited 1-Jan-2022 23:54 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 23:00 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 16:35 by rmk")
|
||||
(* ; "Edited 24-Dec-2021 19:21 by rmk")
|
||||
(* ; "Edited 27-Oct-2021 12:25 by rmk:")
|
||||
|
||||
(* ;; "RMK: PROPS are passed to CREATEW and \TEDIT.ORIGINAL.WINDOW.TITLE. .")
|
||||
|
||||
(* ;;
|
||||
"RMK: If PROMPTWINDOW is in PROPS, I don't see how it gets attached to the new Tedit window.")
|
||||
|
||||
(* ;;
|
||||
"Also odd: The argument PROMPT gets printed, but then gets replaced by the property PROMPT")
|
||||
|
||||
(* ;; "Don't set the global TEDIT default window if we have a region property, that must be special purpose.")
|
||||
(* jds "23-May-85 15:19")
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW PROMPT T)
|
||||
(PROG ((PROMPT (LISTGET PROPS 'PROMPTWINDOW))
|
||||
(PHEIGHT 0)
|
||||
PWINDOW REGION)
|
||||
[COND
|
||||
((EQ PROMPT 'DON'T))
|
||||
(PROMPT)
|
||||
(T (SETQ PHEIGHT (HEIGHTIFWINDOW (ITIMES (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
(FONTPROP TEDIT.PROMPT.FONT 'HEIGHT]
|
||||
(SETQ REGION (GETREGION 32 (IPLUS PHEIGHT 32)))
|
||||
(add (fetch HEIGHT of REGION)
|
||||
(IMINUS PHEIGHT))
|
||||
(SETQ TEDIT.DEFAULT.WINDOW (CREATEW REGION (\TEDIT.ORIGINAL.WINDOW.TITLE FILE)))
|
||||
(CLRPROMPT)
|
||||
(OR PROMPT (GETPROMPTWINDOW TEDIT.DEFAULT.WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
TEDIT.PROMPT.FONT)))
|
||||
TEDIT.DEFAULT.WINDOW])
|
||||
(LET ((PROMPT (LISTGET PROPS 'PROMPTWINDOW))
|
||||
(PHEIGHT 0)
|
||||
REGION
|
||||
(REGIONTYPE (LISTGET PROPS 'REGION-TYPE))
|
||||
WINDOW)
|
||||
|
||||
(* ;; "All this prompt-height calculation would be unnecessary if the attachment in GETPROMPTWINDOW does the proper shrinking of the main window.")
|
||||
|
||||
[COND
|
||||
((EQ PROMPT 'DON'T))
|
||||
[PROMPT (CL:WHEN (WINDOWP PROMPT) (* ;
|
||||
"RMK: If not a window, PHEIGHT remains 0")
|
||||
(SETQ PHEIGHT (FETCH (REGION HEIGHT) OF (WINDOWREGION PROMPT))))]
|
||||
(T (SETQ PHEIGHT (HEIGHTIFWINDOW (ITIMES (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
(FONTPROP TEDIT.PROMPT.FONT 'HEIGHT]
|
||||
(SETQ REGION (OR (REGIONP REGIONTYPE)
|
||||
(GETREGION 32 (IPLUS PHEIGHT 32)
|
||||
REGIONTYPE)))
|
||||
(add (fetch HEIGHT of REGION)
|
||||
(IMINUS PHEIGHT))
|
||||
(SETQ WINDOW (CREATEW REGION (\TEDIT.ORIGINAL.WINDOW.TITLE FILE NIL PROPS)
|
||||
NIL NIL PROPS))
|
||||
(WINDOWPROP WINDOW 'TEDITCREATED T)
|
||||
(OR PROMPT (GETPROMPTWINDOW WINDOW (OR (LISTGET PROPS 'PROMPTWINDOWHEIGHT)
|
||||
TEDIT.PROMPTWINDOW.HEIGHT 1)
|
||||
TEDIT.PROMPT.FONT))
|
||||
(CL:UNLESS REGIONTYPE (SETQ TEDIT.DEFAULT.WINDOW WINDOW))
|
||||
WINDOW])
|
||||
|
||||
(\TEDIT.CREATEW.FROM.REGION
|
||||
[LAMBDA (REGION FILE PROPS) (* gbn "15-Nov-84 18:04")
|
||||
@@ -1446,7 +1471,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
(DEFINEQ
|
||||
|
||||
(TEDIT.GETINPUT
|
||||
[LAMBDA (STREAM PROMPTSTRING DEFAULTSTRING DELIMITER.LIST)
|
||||
[LAMBDA (STREAM PROMPTSTRING DEFAULTSTRING DELIMITER.LIST) (* ; "Edited 21-Jan-2022 23:14 by rmk")
|
||||
(* ; "Edited 30-May-91 23:34 by jds")
|
||||
|
||||
(* ;; "Ask for input (file names, &c) for TEdit, perhaps with a default.")
|
||||
@@ -1462,20 +1487,20 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
TPROMPT))
|
||||
(COND
|
||||
(TPROMPT (* ;
|
||||
"If it's our own promptwindow, just clear it.")
|
||||
"If it's our own promptwindow, just clear it.")
|
||||
(CLEARW TPROMPT))
|
||||
(T (* ;
|
||||
"If it's the system's window, just move to a new line.")
|
||||
"If it's the system's window, just move to a new line.")
|
||||
(FRESHLINE PROMPTWINDOW)))
|
||||
(RETURN (PROG1 (PROMPTFORWORD PROMPTSTRING DEFAULTSTRING NIL (OR TPROMPT PROMPTWINDOW)
|
||||
(RETURN (PROG1 (TTYINPROMPTFORWORD PROMPTSTRING DEFAULTSTRING NIL (OR TPROMPT PROMPTWINDOW
|
||||
)
|
||||
NIL
|
||||
'TTY
|
||||
(OR DELIMITER.LIST (CHARCODE (EOL LF TAB ESCAPE)))
|
||||
NIL) (* ;
|
||||
"Get what the guy wants to tell us")
|
||||
NIL) (* ; "Get what the guy wants to tell us")
|
||||
(WINDOWPROP (OR TPROMPT PROMPTWINDOW)
|
||||
'PROCESS NIL) (* ;
|
||||
"Now detach the prompt window from its process, to avoid a circularity.")
|
||||
"Now detach the prompt window from its process, to avoid a circularity.")
|
||||
)])
|
||||
|
||||
(\TEDIT.MAKEFILENAME
|
||||
@@ -1627,43 +1652,36 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
""])
|
||||
|
||||
(\TEDIT.ORIGINAL.WINDOW.TITLE
|
||||
[LAMBDA (FILE DIRTY?) (* ; "Edited 24-Aug-2021 23:25 by rmk:")
|
||||
[LAMBDA (FILE DIRTY? PROPS) (* ; "Edited 27-Oct-2021 12:25 by rmk:")
|
||||
(* ; "Edited 24-Aug-2021 23:25 by rmk:")
|
||||
|
||||
(* ;; "Given a file name, derive a title for the TEdit window that is editing it.")
|
||||
(* ;; "Given a file name, derive a title for the TEdit window that is editing it. RMK: Title may be provided in a property")
|
||||
|
||||
(PROG (TITLE)
|
||||
(RETURN (COND
|
||||
((NULL FILE) (* ;
|
||||
"Just calling (TEDIT) should give a 'Text Editor Window'")
|
||||
(CONCAT (COND
|
||||
(DIRTY? "* ")
|
||||
(T ""))
|
||||
(LET (TITLE)
|
||||
[SETQ TITLE (COND
|
||||
((LISTGET PROPS 'TITLE))
|
||||
((NULL FILE) (* ;
|
||||
"Just calling (TEDIT) should give a 'Text Editor Window'")
|
||||
"Text Editor Window")
|
||||
((AND (STRINGP FILE)
|
||||
(ZEROP (NCHARS FILE))) (* ;
|
||||
"So should editing an empty string")
|
||||
"Text Editor Window")
|
||||
((WINDOWP FILE) (* ;
|
||||
"if \TEDIT.WINDOW.SETUP has assigned a title, use it")
|
||||
(OR (WINDOWPROP FILE 'TITLE)
|
||||
"Text Editor Window"))
|
||||
((AND (STRINGP FILE)
|
||||
(ZEROP (NCHARS FILE))) (* ;
|
||||
"So should editing an empty string")
|
||||
(CONCAT (COND
|
||||
(DIRTY? "* ")
|
||||
(T ""))
|
||||
"Text Editor Window"))
|
||||
((WINDOWP FILE)
|
||||
(COND
|
||||
((SETQ TITLE (WINDOWPROP FILE 'TITLE))
|
||||
(* ;
|
||||
"if \TEDIT.WINDOW.SETUP has assigned a title, use it")
|
||||
TITLE)
|
||||
(T "Text Editor Window")))
|
||||
(T (* ;
|
||||
"Strings use the string itself, otherwise grab the full file name.")
|
||||
(CONCAT (COND
|
||||
(DIRTY? "* ")
|
||||
(T ""))
|
||||
"Edit Window for: "
|
||||
(CL:TYPECASE FILE
|
||||
(STRINGP FILE)
|
||||
(STREAM (fetch (STREAM FULLNAME) of FILE))
|
||||
(LITATOM FILE)
|
||||
(T FILE))])
|
||||
(T (* ;
|
||||
"Strings use the string itself, otherwise grab the full file name.")
|
||||
(CONCAT "Edit Window for: " (CL:TYPECASE FILE
|
||||
(STRINGP FILE)
|
||||
(STREAM (fetch (STREAM FULLNAME)
|
||||
of FILE))
|
||||
(LITATOM FILE)
|
||||
(T FILE))]
|
||||
(COND
|
||||
(DIRTY? (CONCAT "* " TITLE))
|
||||
(T TITLE])
|
||||
|
||||
(\TEDIT.WINDOW.TITLE
|
||||
[LAMBDA (TEXTSTREAM NEW.TITLE) (* jds "23-May-85 15:20")
|
||||
@@ -2851,30 +2869,30 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
|
||||
|
||||
(RPAQ? TEDIT.ICON.TITLE.REGION [CONS 16 (CONS 4 (CONS 64 (CONS 77 NIL])
|
||||
|
||||
(RPAQ? TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS TEDIT.ICON.TITLE.REGION
|
||||
NIL))))
|
||||
(RPAQ? TEDIT.TITLED.ICON.TEMPLATE (CONS TEDITICON (CONS TEDITMASK (CONS TEDIT.ICON.TITLE.REGION NIL))
|
||||
))
|
||||
(PUTPROPS TEDITWINDOW COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988
|
||||
1989 1990 1991 1993 1994 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7291 94107 (TEDIT.CREATEW 7301 . 8437) (\TEDIT.CREATEW.FROM.REGION 8439 . 9423) (
|
||||
TEDIT.CURSORMOVEDFN 9425 . 20811) (TEDIT.CURSOROUTFN 20813 . 21348) (TEDIT.WINDOW.SETUP 21350 . 23159)
|
||||
(TEDIT.MINIMAL.WINDOW.SETUP 23161 . 30950) (\TEDIT.ACTIVE.WINDOWP 30952 . 31933) (
|
||||
\TEDIT.BUTTONEVENTFN 31935 . 56925) (\TEDIT.WINDOW.OPS 56927 . 60888) (\TEDIT.EXPANDFN 60890 . 61293)
|
||||
(\TEDIT.MAINW 61295 . 62584) (\TEDIT.PRIMARYW 62586 . 63798) (\TEDIT.COPYINSERTFN 63800 . 64771) (
|
||||
\TEDIT.NEWREGIONFN 64773 . 67240) (\TEDIT.SET.WINDOW.EXTENT 67242 . 73344) (\TEDIT.SHRINK.ICONCREATE
|
||||
73346 . 75618) (\TEDIT.SHRINKFN 75620 . 76195) (\TEDIT.SPLITW 76197 . 82298) (\TEDIT.UNSPLITW 82300 .
|
||||
87994) (\TEDIT.WINDOW.SETUP 87996 . 93716) (\SAFE.FIRST 93718 . 94105)) (95437 96344 (TEDITWINDOWP
|
||||
95447 . 96342)) (96381 98877 (TEDIT.GETINPUT 96391 . 98374) (\TEDIT.MAKEFILENAME 98376 . 98875)) (
|
||||
98926 105377 (TEDIT.PROMPTPRINT 98936 . 101840) (TEDIT.PROMPTFLASH 101842 . 103797) (
|
||||
\TEDIT.PROMPT.PAGEFULLFN 103799 . 105375)) (105612 109674 (TEXTSTREAM.TITLE 105622 . 106243) (
|
||||
\TEDIT.ORIGINAL.WINDOW.TITLE 106245 . 108290) (\TEDIT.WINDOW.TITLE 108292 . 108962) (
|
||||
\TEXTSTREAM.FILENAME 108964 . 109672)) (109717 154616 (TEDIT.DEACTIVATE.WINDOW 109727 . 117034) (
|
||||
\TEDIT.REPAINTFN 117036 . 119893) (\TEDIT.RESHAPEFN 119895 . 125515) (\TEDIT.SCROLLFN 125517 . 154614)
|
||||
) (154658 156707 (\TEDIT.PROCIDLEFN 154668 . 156017) (\TEDIT.PROCENTRYFN 156019 . 156312) (
|
||||
\TEDIT.PROCEXITFN 156314 . 156705)) (156786 167786 (\EDIT.DOWNCARET 156796 . 157477) (\EDIT.FLIPCARET
|
||||
157479 . 159014) (TEDIT.FLASHCARET 159016 . 160130) (\EDIT.UPCARET 160132 . 160585) (
|
||||
TEDIT.NORMALIZECARET 160587 . 166538) (\SETCARET 166540 . 167460) (\TEDIT.CARET 167462 . 167784)) (
|
||||
167820 181575 (TEDIT.ADD.MENUITEM 167830 . 169745) (TEDIT.DEFAULT.MENUFN 169747 . 179014) (
|
||||
TEDIT.REMOVE.MENUITEM 179016 . 180017) (\TEDIT.CREATEMENU 180019 . 180472) (\TEDIT.MENU.WHENHELDFN
|
||||
180474 . 181244) (\TEDIT.MENU.WHENSELECTEDFN 181246 . 181573)))))
|
||||
(FILEMAP (NIL (7221 95655 (TEDIT.CREATEW 7231 . 9985) (\TEDIT.CREATEW.FROM.REGION 9987 . 10971) (
|
||||
TEDIT.CURSORMOVEDFN 10973 . 22359) (TEDIT.CURSOROUTFN 22361 . 22896) (TEDIT.WINDOW.SETUP 22898 . 24707
|
||||
) (TEDIT.MINIMAL.WINDOW.SETUP 24709 . 32498) (\TEDIT.ACTIVE.WINDOWP 32500 . 33481) (
|
||||
\TEDIT.BUTTONEVENTFN 33483 . 58473) (\TEDIT.WINDOW.OPS 58475 . 62436) (\TEDIT.EXPANDFN 62438 . 62841)
|
||||
(\TEDIT.MAINW 62843 . 64132) (\TEDIT.PRIMARYW 64134 . 65346) (\TEDIT.COPYINSERTFN 65348 . 66319) (
|
||||
\TEDIT.NEWREGIONFN 66321 . 68788) (\TEDIT.SET.WINDOW.EXTENT 68790 . 74892) (\TEDIT.SHRINK.ICONCREATE
|
||||
74894 . 77166) (\TEDIT.SHRINKFN 77168 . 77743) (\TEDIT.SPLITW 77745 . 83846) (\TEDIT.UNSPLITW 83848 .
|
||||
89542) (\TEDIT.WINDOW.SETUP 89544 . 95264) (\SAFE.FIRST 95266 . 95653)) (96985 97892 (TEDITWINDOWP
|
||||
96995 . 97890)) (97929 100502 (TEDIT.GETINPUT 97939 . 99999) (\TEDIT.MAKEFILENAME 100001 . 100500)) (
|
||||
100551 107002 (TEDIT.PROMPTPRINT 100561 . 103465) (TEDIT.PROMPTFLASH 103467 . 105422) (
|
||||
\TEDIT.PROMPT.PAGEFULLFN 105424 . 107000)) (107237 111230 (TEXTSTREAM.TITLE 107247 . 107868) (
|
||||
\TEDIT.ORIGINAL.WINDOW.TITLE 107870 . 109846) (\TEDIT.WINDOW.TITLE 109848 . 110518) (
|
||||
\TEXTSTREAM.FILENAME 110520 . 111228)) (111273 156172 (TEDIT.DEACTIVATE.WINDOW 111283 . 118590) (
|
||||
\TEDIT.REPAINTFN 118592 . 121449) (\TEDIT.RESHAPEFN 121451 . 127071) (\TEDIT.SCROLLFN 127073 . 156170)
|
||||
) (156214 158263 (\TEDIT.PROCIDLEFN 156224 . 157573) (\TEDIT.PROCENTRYFN 157575 . 157868) (
|
||||
\TEDIT.PROCEXITFN 157870 . 158261)) (158342 169342 (\EDIT.DOWNCARET 158352 . 159033) (\EDIT.FLIPCARET
|
||||
159035 . 160570) (TEDIT.FLASHCARET 160572 . 161686) (\EDIT.UPCARET 161688 . 162141) (
|
||||
TEDIT.NORMALIZECARET 162143 . 168094) (\SETCARET 168096 . 169016) (\TEDIT.CARET 169018 . 169340)) (
|
||||
169376 183131 (TEDIT.ADD.MENUITEM 169386 . 171301) (TEDIT.DEFAULT.MENUFN 171303 . 180570) (
|
||||
TEDIT.REMOVE.MENUITEM 180572 . 181573) (\TEDIT.CREATEMENU 181575 . 182028) (\TEDIT.MENU.WHENHELDFN
|
||||
182030 . 182800) (\TEDIT.MENU.WHENSELECTEDFN 182802 . 183129)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
688
library/TEXTOFD
688
library/TEXTOFD
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "12-Oct-2021 15:38:41"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEXTOFD.;4 176302
|
||||
(FILECREATED "22-Dec-2021 10:29:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;12 182752
|
||||
|
||||
changes to%: (FNS \TEDITOUTCCODEFN)
|
||||
:CHANGES-TO (FNS \TEXTBIN \TEXTPEEKBIN)
|
||||
|
||||
previous date%: " 7-Oct-2021 08:41:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEXTOFD.;3)
|
||||
:PREVIOUS-DATE "22-Dec-2021 10:01:53"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;11)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -31,7 +30,7 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(FNS \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE
|
||||
\INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE))
|
||||
(COMS (* ;
|
||||
"Generic-IO type operations support")
|
||||
"Generic-IO type operations support")
|
||||
(FNS \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR
|
||||
\TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR
|
||||
\TEXTBOUT \TEDITOUTCCODEFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION
|
||||
@@ -1913,214 +1912,248 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(DEFINEQ
|
||||
|
||||
(\TEXTBIN
|
||||
[LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:33 by jds")
|
||||
[LAMBDA (STREAM)
|
||||
|
||||
(* ;; "Edited 22-Dec-2021 10:29 by rmk: Return value of OBJECTCHAR property for image objecdts")
|
||||
|
||||
(* ;; "Edited 28-Mar-94 15:33 by jds")
|
||||
|
||||
(* ;;; "Do BIN slow case for a text stream")
|
||||
(* ;
|
||||
"NB that PEEKBIN and BACKFILEPTR need to track changes in this code")
|
||||
"NB that PEEKBIN and BACKFILEPTR need to track changes in this code")
|
||||
(DECLARE (LOCALVARS . T))
|
||||
(PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(LET (BYTE) (* ;
|
||||
"RMK: Capture all return values for any special imageobject coercion")
|
||||
[SETQ BYTE (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(* ;
|
||||
"Simple case -- just do the usual BIN")
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) of STREAM
|
||||
)))
|
||||
"Simple case -- just do the usual BIN")
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
|
||||
of STREAM)))
|
||||
(* ; "Handle objects specially")
|
||||
(COND
|
||||
((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
|
||||
(COND
|
||||
((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
|
||||
(* ;
|
||||
"If this object has a substream in it, go to that substream")
|
||||
(add (fetch (STREAM COFFSET) of STREAM)
|
||||
1)
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T
|
||||
(* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")
|
||||
"If this object has a substream in it, go to that substream")
|
||||
(add (fetch (STREAM COFFSET) of STREAM)
|
||||
1)
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T
|
||||
(* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")
|
||||
|
||||
(replace (STREAM COFFSET) of STREAM with (fetch (STREAM
|
||||
CBUFSIZE)
|
||||
of STREAM))
|
||||
(replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
|
||||
(RETURN PO]
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(replace (STREAM COFFSET) of STREAM
|
||||
with (fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
|
||||
(RETURN PO]
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(* ;
|
||||
"This is a 16 bit BIN. grab 2 bytes.")
|
||||
"This is a 16 bit BIN. grab 2 bytes.")
|
||||
(* ;
|
||||
"WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")
|
||||
(RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(COND
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
"WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")
|
||||
(RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(COND
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(* ;
|
||||
"This pair of characters doesn't straddle a file page bound. Just grab the next char.")
|
||||
(\PAGEDBIN STREAM))
|
||||
(T (* ;
|
||||
"Need to move to the next page on the backing file. Doing so also grabs the next character.")
|
||||
(\TEDIT.TEXTBIN.NEW.PAGE STREAM T]
|
||||
(T (RETURN (\PAGEDBIN STREAM]
|
||||
(T (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
"This pair of characters doesn't straddle a file page bound. Just grab the next char.")
|
||||
(\PAGEDBIN STREAM))
|
||||
(T (* ;
|
||||
"Need to move to the next page on the backing file. Doing so also grabs the next character.")
|
||||
(\TEDIT.TEXTBIN.NEW.PAGE STREAM T]
|
||||
(T (RETURN (\PAGEDBIN STREAM]
|
||||
(T (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
(* ; "Time for a new piece.")
|
||||
[repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN) of PC)))
|
||||
do (* ;
|
||||
"Skip over any zero-length pieces at the end of the file.")
|
||||
(SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (AND OPC (fetch (PIECE NEXTPIECE)
|
||||
of OPC]
|
||||
(replace (STREAM BINABLE) of STREAM with T)
|
||||
(replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
|
||||
[repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN)
|
||||
of PC)))
|
||||
do (* ;
|
||||
"Skip over any zero-length pieces at the end of the file.")
|
||||
(SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (AND OPC (fetch (PIECE NEXTPIECE)
|
||||
of OPC]
|
||||
(replace (STREAM BINABLE) of STREAM with T)
|
||||
(replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
|
||||
(* ;
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (* ;
|
||||
"There IS a next piece to move to.")
|
||||
(AND (fetch (TEXTSTREAM LOOKSUPDATEFN) of STREAM)
|
||||
(SETQ NPC (APPLY* (fetch (TEXTSTREAM LOOKSUPDATEFN)
|
||||
of STREAM)
|
||||
STREAM PC))
|
||||
(replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (SETQ PC NPC)))
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (* ; "There IS a next piece to move to.")
|
||||
(AND (fetch (TEXTSTREAM LOOKSUPDATEFN)
|
||||
of STREAM)
|
||||
(SETQ NPC (APPLY* (fetch (TEXTSTREAM
|
||||
LOOKSUPDATEFN
|
||||
)
|
||||
of STREAM)
|
||||
STREAM PC))
|
||||
(replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (SETQ PC NPC)))
|
||||
(* ;
|
||||
"Take care of any piece-change uproar. uproar -- which may include picking a new piece to go to.")
|
||||
[COND
|
||||
(NPC (* ;
|
||||
"If we got an NPC, this was taken care of by the LOOKSUPDATEFN")
|
||||
)
|
||||
([AND (SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM]
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS) of
|
||||
SUBSTREAM
|
||||
)))
|
||||
[(NEQ (fetch (PIECE PPARALOOKS) of OPC)
|
||||
(fetch (PIECE PPARALOOKS) of PC))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.PARASTYLES (fetch (PIECE
|
||||
PPARALOOKS
|
||||
)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
((NOT (EQCLOOKS (fetch (PIECE PLOOKS) of PC)
|
||||
(fetch (PIECE PLOOKS) of OPC)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
(COND
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
"Take care of any piece-change uproar. uproar -- which may include picking a new piece to go to.")
|
||||
[COND
|
||||
(NPC (* ;
|
||||
"If we got an NPC, this was taken care of by the LOOKSUPDATEFN")
|
||||
)
|
||||
([AND (SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(SETQ SUBSTREAM (IMAGEOBJPROP
|
||||
PO
|
||||
'SUBSTREAM]
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
) of SUBSTREAM
|
||||
))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
CURRENTLOOKS)
|
||||
of SUBSTREAM)))
|
||||
[(NEQ (fetch (PIECE PPARALOOKS) of OPC)
|
||||
(fetch (PIECE PPARALOOKS) of PC))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (\TEDIT.APPLY.PARASTYLES
|
||||
(fetch (PIECE PPARALOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM with (\TEDIT.APPLY.STYLES
|
||||
(fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
((NOT (EQCLOOKS (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
(fetch (PIECE PLOOKS) of OPC)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM with (\TEDIT.APPLY.STYLES
|
||||
(fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
(COND
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
(* ; "This piece lives in a string.")
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PS)
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP
|
||||
0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PS)
|
||||
|
||||
(* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
|
||||
(* ;
|
||||
"Then actually grab the next character to hand back to the caller.")
|
||||
(\BIN STREAM))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
"Then actually grab the next character to hand back to the caller.")
|
||||
(\BIN STREAM))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
(* ; "This piece lives on a file.")
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PF (fetch (PIECE PFATP) of PC)
|
||||
'PEEKBIN)
|
||||
(\BIN STREAM))
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (STREAM COFFSET) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM
|
||||
with 0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
|
||||
CURRENTPARALOOKS
|
||||
) of
|
||||
SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(RETURN PO]
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(T (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(COND
|
||||
((fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PF (fetch (PIECE PFATP)
|
||||
of PC)
|
||||
'PEEKBIN)
|
||||
(\BIN STREAM))
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM
|
||||
with NIL)
|
||||
(COND
|
||||
(SUBSTREAM
|
||||
(* ;
|
||||
"If there's an EOF handler, call it & return the result")
|
||||
(RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM
|
||||
)
|
||||
STREAM)))
|
||||
(T (* ; "Otherwise, return NIL")
|
||||
(RETURN NIL]
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
|
||||
of STREAM)))
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM
|
||||
TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (STREAM COFFSET)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM
|
||||
with (fetch (PIECE PLEN)
|
||||
of PC))
|
||||
(freplace (STREAM CBUFSIZE)
|
||||
of STREAM
|
||||
with (fetch (PIECE PLEN)
|
||||
of PC))
|
||||
(freplace (STREAM CPAGE)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG)
|
||||
of STREAM with 0)
|
||||
(replace (TEXTSTREAM
|
||||
CURRENTPARALOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
) of SUBSTREAM
|
||||
))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM with 0)
|
||||
(RETURN PO]
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(T (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(COND
|
||||
((fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
(* ;
|
||||
"If there's an EOF handler, call it & return the result")
|
||||
(RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP)
|
||||
of STREAM)
|
||||
STREAM)))
|
||||
(T (* ; "Otherwise, return NIL")
|
||||
(RETURN NIL]
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
|
||||
of STREAM)))
|
||||
(* ; "This is an object")
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of
|
||||
SUBSTREAM))
|
||||
(freplace (STREAM COFFSET) of STREAM with 1)
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM with
|
||||
0)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM with
|
||||
1)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM with
|
||||
0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS) of
|
||||
SUBSTREAM
|
||||
))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
|
||||
(RETURN PO]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM])
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (STREAM COFFSET) of STREAM
|
||||
with 1)
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM
|
||||
with 1)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM
|
||||
with 0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
) of SUBSTREAM)
|
||||
)
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(RETURN PO]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM]
|
||||
(IF (IMAGEOBJP BYTE)
|
||||
THEN (OR (GETTEXTPROP (FETCH (TEXTSTREAM TEXTOBJ) OF STREAM)
|
||||
'OBJECTBYTE)
|
||||
BYTE)
|
||||
ELSE BYTE])
|
||||
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP
|
||||
[LAMBDA (CHOFFSET CHARSLEFT STREAM PS) (* ; "Edited 31-May-91 14:21 by jds")
|
||||
@@ -2353,123 +2386,144 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(DEFINEQ
|
||||
|
||||
(\TEXTPEEKBIN
|
||||
[LAMBDA (STREAM NOERRORFLG) (* ; "Edited 28-Mar-94 15:34 by jds")
|
||||
[LAMBDA (STREAM NOERRORFLG)
|
||||
|
||||
(* ;; "Edited 22-Dec-2021 10:29 by rmk: Return OBJECTCHAR for image objects, if present")
|
||||
|
||||
(* ;; "Edited 28-Mar-94 15:34 by jds")
|
||||
(* ; "DO PEEKBIN for a text stream")
|
||||
(PROG (CH FILE STR PF PS PC PO SUBSTREAM)
|
||||
(SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(LET (BYTE) (* ;
|
||||
"BYTE to capture all returns for imageobject coercion")
|
||||
[SETQ BYTE (PROG (CH FILE STR PF PS PC PO SUBSTREAM)
|
||||
(SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(* ;
|
||||
"Simple case -- just do the usual PEEKBIN")
|
||||
(COND
|
||||
((AND PC (fetch (PIECE POBJ) of PC))
|
||||
(RETURN (fetch (PIECE POBJ) of PC)))
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(* ;
|
||||
"This is a 16 bit PEEKBIN. Grab two chars...")
|
||||
(RETURN (COND
|
||||
[(\EOFP STREAM)
|
||||
"Simple case -- just do the usual PEEKBIN")
|
||||
(COND
|
||||
(NOERRORFLG NIL)
|
||||
(T (\PEEKBIN STREAM]
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(SUB1 (fetch (STREAM CBUFSIZE) of STREAM)))
|
||||
((AND PC (SETQ PO (fetch (PIECE POBJ) of PC)))
|
||||
(RETURN PO))
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(* ;
|
||||
"We're sure of staying on the same page. Just grab the characters")
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(\PAGEDPEEKBIN STREAM NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR STREAM)))
|
||||
(T (SETQ PS (fetch (STREAM F1) of STREAM))
|
||||
(replace (STREAM COFFSET) of PS with (fetch
|
||||
(STREAM COFFSET)
|
||||
of STREAM))
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
|
||||
256)
|
||||
(\PAGEDPEEKBIN PS NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR PS]
|
||||
(T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
|
||||
[PC (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
"This is a 16 bit PEEKBIN. Grab two chars...")
|
||||
(RETURN (COND
|
||||
[(\EOFP STREAM)
|
||||
(COND
|
||||
(NOERRORFLG NIL)
|
||||
(T (\PEEKBIN STREAM]
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(SUB1 (fetch (STREAM CBUFSIZE) of STREAM)))
|
||||
(* ;
|
||||
"We're sure of staying on the same page. Just grab the characters")
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(\PAGEDPEEKBIN STREAM NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR STREAM)))
|
||||
(T (SETQ PS (fetch (STREAM F1) of STREAM))
|
||||
(replace (STREAM COFFSET) of PS
|
||||
with (fetch (STREAM COFFSET) of STREAM))
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
|
||||
256)
|
||||
(\PAGEDPEEKBIN PS NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR PS]
|
||||
(T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
|
||||
[PC (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
(* ; "Time for a new piece.")
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (fetch (PIECE NEXTPIECE) of PC)))
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (fetch (PIECE NEXTPIECE) of PC)))
|
||||
(* ;
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ) of STREAM)
|
||||
))
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM COFFSET) of STREAM with 0)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM
|
||||
with 0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS
|
||||
)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM)))
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM
|
||||
with NIL)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM COFFSET) of STREAM
|
||||
with 0)
|
||||
(COND
|
||||
(SUBSTREAM
|
||||
(* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM
|
||||
TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM
|
||||
with (fetch (PIECE PLEN)
|
||||
of PC))
|
||||
(freplace (STREAM CPAGE)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG)
|
||||
of STREAM with 0)
|
||||
(replace (TEXTSTREAM
|
||||
CURRENTPARALOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of
|
||||
STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(RETURN PO]
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM with 0)
|
||||
(RETURN PO]
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
(* ; "This piece lives in a string.")
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PS)
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP
|
||||
0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PS)
|
||||
|
||||
(* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
|
||||
|
||||
(\PEEKBIN STREAM NOERRORFLG))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
(\PEEKBIN STREAM NOERRORFLG))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
(* ; "This piece lives on a file.")
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PF (fetch (PIECE PFATP) of PC)
|
||||
'PEEKBIN NOERRORFLG))
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM])
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PF (fetch (PIECE PFATP)
|
||||
of PC)
|
||||
'PEEKBIN NOERRORFLG))
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM]
|
||||
(IF (IMAGEOBJP BYTE)
|
||||
THEN (OR (GETTEXTPROP (FETCH (TEXTSTREAM TEXTOBJ) OF STREAM)
|
||||
'OBJECTBYTE)
|
||||
BYTE)
|
||||
ELSE BYTE])
|
||||
|
||||
(\TEDIT.PEEKBIN.NEW.PAGE
|
||||
[LAMBDA (STREAM NOERRORFLG) (* ; "Edited 11-Jun-99 15:11 by rmk:")
|
||||
@@ -2667,25 +2721,25 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1993 1994 1995 1999 2000 2001 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2989 53114 (COPYTEXTSTREAM 2999 . 6121) (OPENTEXTSTREAM 6123 . 21000) (REOPENTEXTSTREAM
|
||||
21002 . 21424) (TEDIT.STREAMCHANGEDP 21426 . 21724) (TEXTSTREAMP 21726 . 22040) (TXTFILE 22042 .
|
||||
22487) (\DELETECH 22489 . 33745) (\SETUPGETCH 33747 . 41026) (\TEDIT.REOPEN.STREAM 41028 . 42878) (
|
||||
\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42880 . 45318) (\TEXTINIT 45320 . 51007) (\TEXTMARK 51009 . 51757) (
|
||||
\TEXTTTYBOUT 51759 . 53112)) (53115 78547 (\INSERTCH 53125 . 76851) (\INSERTCR 76853 . 78545)) (78613
|
||||
98929 (\CHTOPC 78623 . 79812) (\CHTOPCNO 79814 . 81076) (\CLEARPCTB 81078 . 81874) (
|
||||
\CREATEPIECEORSTREAM 81876 . 84850) (\DELETEPIECE 84852 . 85765) (\FINDPIECE 85767 . 86133) (
|
||||
\INSERTPIECE 86135 . 89145) (\MAKEPCTB 89147 . 91062) (\SPLITPIECE 91064 . 98023) (\INSERT.FIRST.PIECE
|
||||
98025 . 98927)) (98981 123219 (\TEXTCLOSEF 98991 . 100218) (\TEXTCLOSEF-SUBTREE 100220 . 100926) (
|
||||
\TEXTDSPFONT 100928 . 101920) (\TEXTEOFP 101922 . 103281) (\TEXTGETEOFPTR 103283 . 103493) (
|
||||
\TEXTGETFILEPTR 103495 . 105558) (\TEXTOPENF 105560 . 106390) (\TEXTOPENF-SUBTREE 106392 . 107193) (
|
||||
\TEXTOUTCHARFN 107195 . 107543) (\TEXTBACKFILEPTR 107545 . 113446) (\TEXTBOUT 113448 . 116796) (
|
||||
\TEDITOUTCCODEFN 116798 . 118064) (\TEXTSETEOF 118066 . 118575) (\TEXTSETFILEPTR 118577 . 119802) (
|
||||
\TEXTDSPXPOSITION 119804 . 120661) (\TEXTDSPYPOSITION 120663 . 121208) (\TEXTLEFTMARGIN 121210 .
|
||||
121693) (\TEXTRIGHTMARGIN 121695 . 122631) (\TEXTDSPCHARWIDTH 122633 . 122871) (\TEXTDSPSTRINGWIDTH
|
||||
122873 . 123113) (\TEXTDSPLINEFEED 123115 . 123217)) (123220 156964 (\TEXTBIN 123230 . 140016) (
|
||||
\TEDIT.TEXTBIN.STRINGSETUP 140018 . 145731) (\TEDIT.TEXTBIN.FILESETUP 145733 . 152119) (
|
||||
\TEDIT.TEXTBIN.NEW.PAGE 152121 . 156962)) (156965 170373 (\TEXTPEEKBIN 156975 . 166114) (
|
||||
\TEDIT.PEEKBIN.NEW.PAGE 166116 . 170371)) (170411 175629 (CGETTEXTPROP 170421 . 170897) (CTEXTPROP
|
||||
170899 . 173243) (GETTEXTPROP 173245 . 173840) (PUTTEXTPROP 173842 . 175167) (TEXTPROP 175169 . 175627
|
||||
(FILEMAP (NIL (2992 53117 (COPYTEXTSTREAM 3002 . 6124) (OPENTEXTSTREAM 6126 . 21003) (REOPENTEXTSTREAM
|
||||
21005 . 21427) (TEDIT.STREAMCHANGEDP 21429 . 21727) (TEXTSTREAMP 21729 . 22043) (TXTFILE 22045 .
|
||||
22490) (\DELETECH 22492 . 33748) (\SETUPGETCH 33750 . 41029) (\TEDIT.REOPEN.STREAM 41031 . 42881) (
|
||||
\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42883 . 45321) (\TEXTINIT 45323 . 51010) (\TEXTMARK 51012 . 51760) (
|
||||
\TEXTTTYBOUT 51762 . 53115)) (53118 78550 (\INSERTCH 53128 . 76854) (\INSERTCR 76856 . 78548)) (78616
|
||||
98932 (\CHTOPC 78626 . 79815) (\CHTOPCNO 79817 . 81079) (\CLEARPCTB 81081 . 81877) (
|
||||
\CREATEPIECEORSTREAM 81879 . 84853) (\DELETEPIECE 84855 . 85768) (\FINDPIECE 85770 . 86136) (
|
||||
\INSERTPIECE 86138 . 89148) (\MAKEPCTB 89150 . 91065) (\SPLITPIECE 91067 . 98026) (\INSERT.FIRST.PIECE
|
||||
98028 . 98930)) (98984 123222 (\TEXTCLOSEF 98994 . 100221) (\TEXTCLOSEF-SUBTREE 100223 . 100929) (
|
||||
\TEXTDSPFONT 100931 . 101923) (\TEXTEOFP 101925 . 103284) (\TEXTGETEOFPTR 103286 . 103496) (
|
||||
\TEXTGETFILEPTR 103498 . 105561) (\TEXTOPENF 105563 . 106393) (\TEXTOPENF-SUBTREE 106395 . 107196) (
|
||||
\TEXTOUTCHARFN 107198 . 107546) (\TEXTBACKFILEPTR 107548 . 113449) (\TEXTBOUT 113451 . 116799) (
|
||||
\TEDITOUTCCODEFN 116801 . 118067) (\TEXTSETEOF 118069 . 118578) (\TEXTSETFILEPTR 118580 . 119805) (
|
||||
\TEXTDSPXPOSITION 119807 . 120664) (\TEXTDSPYPOSITION 120666 . 121211) (\TEXTLEFTMARGIN 121213 .
|
||||
121696) (\TEXTRIGHTMARGIN 121698 . 122634) (\TEXTDSPCHARWIDTH 122636 . 122874) (\TEXTDSPSTRINGWIDTH
|
||||
122876 . 123116) (\TEXTDSPLINEFEED 123118 . 123220)) (123223 161060 (\TEXTBIN 123233 . 144112) (
|
||||
\TEDIT.TEXTBIN.STRINGSETUP 144114 . 149827) (\TEDIT.TEXTBIN.FILESETUP 149829 . 156215) (
|
||||
\TEDIT.TEXTBIN.NEW.PAGE 156217 . 161058)) (161061 176823 (\TEXTPEEKBIN 161071 . 172564) (
|
||||
\TEDIT.PEEKBIN.NEW.PAGE 172566 . 176821)) (176861 182079 (CGETTEXTPROP 176871 . 177347) (CTEXTPROP
|
||||
177349 . 179693) (GETTEXTPROP 179695 . 180290) (PUTTEXTPROP 180292 . 181617) (TEXTPROP 181619 . 182077
|
||||
)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,43 +1,76 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 5-Sep-2020 19:02:30"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;3 20197
|
||||
|
||||
changes to%: (FNS \CS.COMPARE.MASTERS)
|
||||
(FILECREATED " 3-Jan-2022 08:40:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;106 42666
|
||||
|
||||
previous date%: "19-Apr-2018 10:50:03"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;2)
|
||||
:CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN CSOBJ.COPYBUTTONEVENTINFN)
|
||||
(VARS COMPARESOURCESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "27-Dec-2021 11:56:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>COMPARESOURCES.;105)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPARESOURCESCOMS)
|
||||
|
||||
(RPAQQ COMPARESOURCESCOMS
|
||||
((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1
|
||||
\CS.FILTER.GARBAGE)
|
||||
(FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM
|
||||
\CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS
|
||||
\CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS)
|
||||
((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.EXAMINE \CS.FIXFNS
|
||||
\CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE)
|
||||
(FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM
|
||||
\CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM
|
||||
\CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM
|
||||
\CS.COMPARE.FPKGCOMS \CS.COMPARE.DEFINE-FILE-INFO)
|
||||
[COMS (FNS CSOBJ.CREATE CSOBJ.DISPLAYFN CSOBJ.IMAGEBOXFN CSOBJ.BUTTONEVENTINFN
|
||||
CSOBJ.COPYBUTTONEVENTINFN)
|
||||
(INITVARS (COMPARESOURCES-IMAGEFNS (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN
|
||||
NIL NIL NIL 'CSOBJ.BUTTONEVENTINFN
|
||||
'CSOBJ.COPYBUTTONEVENTINFN]
|
||||
(VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS)
|
||||
(COMS (FNS CSBROWSER)
|
||||
(INITVARS (COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW))
|
||||
(FILES (SYSLOAD)
|
||||
OBJECTWINDOW EXAMINEDEFS REGIONMANAGER))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE)
|
||||
(GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS))))
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARESOURCES
|
||||
[LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 19-Apr-2018 10:49 by rmk:")
|
||||
[LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM) (* ; "Edited 26-Dec-2021 21:32 by rmk")
|
||||
(* ; "Edited 20-Dec-2021 09:51 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 23:13 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 19:54 by rmk")
|
||||
(* ; "Edited 23-Nov-2021 19:46 by rmk:")
|
||||
(* ; "Edited 30-Oct-2021 20:13 by rmk:")
|
||||
(* ; "Edited 19-Apr-2018 10:49 by rmk:")
|
||||
|
||||
(* ;;; "Compare two lisp source files, reporting differences.")
|
||||
(* ;;; "Compare two lisp source files, reporting differences. LISTSTREAM if given is an open stream")
|
||||
|
||||
(DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES))
|
||||
(PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY)
|
||||
[SETQ FILEX (OR (FINDFILE FILEX T)
|
||||
(RETURN (printout LISTSTREAM FILEX " not found" T]
|
||||
[SETQ FILEY (OR (FINDFILE FILEY T)
|
||||
(RETURN (printout LISTSTREAM FILEY " not found" T]
|
||||
(PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY DATECOL
|
||||
[INSERTOBJECTS (AND EXAMINE (IF (TEXTSTREAMP LISTSTREAM)
|
||||
THEN 'TEDIT
|
||||
ELSEIF (OBJWINDOWP LISTSTREAM)
|
||||
THEN 'OBJECTWINDOW]
|
||||
(COMPARESTREAM LISTSTREAM)
|
||||
(CONTEXTSTREAM LISTSTREAM)
|
||||
OBJECTS)
|
||||
(DECLARE (SPECVARS INSERTOBJECTS OBJECTABLE))
|
||||
(CL:WHEN INSERTOBJECTS
|
||||
(SETQ COMPARESTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
|
||||
(SETQ CONTEXTSTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
|
||||
(LINELENGTH 65535 COMPARESTREAM) (* ; "Let the receiver do the wrapping")
|
||||
(LINELENGTH 65535 CONTEXTSTREAM))
|
||||
(OR (INFILEP FILEX)
|
||||
(SETQ FILEX (FINDFILE FILEX T))
|
||||
(RETURN (printout CONTEXTSTREAM FILEX " not found" T)))
|
||||
(OR (INFILEP FILEY)
|
||||
(SETQ FILEY (FINDFILE FILEY T))
|
||||
(RETURN (printout CONTEXTSTREAM FILEY " not found" T)))
|
||||
|
||||
(* ;; "Read the two files, throwing out extraneous forms & such:")
|
||||
(* ;; "Read the two files, throwing out extraneous forms & such:")
|
||||
|
||||
(CL:MULTIPLE-VALUE-SETQ (BODYX ENVX)
|
||||
(READFILE FILEX))
|
||||
@@ -45,186 +78,322 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(CL:MULTIPLE-VALUE-SETQ (BODYY ENVY)
|
||||
(READFILE FILEY))
|
||||
(SETQ BODYY (\CS.FILTER.GARBAGE BODYY))
|
||||
(printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE)
|
||||
" and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE)
|
||||
":" T T)
|
||||
[SETQ DATECOL (PLUS 2 (CONSTANT (NCHARS "Comparing"))
|
||||
(IMAX (NCHARS FILEX)
|
||||
(NCHARS FILEY]
|
||||
(printout CONTEXTSTREAM "Comparing " FILEX .TAB0 DATECOL "dated " (GETFILEINFO FILEX
|
||||
'CREATIONDATE)
|
||||
.TAB
|
||||
[SUB1 (CONSTANT (IDIFFERENCE (NCHARS "Comparing ")
|
||||
(NCHARS "and "]
|
||||
" and " FILEY .TAB0 DATECOL "dated " (GETFILEINFO FILEY 'CREATIONDATE)
|
||||
T T)
|
||||
[SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR)
|
||||
'DECLARE%:]
|
||||
'DECLARE%:]
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX))
|
||||
[SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR)
|
||||
'DECLARE%:]
|
||||
'DECLARE%:]
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY))
|
||||
(WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT))
|
||||
(\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM)
|
||||
(\CS.COMPARE.MASTERS BODYX BODYY DW? CONTEXTSTREAM COMPARESTREAM)
|
||||
|
||||
(* ;; "Done with the non-DECLARE: expressions. Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare")
|
||||
(* ;; "Done with the non-DECLARE: expressions. Nw sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare")
|
||||
|
||||
(SETQ BODYX (\CS.SORT.DECLARES DECLAREX))
|
||||
(SETQ BODYY (\CS.SORT.DECLARES DECLAREY))
|
||||
[SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y))
|
||||
unless (SASSOC (CAR Y)
|
||||
BODYX]
|
||||
(* ;
|
||||
"Add placeholders for any declaration types in Y not in X to simplify what follows")
|
||||
BODYX]
|
||||
(* ;
|
||||
"Add placeholders for any declaration types in Y not in X to simplify what follows")
|
||||
[for X in BODYX bind Y TYPE
|
||||
do (SETQ Y (SASSOC (CAR X)
|
||||
BODYY))
|
||||
(SETQ TYPE (CAR X))
|
||||
[SETQ X (LDIFFERENCE (CDR X)
|
||||
(PROG1 (CDR Y)
|
||||
(SETQ Y (LDIFFERENCE (CDR Y)
|
||||
X)))]
|
||||
(COND
|
||||
((OR X Y)
|
||||
(printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
|
||||
BODYY))
|
||||
(SETQ TYPE (CAR X))
|
||||
(SETQ X (CL:SET-DIFFERENCE (CDR X)
|
||||
(PROG1 (CDR Y)
|
||||
(SETQ Y (CL:SET-DIFFERENCE (CDR Y)
|
||||
X :TEST (FUNCTION EQUALALL))))
|
||||
:TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
((OR X Y)
|
||||
(printout CONTEXTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
|
||||
CL:SET-DIFFERENCE
|
||||
TYPE
|
||||
DEFAULT.DECLARE.TAGS
|
||||
)
|
||||
'(--]
|
||||
" forms------" T) (* ;
|
||||
"REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")
|
||||
(\CS.COMPARE.MASTERS (REVERSE X)
|
||||
(REVERSE Y)
|
||||
DW? LISTSTREAM]
|
||||
(TERPRI LISTSTREAM))
|
||||
" forms------" T) (* ;
|
||||
"REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")
|
||||
(\CS.COMPARE.MASTERS (REVERSE X)
|
||||
(REVERSE Y)
|
||||
DW? CONTEXTSTREAM COMPARESTREAM]
|
||||
(TERPRI CONTEXTSTREAM))
|
||||
(SELECTQ INSERTOBJECTS
|
||||
(OBJECTWINDOW (CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE (CL:GET-OUTPUT-STREAM-STRING
|
||||
CONTEXTSTREAM))))
|
||||
(SETQ OBJECTS (DREVERSE OBJECTS))
|
||||
(OBJ.ADDMANYTOW LISTSTREAM OBJECTS))
|
||||
(TEDIT (HELP "Don't know about TEDIT"))
|
||||
(NIL)
|
||||
(HELP))
|
||||
(RETURN (OR (REVERSE DIFFERENCES)
|
||||
'SAME])
|
||||
|
||||
(\CS.COMPARE.MASTERS
|
||||
[LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 5-Sep-2020 19:01 by rmk:")
|
||||
(* ; "Edited 15-Apr-88 14:41 by bvm")
|
||||
(LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS)
|
||||
(DECLARE (USEDFREE DIFFERENCES))
|
||||
[SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR)
|
||||
'DEFINEQ]
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX))
|
||||
(SETQ FNSX (for BOD in FNSX join (CDR BOD)))
|
||||
[SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR)
|
||||
'DEFINEQ]
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY))
|
||||
(SETQ FNSY (for BOD in FNSY join (CDR BOD)))
|
||||
[COND
|
||||
((OR FNSX FNSY)
|
||||
(printout LISTSTREAM "---Functions: " T)
|
||||
[COND
|
||||
(DW? (LET ((NOSPELLFLG T))
|
||||
(DECLARE (SPECVARS NOSPELLFLG))
|
||||
(for X in FNSX when (SETQ Y (ASSOC (CAR X)
|
||||
FNSY))
|
||||
do (* ;
|
||||
"Only bother dwimifying the ones that look different")
|
||||
(DWIMIFY (CADR X)
|
||||
T)
|
||||
(DWIMIFY (CADR Y)
|
||||
T]
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL [FUNCTION (LAMBDA (X Y STREAM)
|
||||
(COMPARELISTS
|
||||
(CADR X)
|
||||
(CADR Y)
|
||||
STREAM]
|
||||
(FUNCTION CAR)
|
||||
LISTSTREAM))
|
||||
(push DIFFERENCES (CONS 'FNS DIFS]
|
||||
[for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE)
|
||||
(SETQ DEFFERS (GET TYPE :DEFINED-BY)))
|
||||
[LAMBDA (BODYX BODYY DW?) (* ; "Edited 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:")
|
||||
(* ; "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 (\CS.FIXFNS BODYX))
|
||||
(SETQ BODYY (\CS.FIXFNS BODYY))
|
||||
(CL:WHEN (AND (SETQ XTHING (ASSOC 'DEFINE-FILE-INFO BODYX))
|
||||
(SETQ YTHING (ASSOC 'DEFINE-FILE-INFO BODYY))
|
||||
(\CS.COMPARE.DEFINE-FILE-INFO XTHING YTHING))
|
||||
(SETQ BODYX (REMOVE XTHING BODYX))
|
||||
(SETQ BODYY (REMOVE YTHING BODYY)))
|
||||
|
||||
(* ;; "These are for commonlispy definers")
|
||||
|
||||
[for TYPE DEFFERS in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE)
|
||||
(SETQ DEFFERS (GET TYPE :DEFINED-BY)))
|
||||
do
|
||||
(* ;; "handle definer based things")
|
||||
|
||||
(* ;; "handle definer based things")
|
||||
(for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
(SETQ YTHING (for X in BODYY collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
|
||||
(for DEFFER in DEFFERS
|
||||
do (SETQ XTHING (for X in BODYX collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
(SETQ YTHING (for X in BODYY collect X
|
||||
when (EQ (CAR X)
|
||||
DEFFER)))
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING))
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING
|
||||
(CONCAT (OR (CL:DOCUMENTATION TYPE 'DEFINE-TYPES)
|
||||
TYPE)
|
||||
" defined by " DEFFER)
|
||||
NIL
|
||||
(GET DEFFER :DEFINITION-NAME)
|
||||
LISTSTREAM))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
[for TYPE in COMPARESOURCETYPES
|
||||
do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE))
|
||||
(SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X)))
|
||||
(SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X)))
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING))
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING
|
||||
(OR (fetch (CSTYPE TITLE) of TYPE)
|
||||
(L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE)
|
||||
of TYPE))
|
||||
T))
|
||||
(fetch (CSTYPE COMPAREFN) of TYPE)
|
||||
(OR (fetch (CSTYPE IDFN) of TYPE)
|
||||
(FUNCTION CADR))
|
||||
LISTSTREAM))
|
||||
(SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
[SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX
|
||||
(SETQ BODYX (LDIFFERENCE BODYX BODYY)))]
|
||||
(* ;; "Take out all of the THINGS we are about to do. ")
|
||||
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
((SETQ DIFS (\CS.COMPARE.TYPES
|
||||
XTHING YTHING
|
||||
(CONCAT (OR (CL:DOCUMENTATION TYPE
|
||||
'DEFINE-TYPES)
|
||||
TYPE)
|
||||
" defined by " DEFFER)
|
||||
NIL
|
||||
(GET DEFFER :DEFINITION-NAME)))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
|
||||
(* ;; "These are for other filepkage types, as registered in COMPARESOURCETYPES")
|
||||
|
||||
[for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE))
|
||||
(SETQ XTHING (for X in BODYX collect X
|
||||
when (CL:FUNCALL PRED X)))
|
||||
(SETQ YTHING (for X in BODYY collect X
|
||||
when (CL:FUNCALL PRED X)))
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
([SETQ DIFS (\CS.COMPARE.TYPES
|
||||
XTHING YTHING
|
||||
(OR (fetch (CSTYPE TITLE) of TYPE)
|
||||
(MKSTRING (fetch (CSTYPE FPKGTYPE)
|
||||
of TYPE)))
|
||||
(fetch (CSTYPE COMPAREFN) of TYPE)
|
||||
(OR (fetch (CSTYPE IDFN) of TYPE)
|
||||
(FUNCTION CADR]
|
||||
(SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE))
|
||||
(COND
|
||||
((SETQ TMP (ASSOC TYPE DIFFERENCES))
|
||||
(NCONC TMP DIFS))
|
||||
(T (push DIFFERENCES (CONS TYPE DIFS]
|
||||
(SETQ BODYY (CL:SET-DIFFERENCE BODYY (PROG1 BODYX
|
||||
(SETQ BODYX (CL:SET-DIFFERENCE
|
||||
BODYX BODYY :TEST
|
||||
(FUNCTION EQUALALL))))
|
||||
:TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(COND
|
||||
((OR BODYX BODYY)
|
||||
(printout LISTSTREAM T "---Expressions:" T)
|
||||
(printout CONTEXTSTREAM T "---Expressions:" T)
|
||||
(LET ((COMMENTX 0)
|
||||
(COMMENTY 0)
|
||||
EXTRAS) (* ; "Remove comments")
|
||||
[SETQ BODYX (for X in BODYX collect X
|
||||
unless (COND
|
||||
((EQ (CAR X)
|
||||
COMMENTFLG)
|
||||
(add COMMENTX 1)
|
||||
T]
|
||||
[SETQ BODYY (for Y in BODYY collect Y
|
||||
unless (COND
|
||||
((EQ (CAR Y)
|
||||
COMMENTFLG)
|
||||
(add COMMENTY 1)
|
||||
T]
|
||||
(COMMENTY 0)) (* ; "Remove comments")
|
||||
[SETQ BODYX (for X in BODYX collect X unless (COND
|
||||
((EQ (CAR X)
|
||||
COMMENTFLG)
|
||||
(add COMMENTX 1)
|
||||
T]
|
||||
[SETQ BODYY (for Y in BODYY collect Y unless (COND
|
||||
((EQ (CAR Y)
|
||||
COMMENTFLG)
|
||||
(add COMMENTY 1)
|
||||
T]
|
||||
(COND
|
||||
((OR (NEQ COMMENTX 0)
|
||||
(NEQ COMMENTY 0))
|
||||
(printout LISTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments." T T
|
||||
)))
|
||||
(printout CONTEXTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments."
|
||||
T T)))
|
||||
[COND
|
||||
((SETQ EXTRAS (COND
|
||||
(BODYX (COND
|
||||
(BODYY (COMPARELISTS BODYX BODYY LISTSTREAM)
|
||||
NIL)
|
||||
(T (printout LISTSTREAM "These are not on " FILEY)
|
||||
BODYX)))
|
||||
(BODYY (printout LISTSTREAM "These are not on " FILEX)
|
||||
BODYY)))
|
||||
(printout LISTSTREAM ":" T)
|
||||
(for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3]
|
||||
[COND
|
||||
((AND (OR BODYX BODYY)
|
||||
(OR (EQ EXAMINE T)
|
||||
(EQMEMB 'MISC EXAMINE)))
|
||||
(IF (EQMEMB 2WINDOWS EXAMINE)
|
||||
THEN (EDITE BODYX)
|
||||
(EDITE BODYY)
|
||||
ELSE (EDITE (LIST BODYX BODYY]
|
||||
[BODYX (COND
|
||||
(BODYY (COMPARELISTS BODYX BODYY COMPARESTREAM)
|
||||
(\CS.EXAMINE BODYX BODYY))
|
||||
(T (printout COMPARESTREAM "These are not on File 2:" T)
|
||||
(FOR X IN BODYX DO (LVLPRINT X COMPARESTREAM 2 3)
|
||||
(\CS.EXAMINE X NIL T]
|
||||
(BODYY (printout COMPARESTREAM "These are not on File 1:" T)
|
||||
(FOR Y IN BODYY DO (LVLPRINT Y COMPARESTREAM 2 3)
|
||||
(\CS.EXAMINE NIL Y T]
|
||||
(OR (ASSOC 'Other DIFFERENCES)
|
||||
(push DIFFERENCES (LIST 'Other '--])
|
||||
|
||||
(\CS.COMPARE.TYPES
|
||||
(LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN. Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT))))
|
||||
)
|
||||
[LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN) (* ; "Edited 9-Dec-2021 23:19 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 23:25 by rmk:")
|
||||
(* ; "Edited 30-Nov-2021 23:07 by rmk:")
|
||||
(* ; "Edited 27-Nov-2021 12:32 by rmk:")
|
||||
(* ; "Edited 25-Nov-2021 13:29 by rmk:")
|
||||
(* ; "Edited 29-Dec-86 11:49 by jds")
|
||||
|
||||
(* ;;; "Compare things using COMPAREFN. Deltas -> COMPARESTREAM. Anything that passes the WHEN predicate has a difference somewhere, will produce some output. ")
|
||||
|
||||
(DECLARE (USEDFREE CONTEXTSTREAM COMPARESTREAM))
|
||||
(LET (X Y RESULT NAME)
|
||||
(CL:WHEN (AND (OR XTHING YTHING)
|
||||
(PROGN (SETQ XTHING (CL:SET-DIFFERENCE XTHING
|
||||
(PROG1 YTHING
|
||||
(SETQ YTHING (CL:SET-DIFFERENCE
|
||||
YTHING XTHING :TEST
|
||||
(FUNCTION EQUALALL))))
|
||||
:TEST
|
||||
(FUNCTION EQUALALL)))
|
||||
(OR XTHING YTHING)))
|
||||
DF
|
||||
|
||||
(* ;; "We know we are going to have some output. Strings can go directly onto theCONTEXTSTREAM, and objects may then be inserted.")
|
||||
|
||||
(AND TITLE (printout CONTEXTSTREAM T "---" TITLE ":" T T))
|
||||
(for TAIL on XTHING
|
||||
do [SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL]
|
||||
[COND
|
||||
([NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y)
|
||||
NAME]
|
||||
(printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT
|
||||
" is not on File 2" T T)
|
||||
(\CS.EXAMINE X NIL T NAME))
|
||||
(T (printout COMPARESTREAM .FONT BOLDFONT .P2 NAME ":" .FONT DEFAULTFONT T)
|
||||
(COND
|
||||
(COMPAREFN (CL:FUNCALL COMPAREFN X Y COMPARESTREAM))
|
||||
(T (COMPARELISTS X Y COMPARESTREAM)))
|
||||
(\CS.EXAMINE X Y NIL NAME)
|
||||
(RPLACA (FMEMB Y YTHING]
|
||||
(RPLACA TAIL)
|
||||
(push RESULT NAME))
|
||||
(for Y in (CL:SET-DIFFERENCE YTHING XTHING :TEST (FUNCTION EQUALALL))
|
||||
do (SETQ NAME (CL:FUNCALL IDFN Y))
|
||||
(printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT
|
||||
" is not on File 1" T T)
|
||||
(\CS.EXAMINE Y NIL T NAME)
|
||||
(push RESULT NAME))
|
||||
RESULT)])
|
||||
|
||||
(\CS.EXAMINE
|
||||
[LAMBDA (X Y ONLYONE NAME TYPE) (* ; "Edited 24-Dec-2021 22:48 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 22:46 by rmk")
|
||||
(* ; "Edited 9-Dec-2021 23:23 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 16:43 by rmk")
|
||||
(* ; "Edited 2-Dec-2021 15:23 by rmk:")
|
||||
(* ; "Edited 29-Nov-2021 20:37 by rmk:")
|
||||
(* ; "Edited 27-Nov-2021 11:21 by rmk:")
|
||||
(DECLARE (USEDFREE EXAMINE INSERTOBJECTS COMPARESTREAM CONTEXTSTREAM OBJECTS))
|
||||
|
||||
(* ;; "ONLYONE as a flag, because we don't want to test X or Y for NIL, that could be the contrasting value.")
|
||||
|
||||
(* ;; "I don't understand MISC: changed but otherwise unclassified. Does that mean just an unknown type?")
|
||||
|
||||
(* ;; "The only call seemed to be from \CS.COMPARE.MASTERS, where EXTRAS is set to either BODYX or BODYY if the other one is NIL. It may be that that call only happens in the MISC case.")
|
||||
|
||||
(CL:UNLESS NAME (SETQ NAME "from File"))
|
||||
|
||||
(* ;; "Context gets printed to the CONTEXTSTREAM, diffs go to the COMPARESTREAM. If we aren't doing objects, those are the same streams, and the output gets printed in the right order. Nothing to do here.")
|
||||
|
||||
(IF INSERTOBJECTS
|
||||
THEN (SELECTQ INSERTOBJECTS
|
||||
(OBJECTWINDOW [LET (STRING)
|
||||
|
||||
(* ;; "Take out last EOL, let SEPDIST space things out.")
|
||||
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING CONTEXTSTREAM))
|
||||
(CL:WHEN (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING)))
|
||||
(CL:UNLESS (EQ 0 (GETFILEPTR COMPARESTREAM))
|
||||
(SETQ STRING (CL:GET-OUTPUT-STREAM-STRING COMPARESTREAM))
|
||||
|
||||
(* ;; "Don't know why, but SEPTDIST doesn't work if there if there isn't at least one EOL. Magically, this gets the right appearance and behavior.")
|
||||
|
||||
(CL:WHEN (AND (EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -1))
|
||||
(EQ (CHARCODE EOL)
|
||||
(NTHCHARCODE STRING -2)))
|
||||
(SETQ STRING (OR (SUBSTRING STRING 1 -2)
|
||||
"")))
|
||||
(PUSH OBJECTS (CSOBJ.CREATE STRING
|
||||
(LIST NAME TYPE X Y LABEL1 LABEL2)
|
||||
ONLYONE)))])
|
||||
(TEDIT (HELP "TEDIT NOT IMPLEMENTED"))
|
||||
NIL)
|
||||
ELSEIF (OR (LISTP X)
|
||||
(LISTP Y))
|
||||
THEN (* ;
|
||||
"No point in bringing up an editor on a non-list")
|
||||
(IF ONLYONE
|
||||
THEN (IF (OR (EQMEMB T EXAMINE)
|
||||
(EQMEMB 'NEW EXAMINE))
|
||||
THEN (EDITE (OR X Y)))
|
||||
ELSEIF (OR (EQMEMB T EXAMINE)
|
||||
(EQMEMB 'OLD EXAMINE)
|
||||
(EQMEMB 'MISCC))
|
||||
THEN (IF (EQMEMB '2WINDOWS EXAMINE)
|
||||
THEN (EXAMINEDEFS X Y NAME TYPE)
|
||||
ELSE (EDITE (LIST X Y])
|
||||
|
||||
(\CS.FIXFNS
|
||||
[LAMBDA (BODY DW?) (* ; "Edited 29-Nov-2021 20:42 by rmk:")
|
||||
(* ; "Edited 26-Nov-2021 13:34 by rmk:")
|
||||
|
||||
(* ;; "RMK: Functions are special in that they are grouped under DEFINEQ and they may need dwimifying. We don't want to deal with these idiosyncracies below, so our strategy is to split each multi-fn defineq into a sequence of single-fn defineqs , one for each function, then let it fall through. After dwimifying, things should be standard.")
|
||||
|
||||
(LET (DEFINEQS FNS (NOSPELLFLG T))
|
||||
(DECLARE (SPECVARS NOSPELLFLG))
|
||||
[SETQ DEFINEQS (for EXPR in BODY collect EXPR when (EQ (CAR EXPR)
|
||||
'DEFINEQ]
|
||||
(SETQ BODY (CL:SET-DIFFERENCE BODY DEFINEQS)) (* ;
|
||||
"Remove all the multiple function defineqs, so we can pack on the exploded forms")
|
||||
[SETQ FNS (for DFQ in DEFINEQS join (FOR FN IN (CDR DFQ)
|
||||
COLLECT
|
||||
|
||||
(* ;; "FN is a single (NAME DEF) pair")
|
||||
|
||||
`(DEFINEQ (,@FN]
|
||||
(CL:WHEN DW?
|
||||
(FOR FN IN FNS DO (DWIMIFY (CADADR FN)
|
||||
T)))
|
||||
(SETQ BODY (APPEND FNS BODY])
|
||||
|
||||
(\CS.SORT.DECLARES
|
||||
(LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT))
|
||||
@@ -240,6 +409,24 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\CS.ISFNFORM
|
||||
[LAMBDA (X) (* ; "Edited 29-Nov-2021 20:34 by rmk:")
|
||||
(* ; "Edited 26-Nov-2021 13:19 by rmk:")
|
||||
(EQ 'DEFINEQ (CAR (LISTP X])
|
||||
|
||||
(\CS.COMPARE.FNS
|
||||
[LAMBDA (DQX DQY STREAM) (* ; "Edited 29-Nov-2021 20:51 by rmk:")
|
||||
|
||||
(* ;; "CADADR is the body")
|
||||
|
||||
(COMPARELISTS (CADADR DQX)
|
||||
(CADADR DQY)
|
||||
STREAM])
|
||||
|
||||
(\CS.FNSID
|
||||
[LAMBDA (DQX) (* ; "Edited 29-Nov-2021 20:50 by rmk:")
|
||||
(CAR (CADR DQX])
|
||||
|
||||
(\CS.ISVARFORM
|
||||
(LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL)))
|
||||
|
||||
@@ -290,10 +477,142 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(\CS.COMPARE.FPKGCOMS
|
||||
(LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM))
|
||||
)
|
||||
|
||||
(\CS.COMPARE.DEFINE-FILE-INFO
|
||||
[LAMBDA (DFI1 DFI2) (* ; "Edited 19-Dec-2021 21:02 by rmk")
|
||||
(AND (EQUAL (LISTGET :READTABLE DFI1)
|
||||
(LISTGET :READTABLE DFI2))
|
||||
(EQUAL (LISTGET :PACKAGE DFI1)
|
||||
(LISTGET :PACKAGE DFI2))
|
||||
(EQ (OR (LISTGET :BASE DFI1)
|
||||
10)
|
||||
(OR (LISTGET :BASE DFI2)
|
||||
10))
|
||||
(EQ (OR (LISTGET :FORMAT DFI1)
|
||||
*DEFAULT-EXTERNALFORMAT*)
|
||||
(OR (LISTGET :FORMAT DFI2)
|
||||
*DEFAULT-EXTERNALFORMAT*])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CSOBJ.CREATE
|
||||
[LAMBDA (STRING COMPAREDATA ONLYONE) (* ; "Edited 4-Dec-2021 09:57 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 13:26 by rmk:")
|
||||
(LET ((OBJ (IMAGEOBJCREATE STRING COMPARESOURCES-IMAGEFNS)))
|
||||
(IMAGEOBJPROP OBJ 'COMPAREDATA COMPAREDATA)
|
||||
(IMAGEOBJPROP OBJ 'ONLYONE ONLYONE)
|
||||
OBJ])
|
||||
|
||||
(CSOBJ.DISPLAYFN
|
||||
[LAMBDA (OBJ WINDOW) (* ; "Edited 4-Dec-2021 08:24 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 14:18 by rmk:")
|
||||
(DSPFONT DEFAULTFONT WINDOW)
|
||||
(FOR I C (FONTARRAY _ (FONTMAPARRAY))
|
||||
(STRING _ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) FROM 1
|
||||
DO (SELCHARQ (SETQ C (NTHCHARCODE STRING I))
|
||||
(EOL (TERPRI WINDOW))
|
||||
(NIL (RETURN))
|
||||
(IF (EQ C (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
|
||||
THEN (DSPFONT (ELT FONTARRAY (NTHCHARCODE STRING (ADD I 1)))
|
||||
WINDOW)
|
||||
ELSE (PRINTCCODE C WINDOW])
|
||||
|
||||
(CSOBJ.IMAGEBOXFN
|
||||
[LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 9-Dec-2021 23:02 by rmk")
|
||||
(* ; "Edited 7-Dec-2021 10:50 by rmk")
|
||||
(* ; "Edited 5-Dec-2021 23:52 by rmk")
|
||||
(* ; "Edited 4-Dec-2021 08:24 by rmk")
|
||||
(* ; "Edited 1-Dec-2021 13:27 by rmk:")
|
||||
|
||||
(* ;; "Calculate the height of each line, and the width of the widest line.")
|
||||
|
||||
(* ;;
|
||||
"Probably ought to compute the max height per line, at every font change, add it at each EOL.")
|
||||
|
||||
(SETQ IMAGESTREAM (GETSTREAM IMAGESTREAM 'OUTPUT))
|
||||
(FOR I C (STRING _ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
|
||||
(FONT _ (FONTCREATE DEFAULTFONT NIL NIL NIL IMAGESTREAM))
|
||||
(HEIGHT _ 0)
|
||||
(LINELENGTH _ 0)
|
||||
(MAXLINELENGTH _ 0)
|
||||
(FONTARRAY _ (FONTMAPARRAY)) FROM 1
|
||||
DO (SELCHARQ (SETQ C (NTHCHARCODE STRING I))
|
||||
(EOL (ADD HEIGHT (FONTPROP FONT 'HEIGHT))
|
||||
(CL:WHEN (IGREATERP LINELENGTH MAXLINELENGTH)
|
||||
(SETQ MAXLINELENGTH LINELENGTH))
|
||||
(SETQ LINELENGTH 0))
|
||||
(NIL (* ; "end of string")
|
||||
(CL:WHEN (IGREATERP LINELENGTH MAXLINELENGTH)
|
||||
(SETQ MAXLINELENGTH LINELENGTH))
|
||||
(RETURN (CREATE IMAGEBOX
|
||||
XSIZE _ MAXLINELENGTH
|
||||
YSIZE _ HEIGHT
|
||||
YDESC _ (DIFFERENCE HEIGHT (FONTPROP FONT 'HEIGHT))
|
||||
XKERN _ 0)))
|
||||
(IF (EQ C (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
|
||||
THEN (SETQ FONT (FONTCREATE (ELT FONTARRAY (NTHCHARCODE STRING (ADD I 1)))
|
||||
NIL NIL NIL IMAGESTREAM))
|
||||
ELSE (ADD LINELENGTH (CHARWIDTH C FONT])
|
||||
|
||||
(CSOBJ.BUTTONEVENTINFN
|
||||
[LAMBDA (OBJ WINDOW) (* ; "Edited 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")
|
||||
(LET
|
||||
[(COMPAREDATA (IMAGEOBJPROP OBJ 'COMPAREDATA]
|
||||
(CL:WHEN (AND COMPAREDATA (MOUSESTATE LEFT)
|
||||
(UNTILMOUSESTATE (NOT LEFT)))
|
||||
[LET ((NAME (POP COMPAREDATA))
|
||||
(TYPE (POP COMPAREDATA))
|
||||
(DEF1 (POP COMPAREDATA))
|
||||
(DEF2 (POP COMPAREDATA))
|
||||
(TITLE1 (POP COMPAREDATA))
|
||||
(TITLE2 (CAR COMPAREDATA)))
|
||||
|
||||
(* ;; "Move the cursor to just slightly below the current object, so that the edit windows are well aligned. We have to figure out the bottom of the current object, in screen coordinates.")
|
||||
|
||||
[LET ((OBJREGION (OBJ.FIND.REGION WINDOW OBJ)))
|
||||
(\CURSORPOSITION (IPLUS 20 LASTMOUSEX)
|
||||
(IPLUS (IDIFFERENCE (FETCH (REGION BOTTOM) OF (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])])
|
||||
|
||||
(CSOBJ.COPYBUTTONEVENTINFN
|
||||
[LAMBDA (OBJ WINDOW REGION) (* ; "Edited 3-Jan-2022 08:36 by rmk")
|
||||
(CL:WHEN (CAR (IMAGEOBJPROP OBJ 'COMPAREDATA))
|
||||
[COPYINSERT (CAR (IMAGEOBJPROP OBJ 'COMPAREDATA])])
|
||||
)
|
||||
|
||||
(RPAQ? COMPARESOURCES-IMAGEFNS (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN NIL NIL NIL
|
||||
'CSOBJ.BUTTONEVENTINFN
|
||||
'CSOBJ.COPYBUTTONEVENTINFN))
|
||||
|
||||
(RPAQQ COMPARESOURCETYPES
|
||||
((VARS \CS.ISVARFORM \CS.COMPARE.VARS)
|
||||
((FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID "FNS defined by DEFINEQ")
|
||||
(VARS \CS.ISVARFORM \CS.COMPARE.VARS)
|
||||
(MACROS \CS.ISMACROFORM)
|
||||
(RECORDS \CS.ISRECFORM)
|
||||
(PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties")
|
||||
@@ -303,6 +622,60 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR)))
|
||||
|
||||
(RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST))
|
||||
(DEFINEQ
|
||||
|
||||
(CSBROWSER
|
||||
[LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION) (* ; "Edited 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")
|
||||
|
||||
(* ;; "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.")
|
||||
|
||||
(* ;; "Don't use the INFILEP value, because that might screw with capitalization that the caller prefers. If the file can be found that way, then lower functions will find it.")
|
||||
|
||||
(DECLARE (SPECVARS LABEL1 LABEL2))
|
||||
(OR (INFILEP FILEX)
|
||||
(SETQ FILEX (FINDFILE FILEX NIL DIRECTORIES))
|
||||
(ERROR "FILE NOT FOUND" FILEX))
|
||||
(OR (INFILEP FILEY)
|
||||
(SETQ FILEY (FINDFILE FILEY NIL DIRECTORIES))
|
||||
(ERROR "FILE NOT FOUND" FILEY))
|
||||
(CL:UNLESS (LISPSOURCEFILEP FILEX)
|
||||
(ERROR FILEX " is not a Medley source file"))
|
||||
(CL:UNLESS (LISPSOURCEFILEP FILEY)
|
||||
(ERROR FILEX " is not a Medley source file"))
|
||||
(LET [(TITLE (CONCAT "COMPARESOURCES of " (OR LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL
|
||||
'BODY FILEX))
|
||||
" and "
|
||||
(OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY]
|
||||
(SELECTQ COMPARESOURCES-BROWSER-TYPE
|
||||
(OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL NIL 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)))
|
||||
(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))))])
|
||||
(HELP])
|
||||
)
|
||||
|
||||
(RPAQ? COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW)
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
OBJECTWINDOW EXAMINEDEFS REGIONMANAGER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -314,14 +687,18 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation. All righ
|
||||
(GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)
|
||||
)
|
||||
)
|
||||
(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020))
|
||||
(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1166 16557 (COMPARESOURCES 1176 . 5134) (\CS.COMPARE.MASTERS 5136 . 13057) (
|
||||
\CS.COMPARE.TYPES 13059 . 14308) (\CS.SORT.DECLARES 14310 . 14653) (\CS.SORT.DECLARE1 14655 . 16075) (
|
||||
\CS.FILTER.GARBAGE 16077 . 16555)) (16558 19286 (\CS.ISVARFORM 16568 . 16673) (\CS.COMPARE.VARS 16675
|
||||
. 17337) (\CS.ISMACROFORM 17339 . 17477) (\CS.ISRECFORM 17479 . 17572) (\CS.ISCOURIERFORM 17574 .
|
||||
17674) (\CS.ISTEMPLATEFORM 17676 . 17774) (\CS.COMPARE.TEMPLATES 17776 . 18141) (\CS.ISPROPFORM 18143
|
||||
. 18298) (\CS.PROP.NAME 18300 . 18445) (\CS.COMPARE.PROPS 18447 . 18604) (\CS.ISADDVARFORM 18606 .
|
||||
18699) (\CS.COMPARE.ADDVARS 18701 . 18866) (\CS.ISFPKGCOMFORM 18868 . 19075) (\CS.COMPARE.FPKGCOMS
|
||||
19077 . 19284)))))
|
||||
(FILEMAP (NIL (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)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -1,15 +1,16 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "14-Feb-2021 23:11:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;5 64800
|
||||
|
||||
changes to%: (VARS DINFOCOMS)
|
||||
(FILECREATED "25-Oct-2021 23:24:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;2 65213
|
||||
|
||||
previous date%: "14-Feb-2021 14:55:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;4)
|
||||
changes to%: (FNS DINFO.CREATE.FMENU)
|
||||
|
||||
previous date%: "14-Feb-2021 23:11:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
Copyright (c) 1985-1987, 2020-2021 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DINFOCOMS)
|
||||
@@ -19,24 +20,24 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DINFOGRAPH DINFONODE)
|
||||
(FUNCTIONS DINFOGRAPHPROP))
|
||||
(INITRECORDS DINFOGRAPH)
|
||||
(FNS (* ; "Primary functions")
|
||||
(FNS (* ; "Primary functions")
|
||||
DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH
|
||||
DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP)
|
||||
(FNS (* ; "Koto compatability")
|
||||
(FNS (* ; "Koto compatability")
|
||||
DINFO.READ.KOTO.GRAPH)
|
||||
(FNS (* ; "Window functions")
|
||||
(FNS (* ; "Window functions")
|
||||
DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN)
|
||||
(FNS (* ; "FreeMenu functions")
|
||||
(FNS (* ; "FreeMenu functions")
|
||||
DINFO.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER
|
||||
DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY
|
||||
DINFO.TOGGLE.TEXT)
|
||||
(FNS (* ; "Other menu functions")
|
||||
(FNS (* ; "Other menu functions")
|
||||
DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY
|
||||
DINFO.HISTORIC.UPDATE)
|
||||
(FNS (* ; "Interface to GRAPHER")
|
||||
(FNS (* ; "Interface to GRAPHER")
|
||||
DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW
|
||||
DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH)
|
||||
(FNS (* ; "Interface to TEdit")
|
||||
(FNS (* ; "Interface to TEdit")
|
||||
DINFO.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL
|
||||
DINFO.GET.FILENAME)
|
||||
(ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH)
|
||||
@@ -539,14 +540,17 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
(DINFO.UPDATE.FMENU GRAPH])
|
||||
|
||||
(DINFO.CREATE.FMENU
|
||||
[LAMBDA (GRAPH) (* jow "15-Jul-86 17:39")
|
||||
|
||||
(* * Makes a DInfo FreeMenu for GRAPH)
|
||||
[LAMBDA (GRAPH) (* ; "Edited 25-Oct-2021 23:23 by rmk:")
|
||||
(* jow "15-Jul-86 17:39")
|
||||
|
||||
(* ;;; "Makes a DInfo FreeMenu for GRAPH")
|
||||
|
||||
(* ;; "RMK: Added MINSIZE and MAXSIZE so that the menu doesn't get distorted during reshaping")
|
||||
|
||||
(LET* [(ADD.ITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH))
|
||||
(FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH))
|
||||
MENUFONT))
|
||||
(FM (FREEMENU `((PROPS FONT %, FONT)
|
||||
[FM (FREEMENU `((PROPS FONT %, FONT)
|
||||
((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10))
|
||||
(ID NODE LABEL "" TYPE DISPLAY))
|
||||
((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD)
|
||||
@@ -585,8 +589,12 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
(HELVETICA 10 BOLD)
|
||||
MESSAGE
|
||||
"Lookup a term in this graph. LEFT for new term, MIDDLE to repeat last."
|
||||
)) ADD.ITEMS]
|
||||
))
|
||||
ADD.ITEMS]
|
||||
(HEIGHT (FETCH (REGION HEIGHT) OF (WINDOWPROP FM 'REGION]
|
||||
(WINDOWPROP FM 'FM.DONTRESHAPE T)
|
||||
(WINDOWPROP FM 'MINSIZE (CONS 0 HEIGHT))
|
||||
(WINDOWPROP FM 'MAXSIZE (CONS 64000 HEIGHT))
|
||||
FM])
|
||||
|
||||
(DINFO.FMW.CLOSEFN
|
||||
@@ -1110,20 +1118,20 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7732 24558 (DINFO 7742 . 9356) (DINFO.UPDATE 9358 . 12222) (DINFOGRAPH 12224 . 12642) (
|
||||
DINFO.SPECIAL.UPDATE 12644 . 14342) (DINFO.READ.GRAPH 14344 . 16199) (DINFO.WRITE.GRAPH 16201 . 17291)
|
||||
(DINFO.SELECT.GRAPH 17293 . 18200) (DINFO.DEFAULT.MENU 18202 . 20726) (DINFO.FIND 20728 . 23112) (
|
||||
DINFO.LOOKUP 23114 . 24556)) (24559 27253 (DINFO.READ.KOTO.GRAPH 24569 . 27251)) (27254 29568 (
|
||||
DINFO.SETUP.WINDOW 27264 . 27945) (DINFO.CLOSEFN 27947 . 28380) (DINFO.SHRINKFN 28382 . 28578) (
|
||||
DINFO.EXPANDFN 28580 . 29137) (DINFO.ICONFN 29139 . 29566)) (29569 40417 (DINFO.ADD.FMENU 29579 .
|
||||
30674) (DINFO.CREATE.FMENU 30676 . 34213) (DINFO.FMW.CLOSEFN 34215 . 35060) (DINFO.FMENU.HANDLER 35062
|
||||
. 35701) (DINFO.UPDATE.FMENU 35703 . 37908) (DINFO.TOGGLE.MENU 37910 . 38500) (DINFO.TOGGLE.GRAPH
|
||||
38502 . 39001) (DINFO.TOGGLE.HISTORY 39003 . 39547) (DINFO.TOGGLE.TEXT 39549 . 40415)) (40418 48116 (
|
||||
DINFO.UPDATE.MENU.DISPLAY 40428 . 44448) (DINFO.UPDATE.FROM.MENU 44450 . 44749) (DINFO.UPDATE.HISTORY
|
||||
44751 . 47285) (DINFO.HISTORIC.UPDATE 47287 . 48114)) (48117 58283 (DINFO.UPDATE.GRAPH.DISPLAY 48127
|
||||
. 49445) (DINFO.UPDATE.FROM.GRAPH 49447 . 49890) (DINFO.GET.GRAPH.WINDOW 49892 . 50477) (
|
||||
DINFO.CREATE.GRAPH.WINDOW 50479 . 51596) (DINFO.SHOWGRAPH 51598 . 53323) (DINFO.INVERT.NODE 53325 .
|
||||
54713) (DINFO.LAYOUTGRAPH 54715 . 58281)) (58284 64140 (DINFO.UPDATE.TEXT.DISPLAY 58294 . 60155) (
|
||||
DINFO.TITLEMENUFN 60157 . 61282) (DINFO.OPENTEXTSTREAM 61284 . 62500) (DINFO.SHOWSEL 62502 . 63235) (
|
||||
DINFO.GET.FILENAME 63237 . 64138)))))
|
||||
(FILEMAP (NIL (7733 24559 (DINFO 7743 . 9357) (DINFO.UPDATE 9359 . 12223) (DINFOGRAPH 12225 . 12643) (
|
||||
DINFO.SPECIAL.UPDATE 12645 . 14343) (DINFO.READ.GRAPH 14345 . 16200) (DINFO.WRITE.GRAPH 16202 . 17292)
|
||||
(DINFO.SELECT.GRAPH 17294 . 18201) (DINFO.DEFAULT.MENU 18203 . 20727) (DINFO.FIND 20729 . 23113) (
|
||||
DINFO.LOOKUP 23115 . 24557)) (24560 27254 (DINFO.READ.KOTO.GRAPH 24570 . 27252)) (27255 29569 (
|
||||
DINFO.SETUP.WINDOW 27265 . 27946) (DINFO.CLOSEFN 27948 . 28381) (DINFO.SHRINKFN 28383 . 28579) (
|
||||
DINFO.EXPANDFN 28581 . 29138) (DINFO.ICONFN 29140 . 29567)) (29570 40830 (DINFO.ADD.FMENU 29580 .
|
||||
30675) (DINFO.CREATE.FMENU 30677 . 34626) (DINFO.FMW.CLOSEFN 34628 . 35473) (DINFO.FMENU.HANDLER 35475
|
||||
. 36114) (DINFO.UPDATE.FMENU 36116 . 38321) (DINFO.TOGGLE.MENU 38323 . 38913) (DINFO.TOGGLE.GRAPH
|
||||
38915 . 39414) (DINFO.TOGGLE.HISTORY 39416 . 39960) (DINFO.TOGGLE.TEXT 39962 . 40828)) (40831 48529 (
|
||||
DINFO.UPDATE.MENU.DISPLAY 40841 . 44861) (DINFO.UPDATE.FROM.MENU 44863 . 45162) (DINFO.UPDATE.HISTORY
|
||||
45164 . 47698) (DINFO.HISTORIC.UPDATE 47700 . 48527)) (48530 58696 (DINFO.UPDATE.GRAPH.DISPLAY 48540
|
||||
. 49858) (DINFO.UPDATE.FROM.GRAPH 49860 . 50303) (DINFO.GET.GRAPH.WINDOW 50305 . 50890) (
|
||||
DINFO.CREATE.GRAPH.WINDOW 50892 . 52009) (DINFO.SHOWGRAPH 52011 . 53736) (DINFO.INVERT.NODE 53738 .
|
||||
55126) (DINFO.LAYOUTGRAPH 55128 . 58694)) (58697 64553 (DINFO.UPDATE.TEXT.DISPLAY 58707 . 60568) (
|
||||
DINFO.TITLEMENUFN 60570 . 61695) (DINFO.OPENTEXTSTREAM 61697 . 62913) (DINFO.SHOWSEL 62915 . 63648) (
|
||||
DINFO.GET.FILENAME 63650 . 64551)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
132
lispusers/EXAMINEDEFS
Normal file
132
lispusers/EXAMINEDEFS
Normal file
@@ -0,0 +1,132 @@
|
||||
(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
|
||||
|
||||
:CHANGES-TO (FNS EXAMINEFILES)
|
||||
|
||||
:PREVIOUS-DATE "30-Dec-2021 21:49:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;18)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
|
||||
|
||||
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEFILES)
|
||||
(INITVARS (EXAMINEDEFS-PROCESS-LIST))))
|
||||
(DEFINEQ
|
||||
|
||||
(EXAMINEDEFS
|
||||
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "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.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Examination is in side-by-side attached SEDIT windows if SEDIT is the EDITMODE. You can use SEDIT operations to zoom in on the location of any changes, deleting common stuff for example. But you are always working on a copy, so that changes are safe and ephemeral. This is an examination, not an edit.")
|
||||
|
||||
(CL:UNLESS NAME
|
||||
(CL:UNLESS (LISTP SOURCE1)
|
||||
(ERROR SOURCE1 " cannot be examined"))
|
||||
(CL:UNLESS (LISTP SOURCE2)
|
||||
(ERROR SOURCE2 " cannot be examined")))
|
||||
|
||||
(* ;; "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?)")
|
||||
|
||||
(LET (DEF1 DEF2)
|
||||
(SETQ DEF1 (IF (LISTP SOURCE1)
|
||||
THEN
|
||||
(* ;; "Copy to simulate READONLY")
|
||||
|
||||
(SETQ DEF1 (COPY SOURCE1))
|
||||
ELSEIF (GETDEF NAME TYPE SOURCE1)
|
||||
ELSE (ERROR NAME " not found on " SOURCE1)))
|
||||
(SETQ DEF2 (IF (LISTP SOURCE2)
|
||||
THEN (COPY SOURCE2)
|
||||
ELSEIF (GETDEF NAME TYPE SOURCE2)
|
||||
ELSE (ERROR NAME " not found on " SOURCE2)))
|
||||
(CL:UNLESS TITLE1
|
||||
(SETQ TITLE1 (OR (AND SOURCE1 (LITATOM SOURCE1))
|
||||
"File 1")))
|
||||
(CL:UNLESS TITLE2
|
||||
(SETQ TITLE2 (OR (AND SOURCE2 (LITATOM SOURCE2))
|
||||
"File 2")))
|
||||
(SELECTQ (EDITMODE)
|
||||
(SEDIT:SEDIT
|
||||
(* ;;
|
||||
"A kludge to eliminate dangling SEDIT processes from previous examinations")
|
||||
|
||||
[SETQ EXAMINEDEFS-PROCESS-LIST
|
||||
(FOR PAIR IN EXAMINEDEFS-PROCESS-LIST
|
||||
COLLECT (IF (OPENWP (CAR PAIR))
|
||||
THEN PAIR
|
||||
ELSE (DEL.PROCESS (CDR PAIR))
|
||||
(GO $$ITERATE]
|
||||
|
||||
(* ;; "Set it up for new side-by-side regions that are forgotten when the window is closed. Their shape is usually not that useful for regular edits.")
|
||||
|
||||
(* ;;
|
||||
"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]
|
||||
|
||||
(* ;;
|
||||
"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)))
|
||||
(PROGN (EDITE DEF1)
|
||||
(EDITE DEF2])
|
||||
|
||||
(EXAMINEFILES
|
||||
[LAMBDA (FILE1 FILE2 TITLE1 TITLE2 REGION) (* ; "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])
|
||||
)
|
||||
|
||||
(RPAQ? EXAMINEDEFS-PROCESS-LIST )
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (510 6809 (EXAMINEDEFS 520 . 5811) (EXAMINEFILES 5813 . 6807)))))
|
||||
STOP
|
||||
BIN
lispusers/EXAMINEDEFS.LCOM
Normal file
BIN
lispusers/EXAMINEDEFS.LCOM
Normal file
Binary file not shown.
BIN
lispusers/EXAMINEDEFS.TEDIT
Normal file
BIN
lispusers/EXAMINEDEFS.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.
227
lispusers/LIFE
227
lispusers/LIFE
@@ -1,119 +1,156 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(filecreated "20-Aug-88 12:18:43" {erinyes}<lispusers>medley>life.\;5 8231
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
|previous| |date:| " 6-Mar-87 19:11:20" {erinyes}<lispusers>medley>life.\;3)
|
||||
(FILECREATED " 6-Dec-2021 15:21:48" |{DSK}<home>medley>medley>lispusers>LIFE.;3| 9875
|
||||
|
||||
|changes| |to:| (VARS LIFECOMS)
|
||||
(FNS EXPAND.BITMAP.VERTICALLY)
|
||||
|
||||
|previous| |date:| "20-Aug-88 12:18:43" |{DSK}<home>medley>medley>lispusers>LIFE.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988 by Xerox Corporation.
|
||||
|
||||
(prettycomprint lifecoms)
|
||||
(PRETTYCOMPRINT LIFECOMS)
|
||||
|
||||
(rpaqq lifecoms
|
||||
((functions |Life| |LifeIdle|)
|
||||
(fns expand.bitmap.vertically expand.bitmap.horizontally)
|
||||
(addvars (idle.functions ("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(lambda (\w)
|
||||
(RPAQQ LIFECOMS
|
||||
((PROP FILETYPE LIFE)
|
||||
(FUNCTIONS |Life| |LifeIdle|)
|
||||
(FNS EXPAND.BITMAP.VERTICALLY EXPAND.BITMAP.HORIZONTALLY)
|
||||
(ADDVARS (IDLE.FUNCTIONS ("Life" '|LifeIdle| NIL (SUBITEMS ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(LAMBDA (\w)
|
||||
(|LifeIdle|
|
||||
\w 2)))
|
||||
("Quadruple bits"
|
||||
'(lambda (\w)
|
||||
'(LAMBDA (\w)
|
||||
(|LifeIdle| \w 4)))
|
||||
("Eight bits" '(lambda (\w)
|
||||
("Eight bits" '(LAMBDA (\w)
|
||||
(|LifeIdle|
|
||||
\w 8)))))))))
|
||||
|
||||
(cl:defun |Life| (win &optional (n 1))
|
||||
(let* ((w (windowprop win 'width))
|
||||
(w1 (idifference w n))
|
||||
(h (iquotient (windowprop win 'height)
|
||||
n))
|
||||
(h1 (sub1 h))
|
||||
(a (bitmapcreate w h))
|
||||
(b (bitmapcreate w h))
|
||||
(c (bitmapcreate w h))
|
||||
(d (bitmapcreate w h))
|
||||
(e (bitmapcreate w h))
|
||||
pbt temp)
|
||||
(|if| (neq n 1)
|
||||
|then| (setq temp (bitmapcreate (iquotient w n)
|
||||
h))
|
||||
(setq pbt (|create| pilotbbt))
|
||||
(bitblt win 0 0 temp 0 0)
|
||||
(expand.bitmap.horizontally temp n a pbt)
|
||||
(setq temp (bitmapcreate w (windowprop win 'height)))
|
||||
(bitblt a 0 0 temp 0 0 w h)
|
||||
|else| (bitblt win 0 0 a 0 0 w h))
|
||||
(cl:loop (block)
|
||||
(cl:macrolet ((bitbltbitmap (source sourceleft sourcebottom destination
|
||||
destinationleft destinationbottom width height
|
||||
&optional sourcetype operation)
|
||||
`(\\bitblt.bitmap ,source ,sourceleft ,sourcebottom
|
||||
,destination ,destinationleft ,destinationbottom
|
||||
,width
|
||||
,height
|
||||
,sourcetype
|
||||
,operation nil nil ,sourceleft ,sourcebottom))
|
||||
(shuffle (inhi lo horiz?)
|
||||
`(progn ,@(|if| horiz?
|
||||
|then| `((bitbltbitmap ,inhi n 0 ,lo 0 0 w1 h)
|
||||
(bitbltbitmap ,inhi 0 0 ,lo w1 0 n h)
|
||||
(bitbltbitmap ,inhi 0 0 c n 0 w1 h)
|
||||
(bitbltbitmap ,inhi w1 0 c 0 0 n h))
|
||||
|else| `((bitbltbitmap ,inhi 0 1 ,lo 0 0 w h1)
|
||||
(bitbltbitmap ,inhi 0 0 ,lo 0 h1 w 1)
|
||||
(bitbltbitmap ,inhi 0 0 c 0 1 w h1)
|
||||
(bitbltbitmap ,inhi 0 h1 c 0 0 w 1)))
|
||||
(bitbltbitmap c 0 0 ,lo 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap ,lo 0 0 c 0 0 w h 'input 'erase)
|
||||
(bitbltbitmap ,inhi 0 0 ,lo 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap ,lo 0 0 ,inhi 0 0 w h 'input 'erase)
|
||||
(bitbltbitmap c 0 0 ,inhi 0 0 w h 'input 'paint))))
|
||||
(shuffle a b t)
|
||||
(shuffle b d nil)
|
||||
(shuffle a e nil)
|
||||
(bitbltbitmap d 0 0 c 0 0 w h)
|
||||
(bitbltbitmap b 0 0 c 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap e 0 0 c 0 0 w h 'input 'invert)
|
||||
(|if| (eq n 1)
|
||||
|then| (bitblt win 0 0 d 0 0 w h 'input 'paint)
|
||||
|else| (bitbltbitmap temp 0 0 d 0 0 w h 'input 'paint))
|
||||
(|if| (shiftdownp 'ctrl)
|
||||
|then| (bitbltbitmap d 0 0 a 0 0 w h)
|
||||
|else| (bitbltbitmap b 0 0 e 0 0 w h 'input 'paint)
|
||||
(bitbltbitmap e 0 0 a 0 0 w h 'input 'invert)
|
||||
(bitbltbitmap c 0 0 a 0 0 w h 'input 'erase)
|
||||
(bitbltbitmap d 0 0 a 0 0 w h 'invert 'erase))
|
||||
(|if| (eq n 1)
|
||||
|then| (bitblt a 0 0 win 0 0 w h)
|
||||
|else| (expand.bitmap.vertically a n temp pbt)
|
||||
(bitblt temp 0 0 win 0 0)
|
||||
(bitbltbitmap a 0 0 temp 0 0 w h))))))
|
||||
(PUTPROPS LIFE FILETYPE :COMPILE-FILE)
|
||||
|
||||
(cl:defun |LifeIdle| (\w &optional (\n 1))
|
||||
(bitblt (windowprop \w 'imagecovered)
|
||||
(CL:DEFUN |Life| (WIN &OPTIONAL (N 1))
|
||||
(LET* ((W (WINDOWPROP WIN 'WIDTH))
|
||||
(W1 (IDIFFERENCE W N))
|
||||
(H (IQUOTIENT (WINDOWPROP WIN 'HEIGHT)
|
||||
N))
|
||||
(H1 (SUB1 H))
|
||||
(A (BITMAPCREATE W H))
|
||||
(B (BITMAPCREATE W H))
|
||||
(C (BITMAPCREATE W H))
|
||||
(D (BITMAPCREATE W H))
|
||||
(E (BITMAPCREATE W H))
|
||||
PBT TEMP)
|
||||
(|if| (NEQ N 1)
|
||||
|then| (SETQ TEMP (BITMAPCREATE (IQUOTIENT W N)
|
||||
H))
|
||||
(SETQ PBT (|create| PILOTBBT))
|
||||
(BITBLT WIN 0 0 TEMP 0 0)
|
||||
(EXPAND.BITMAP.HORIZONTALLY TEMP N A PBT)
|
||||
(SETQ TEMP (BITMAPCREATE W (WINDOWPROP WIN 'HEIGHT)))
|
||||
(BITBLT A 0 0 TEMP 0 0 W H)
|
||||
|else| (BITBLT WIN 0 0 A 0 0 W H))
|
||||
(CL:LOOP (BLOCK)
|
||||
(CL:MACROLET ((BITBLTBITMAP (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION
|
||||
DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
|
||||
&OPTIONAL SOURCETYPE OPERATION)
|
||||
`(\\BITBLT.BITMAP ,SOURCE ,SOURCELEFT ,SOURCEBOTTOM
|
||||
,DESTINATION ,DESTINATIONLEFT ,DESTINATIONBOTTOM
|
||||
,WIDTH
|
||||
,HEIGHT
|
||||
,SOURCETYPE
|
||||
,OPERATION NIL NIL ,SOURCELEFT ,SOURCEBOTTOM))
|
||||
(SHUFFLE (INHI LO HORIZ?)
|
||||
`(PROGN ,@(|if| HORIZ?
|
||||
|then| `((BITBLTBITMAP ,INHI N 0 ,LO 0 0 W1 H)
|
||||
(BITBLTBITMAP ,INHI 0 0 ,LO W1 0 N H)
|
||||
(BITBLTBITMAP ,INHI 0 0 C N 0 W1 H)
|
||||
(BITBLTBITMAP ,INHI W1 0 C 0 0 N H))
|
||||
|else| `((BITBLTBITMAP ,INHI 0 1 ,LO 0 0 W H1)
|
||||
(BITBLTBITMAP ,INHI 0 0 ,LO 0 H1 W 1)
|
||||
(BITBLTBITMAP ,INHI 0 0 C 0 1 W H1)
|
||||
(BITBLTBITMAP ,INHI 0 H1 C 0 0 W 1)))
|
||||
(BITBLTBITMAP C 0 0 ,LO 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP ,LO 0 0 C 0 0 W H 'INPUT 'ERASE)
|
||||
(BITBLTBITMAP ,INHI 0 0 ,LO 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP ,LO 0 0 ,INHI 0 0 W H 'INPUT 'ERASE)
|
||||
(BITBLTBITMAP C 0 0 ,INHI 0 0 W H 'INPUT 'PAINT))))
|
||||
(SHUFFLE A B T)
|
||||
(SHUFFLE B D NIL)
|
||||
(SHUFFLE A E NIL)
|
||||
(BITBLTBITMAP D 0 0 C 0 0 W H)
|
||||
(BITBLTBITMAP B 0 0 C 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP E 0 0 C 0 0 W H 'INPUT 'INVERT)
|
||||
(|if| (EQ N 1)
|
||||
|then| (BITBLT WIN 0 0 D 0 0 W H 'INPUT 'PAINT)
|
||||
|else| (BITBLTBITMAP TEMP 0 0 D 0 0 W H 'INPUT 'PAINT))
|
||||
(|if| (SHIFTDOWNP 'CTRL)
|
||||
|then| (BITBLTBITMAP D 0 0 A 0 0 W H)
|
||||
|else| (BITBLTBITMAP B 0 0 E 0 0 W H 'INPUT 'PAINT)
|
||||
(BITBLTBITMAP E 0 0 A 0 0 W H 'INPUT 'INVERT)
|
||||
(BITBLTBITMAP C 0 0 A 0 0 W H 'INPUT 'ERASE)
|
||||
(BITBLTBITMAP D 0 0 A 0 0 W H 'INVERT 'ERASE))
|
||||
(|if| (EQ N 1)
|
||||
|then| (BITBLT A 0 0 WIN 0 0 W H)
|
||||
|else| (EXPAND.BITMAP.VERTICALLY A N TEMP PBT)
|
||||
(BITBLT TEMP 0 0 WIN 0 0)
|
||||
(BITBLTBITMAP A 0 0 TEMP 0 0 W H))))))
|
||||
|
||||
(CL:DEFUN |LifeIdle| (\w &OPTIONAL (\n 1))
|
||||
(BITBLT (WINDOWPROP \w 'IMAGECOVERED)
|
||||
0 0 \w)
|
||||
(|Life| \w \n))
|
||||
(defineq
|
||||
(|Life| \w \n))
|
||||
(DEFINEQ
|
||||
|
||||
(expand.bitmap.vertically
|
||||
(lambda (bitmap m bm2 pbt) (* \; "Edited 6-Mar-87 15:02 by Masinter") (or bm2 (setq bm2 (bitmapcreate (|fetch| bitmapwidth bitmap) (times m (|fetch| bitmapheight bitmap))))) (or pbt (setq pbt (|create| pilotbbt))) (|with| pilotbbt pbt (*) (setq pbtdesthi (|ffetch| |BitMapHiLoc| bm2)) (setq pbtdestlo (|ffetch| |BitMapLoLoc| bm2)) (setq pbtsourcehi (|ffetch| |BitMapHiLoc| bitmap)) (setq pbtsourcelo (|ffetch| |BitMapLoLoc| bitmap)) (setq pbtdestbpl (times 16 m (|ffetch| bitmaprasterwidth bm2))) (setq pbtsourcebpl (times 16 (|ffetch| bitmaprasterwidth bitmap))) (setq pbtsourcebit 0) (setq pbtdestbit 0) (setq pbtflags 16384) (setq pbtheight (|fetch| bitmapheight bitmap)) (setq pbtwidth (|fetch| bitmapwidth bitmap)) (|for| i |from| 0 |while| (lessp i m) |do| (\\pilotbitblt pbt 0) (|add| pbtdestlo (|fetch| bitmaprasterwidth bm2)))) bm2)
|
||||
)
|
||||
(EXPAND.BITMAP.VERTICALLY
|
||||
(LAMBDA (BITMAP M BM2 PBT) (* \;
|
||||
"Edited 6-Dec-2021 15:04 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 14:47 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 13:54 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 13:51 by medley")
|
||||
(* \;
|
||||
"Edited 6-Dec-2021 13:11 by medley")
|
||||
(* \;
|
||||
"Edited 6-Mar-87 15:02 by Masinter")
|
||||
(OR BM2 (SETQ BM2 (BITMAPCREATE (|fetch| BITMAPWIDTH BITMAP)
|
||||
(TIMES M (|fetch| BITMAPHEIGHT BITMAP)))))
|
||||
(OR PBT (SETQ PBT (|create| PILOTBBT)))
|
||||
(|with| PILOTBBT PBT (*)
|
||||
(SETQ PBTDESTHI (|ffetch| |BitMapHiLoc| BM2))
|
||||
(SETQ PBTDESTLO (|ffetch| |BitMapLoLoc| BM2))
|
||||
(SETQ PBTSOURCEHI (|ffetch| |BitMapHiLoc| BITMAP))
|
||||
(SETQ PBTSOURCELO (|ffetch| |BitMapLoLoc| BITMAP))
|
||||
(SETQ PBTDESTBPL (TIMES 16 M (|ffetch| BITMAPRASTERWIDTH BM2)))
|
||||
(SETQ PBTSOURCEBPL (TIMES 16 (|ffetch| BITMAPRASTERWIDTH BITMAP)))
|
||||
(SETQ PBTSOURCEBIT 0)
|
||||
(SETQ PBTDESTBIT 0)
|
||||
(SETQ PBTFLAGS 16384)
|
||||
(SETQ PBTHEIGHT (|fetch| BITMAPHEIGHT BITMAP))
|
||||
(SETQ PBTWIDTH (|fetch| BITMAPWIDTH BITMAP))
|
||||
(|for| I |from| 1 |to| M |do| (\\PILOTBITBLT PBT 0)
|
||||
(|add| PBTDESTLO (|fetch|
|
||||
BITMAPRASTERWIDTH
|
||||
|of| BM2))))
|
||||
BM2))
|
||||
|
||||
(expand.bitmap.horizontally
|
||||
(lambda (bitmap n bm2 pbt) (* \; "Edited 6-Mar-87 17:08 by Masinter") (or bm2 (setq bm2 (bitmapcreate (times n (|fetch| bitmapwidth bitmap)) (|fetch| bitmapheight bitmap)))) (or pbt (setq pbt (|create| pilotbbt))) (let ((sourcebase (|fetch| bitmapbase bitmap)) (destbase (|fetch| bitmapbase bm2))) (|with| pilotbbt pbt (setq pbtdestbpl n) (setq pbtsourcebpl 1) (setq pbtsourcebit 0) (setq pbtflags 16384) (setq pbtwidth 1) (let ((ht (times (|fetch| bitmapwidth bitmap) (|fetch| bitmapheight bitmap)))) (|do| (setq pbtdest destbase) (setq pbtsource sourcebase) (setq pbtheight (min (times 1024 16) ht)) (setq pbtdestbit 0) (|for| i |from| 0 |while| (lessp i n) |do| (\\pilotbitblt pbt 0) (|add| pbtdestbit 1)) (setq ht (- ht (times 1024 16))) (|if| (leq ht 0) |then| (return)) (setq destbase (\\addbase destbase (times n 1024))) (setq sourcebase (\\addbase sourcebase 1024)))))) bm2)
|
||||
)
|
||||
)
|
||||
|
||||
(addtovar idle.functions
|
||||
("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(lambda (\w)
|
||||
(ADDTOVAR IDLE.FUNCTIONS
|
||||
("Life" '|LifeIdle| NIL (SUBITEMS ("Single bits" '|LifeIdle|)
|
||||
("Double bits" '(LAMBDA (\w)
|
||||
(|LifeIdle| \w 2)))
|
||||
("Quadruple bits" '(lambda (\w)
|
||||
("Quadruple bits" '(LAMBDA (\w)
|
||||
(|LifeIdle| \w 4)))
|
||||
("Eight bits" '(lambda (\w)
|
||||
("Eight bits" '(LAMBDA (\w)
|
||||
(|LifeIdle| \w 8))))))
|
||||
(putprops life copyright ("Xerox Corporation" 1987 1988))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil (5774 7579 (expand.bitmap.vertically 5784 . 6658) (expand.bitmap.horizontally 6660 .
|
||||
7577)))))
|
||||
stop
|
||||
(PUTPROPS LIFE COPYRIGHT ("Xerox Corporation" 1987 1988))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (1557 5825 (|Life| 1557 . 5825)) (5827 5955 (|LifeIdle| 5827 . 5955)) (5956 9223 (
|
||||
EXPAND.BITMAP.VERTICALLY 5966 . 8302) (EXPAND.BITMAP.HORIZONTALLY 8304 . 9221)))))
|
||||
STOP
|
||||
|
||||
BIN
lispusers/LIFE.DFASL
Normal file
BIN
lispusers/LIFE.DFASL
Normal file
Binary file not shown.
Binary file not shown.
3
lispusers/MIGRATION/DIR.TXT
Normal file
3
lispusers/MIGRATION/DIR.TXT
Normal file
@@ -0,0 +1,3 @@
|
||||
Contains a tool for translating File Manger format Interlisp source
|
||||
files from Medley into Common Lisp text files. The software runs in
|
||||
the Medley system.
|
||||
116
lispusers/MIGRATION/FILEPKGRECORDS
Normal file
116
lispusers/MIGRATION/FILEPKGRECORDS
Normal file
@@ -0,0 +1,116 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||
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
|
||||
with the terms of said license.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT FILEPKGRECORDSCOMS)
|
||||
|
||||
(RPAQQ FILEPKGRECORDSCOMS
|
||||
[(COMS (* ;
|
||||
"standard records for accessing file package type/command parts. Exported for PRETTY")
|
||||
(RECORDS * FILEPKGRECORDS)])
|
||||
|
||||
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
|
||||
|
||||
(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
|
||||
(UNDOABLE (COND
|
||||
(NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
|
||||
(T (/REMPROP DATUM 'ADDTOPRETTYCOM]
|
||||
[DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
|
||||
(UNDOABLE (COND
|
||||
(NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
|
||||
(T (/REMPROP DATUM 'DELFROMPRETTYCOM]
|
||||
[PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
|
||||
(UNDOABLE (COND
|
||||
(NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
|
||||
(T (/REMPROP DATUM 'PRETTYTYPE]
|
||||
[CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
|
||||
(UNDOABLE (COND
|
||||
(NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
|
||||
(T (/REMPROP DATUM 'FILEPKGCONTENTS]
|
||||
(MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
|
||||
(STANDARD [COND
|
||||
[NEWVALUE (PUTASSOC DATUM NEWVALUE
|
||||
(OR (LISTP (GETTOPVAL
|
||||
'PRETTYDEFMACROS))
|
||||
(SETTOPVAL 'PRETTYDEFMACROS
|
||||
(LIST (LIST DATUM]
|
||||
(T (SETTOPVAL 'PRETTYDEFMACROS
|
||||
(REMOVE (FASSOC DATUM (GETTOPVAL
|
||||
'PRETTYDEFMACROS))
|
||||
(GETTOPVAL 'PRETTYDEFMACROS]
|
||||
UNDOABLE
|
||||
(COND
|
||||
[NEWVALUE (/PUTASSOC DATUM NEWVALUE
|
||||
(OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
|
||||
(/SETTOPVAL 'PRETTYDEFMACROS
|
||||
(LIST (LIST DATUM]
|
||||
(T (/SETTOPVAL 'PRETTYDEFMACROS
|
||||
(REMOVE (FASSOC DATUM (GETTOPVAL
|
||||
'PRETTYDEFMACROS))
|
||||
(GETTOPVAL 'PRETTYDEFMACROS]
|
||||
(* Not an atom record cause want
|
||||
REMPROP on NILs.)
|
||||
(* NOTE%: PRETTCOM on PRETTY has
|
||||
open-coded access to the MACRO
|
||||
property.)
|
||||
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
|
||||
FILEPKGCONTENTS)))
|
||||
|
||||
|
||||
|
||||
(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED
|
||||
HASDEF EDITDEF FILEGETDEF CANFILEDEF)
|
||||
(ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
|
||||
(CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
|
||||
)
|
||||
(CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
|
||||
DATUM)))
|
||||
(STANDARD (SETTOPVAL (CAR (
|
||||
SEARCHPRETTYTYPELST
|
||||
DATUM NEWVALUE)
|
||||
)
|
||||
NEWVALUE)
|
||||
UNDOABLE
|
||||
(/SETTOPVAL (CAR (
|
||||
SEARCHPRETTYTYPELST
|
||||
DATUM NEWVALUE))
|
||||
NEWVALUE)))
|
||||
(DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
|
||||
DATUM)))
|
||||
(CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
|
||||
DATUM NEWVALUE))
|
||||
NEWVALUE)))
|
||||
(ALLFIELDS NIL (/SETTOPVAL
|
||||
'PRETTYTYPELST
|
||||
(REMOVE (SEARCHPRETTYTYPELST
|
||||
DATUM)
|
||||
(GETTOPVAL 'PRETTYTYPELST]
|
||||
(* NOTE%: PRETTYCOM on PRETTY has
|
||||
open-coded access to GETDEF property)
|
||||
(INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
|
||||
(MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
|
||||
(PUT X
|
||||
'PROPTYPE
|
||||
'FILEPKGCOMS]
|
||||
(ADDTOVAR PRETTYTYPELST))))
|
||||
|
||||
|
||||
(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
|
||||
[ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
|
||||
(STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
|
||||
UNDOABLE
|
||||
(/PUTPROP DATUM 'FILE NEWVALUE])
|
||||
|
||||
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
|
||||
|
||||
(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
|
||||
|
||||
|
||||
|
||||
IL:STOP
|
||||
1
lispusers/MIGRATION/FILEPKGRECORDS.LCOM
Normal file
1
lispusers/MIGRATION/FILEPKGRECORDS.LCOM
Normal file
@@ -0,0 +1 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
805
lispusers/MIGRATION/IL-CONVERT
Normal file
805
lispusers/MIGRATION/IL-CONVERT
Normal file
@@ -0,0 +1,805 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL-CONVERT" BASE 10)
|
||||
(IL:FILECREATED "26-Jan-90 10:28:55" IL:|{DSK}/users/welch/migration/IL-CONVERT.;5| 30652
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:IL-CONVERTCOMS)
|
||||
|
||||
IL:|previous| IL:|date:| "25-Jan-90 14:45:43" IL:|{DSK}/users/welch/migration/IL-CONVERT.;4|)
|
||||
|
||||
|
||||
; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:IL-CONVERTCOMS)
|
||||
|
||||
(IL:RPAQQ IL:IL-CONVERTCOMS
|
||||
((IL:FUNCTIONS IL-DEFCONV)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Used when an Interlisp function is the same as the Common Lisp function of the same name.")
|
||||
|
||||
(IL:FUNCTIONS IL-COPYDEF)
|
||||
|
||||
(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")
|
||||
|
||||
(IL:FUNCTIONS IL-DEFUN IL-DEFVAR)
|
||||
|
||||
(IL:* IL:|;;| "
|
||||
; Creates an external symbol in the IL package.
|
||||
(defmacro il-defsym (name)
|
||||
`(export (intern (symbol-name ',name) *il-package*) *il-package*))
|
||||
|
||||
(defmacro il-import (symbol)
|
||||
`(progn (import ,symbol 'il)
|
||||
(export (find-symbol (symbol-name ,symbol) 'il) 'il)))
|
||||
")
|
||||
|
||||
(IL:FUNCTIONS IL-COPYCONV)
|
||||
|
||||
(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")
|
||||
|
||||
(IL:FUNCTIONS IL-WARNINGFORM)
|
||||
|
||||
(IL:* IL:|;;| "Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1. Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR).")
|
||||
|
||||
(IL:P
|
||||
(MACROLET ((DEF-*-IF-NEEDED
|
||||
(NAME)
|
||||
(LET ((NAME-STRING (SYMBOL-NAME NAME)))
|
||||
`(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED"))
|
||||
(ARGS)
|
||||
(CASE (LENGTH ARGS)
|
||||
(0 ,(EVAL `(,NAME)))
|
||||
(1 (FIRST ARGS))
|
||||
(T `(,',NAME ,@ARGS)))))))
|
||||
(DEF-*-IF-NEEDED PROGN)
|
||||
(DEF-*-IF-NEEDED AND)
|
||||
(DEF-*-IF-NEEDED OR)))
|
||||
(IL:STRUCTURES FAKE-SYMBOL SHARP-DOT SHARP-COMMA)
|
||||
|
||||
(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")
|
||||
|
||||
(IL:FUNCTIONS QUOTED-SYMBOL-P)
|
||||
(IL:VARIABLES *ORIGINAL-READTABLE*)
|
||||
(IL:FUNCTIONS OLD-CONVERT-FILE)
|
||||
(IL:P (EXPORT 'CONVERT-FILE))
|
||||
|
||||
(IL:* IL:|;;| "(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")")
|
||||
|
||||
(IL:P (EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES)))
|
||||
(IL:FUNCTIONS READ-EXPORTS)
|
||||
(IL:* IL:\; "Get the symbol list")
|
||||
(IL:FUNCTIONS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES READ-HASH-TABLE
|
||||
WRITE-HASH-TABLE)
|
||||
(IL:FUNCTIONS CONVERT-FILE CONVERT-FILECOMS CONVERT-ONE-FILECOM
|
||||
EXPURGATE-EXTRANEOUS-PROGNS REORDER-FILECOMS MAKE-EXPORT-FORM)
|
||||
(IL:VARIABLES *WALKER-TEMPLATES*)
|
||||
(IL:FUNCTIONS GET-WALKER-TEMPLATE WALK-FORM-INTERNAL WALK-TEMPLATE
|
||||
WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-REPEAT-EVAL RECONS
|
||||
RELIST RELIST* RELIST-INTERNAL)
|
||||
(IL:VARIABLES *GETVALUE-TRANSLATION* *CURRENT-DEFINITION* *CURRENT-DEFINITION-TYPE*
|
||||
*CURRENT-EXPRESSION* *CURRENT-LOCALS* *FILE-CONTEXT* *WALKER-FIND-PARAMETER-LIST*
|
||||
*WARNINGS-MADE* *PACKAGE-FOR-IL-SYMBOLS* *PACKAGE-FOR-RESULT-FILE*
|
||||
*PARAMETERS-ALWAYS-OPTIONAL* *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE*
|
||||
*UNKNOWN-MACRO-ACTION* *ALWAYS-INCLUDE-PROPS*)
|
||||
(IL:DECLARE\: IL:DONTCOPY (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE)
|
||||
IL:IL-CONVERT))))
|
||||
|
||||
(XCL:DEFDEFINER IL-DEFCONV IL:FUNCTIONS (NAME ARGLIST &REST REST)
|
||||
(CHECK-TYPE NAME SYMBOL)
|
||||
(LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
|
||||
*IL-PACKAGE*)))
|
||||
(IF FN-NAME
|
||||
`(SETF (GET ',FN-NAME 'CONVERT-FORM)
|
||||
#'(LAMBDA ,ARGLIST ,@REST))
|
||||
(PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
|
||||
NIL))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Used when an Interlisp function is the same as the Common Lisp function of the same name.")
|
||||
|
||||
|
||||
(DEFMACRO IL-COPYDEF (NAME &OPTIONAL (NEWNAME NAME))
|
||||
(LET ((SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
|
||||
*IL-PACKAGE*)))
|
||||
(UNLESS SYM (ERROR "No symbol ~:@(~a~) found in IL package." SYM))
|
||||
`(SETF (GET ',SYM 'CONVERT-FORM)
|
||||
#'(LAMBDA (&REST ARGS)
|
||||
(CONS ',NAME (MAPCONVERT ARGS))))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")
|
||||
|
||||
|
||||
(XCL:DEFDEFINER IL-DEFUN IL:FUNCTIONS (NAME &REST REST)
|
||||
(CHECK-TYPE NAME SYMBOL)
|
||||
(LET* ((NAME-STRING (SYMBOL-NAME NAME))
|
||||
(IL-SYM (INTERN NAME-STRING 'IL))
|
||||
(IL-SYM1 (IF (CHAR/= (ELT NAME-STRING 0)
|
||||
#\/)
|
||||
(INTERN (CONCATENATE 'STRING "/" NAME-STRING)
|
||||
'IL))))
|
||||
`(PROGN (EXPORT ',IL-SYM 'IL)
|
||||
(DEFUN ,IL-SYM ,@REST) (IL:* IL:\;
|
||||
"Also make a version starting with a /")
|
||||
,@(IF IL-SYM1
|
||||
`((EXPORT ',IL-SYM1 'IL)
|
||||
(SETF (SYMBOL-FUNCTION ',IL-SYM1)
|
||||
(SYMBOL-FUNCTION ',IL-SYM)))))))
|
||||
|
||||
(XCL:DEFDEFINER IL-DEFVAR IL:FUNCTIONS (NAME &REST ARGS)
|
||||
(LET ((IL-SYM (INTERN (SYMBOL-NAME NAME)
|
||||
*IL-PACKAGE*)))
|
||||
`(PROGN (EXPORT ',IL-SYM 'IL)
|
||||
(DEFVAR ,IL-SYM ,@(MAPCONVERT ARGS)))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"
|
||||
; Creates an external symbol in the IL package.
|
||||
(defmacro il-defsym (name)
|
||||
`(export (intern (symbol-name ',name) *il-package*) *il-package*))
|
||||
|
||||
(defmacro il-import (symbol)
|
||||
`(progn (import ,symbol 'il)
|
||||
(export (find-symbol (symbol-name ,symbol) 'il) 'il)))
|
||||
")
|
||||
|
||||
|
||||
(DEFMACRO IL-COPYCONV (OLDNAME NEWNAME)
|
||||
(LET* ((OLD-SYM (FIND-SYMBOL (SYMBOL-NAME OLDNAME)
|
||||
*IL-PACKAGE*))
|
||||
(NEW-SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
|
||||
*IL-PACKAGE*)))
|
||||
(UNLESS OLD-SYM (ERROR "No symbol ~:@(~a~) found in IL package." OLD-SYM))
|
||||
(UNLESS NEW-SYM (ERROR "No symbol ~:@(~a~) found in IL package." NEW-SYM))
|
||||
`(SETF (GET ',NEW-SYM 'CONVERT-FORM)
|
||||
#'(LAMBDA (&REST ARGS)
|
||||
(APPLY (GET ',OLD-SYM 'CONVERT-FORM)
|
||||
ARGS)))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")
|
||||
|
||||
|
||||
(XCL:DEFDEFINER IL-WARNINGFORM IL:FUNCTIONS (NAME &OPTIONAL (TEMPLATE '(NIL REPEAT (EVAL)))
|
||||
(WARN-SWITCH '*WARN-ON-UNTRANSLATABLE-IL-FORM*)
|
||||
)
|
||||
(LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
|
||||
*IL-PACKAGE*)))
|
||||
(IF FN-NAME
|
||||
`(SETF (GET ',FN-NAME 'CONVERT-FORM)
|
||||
#'(LAMBDA (&REST REST)
|
||||
(DECLARE (SPECIAL ,WARN-SWITCH))
|
||||
(WHEN ,WARN-SWITCH
|
||||
(WARN "Unable to translate a ~a form." ',FN-NAME))
|
||||
(WALK-TEMPLATE (CONS ',FN-NAME REST)
|
||||
',TEMPLATE)))
|
||||
(PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
|
||||
NIL))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1. Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR)."
|
||||
)
|
||||
|
||||
|
||||
(MACROLET ((DEF-*-IF-NEEDED (NAME)
|
||||
(LET ((NAME-STRING (SYMBOL-NAME NAME)))
|
||||
`(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED")) (ARGS)
|
||||
(CASE (LENGTH ARGS)
|
||||
(0 ,(EVAL `(,NAME)))
|
||||
(1 (FIRST ARGS))
|
||||
(T `(,',NAME ,@ARGS)))))))
|
||||
(DEF-*-IF-NEEDED PROGN)
|
||||
(DEF-*-IF-NEEDED AND)
|
||||
(DEF-*-IF-NEEDED OR))
|
||||
|
||||
(DEFSTRUCT (FAKE-SYMBOL (:CONSTRUCTOR MAKE-FAKE-SYMBOL (NAME))
|
||||
(:PRINT-FUNCTION (LAMBDA (OBJ STREAM DEPTH)
|
||||
(PRINC (FAKE-SYMBOL-NAME OBJ)
|
||||
STREAM))))
|
||||
NAME)
|
||||
|
||||
(DEFSTRUCT (SHARP-DOT (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
|
||||
(WRITE-STRING "#." STREAM)
|
||||
(WRITE (SHARP-DOT-CONTENTS SELF)
|
||||
:STREAM STREAM))))
|
||||
CONTENTS)
|
||||
|
||||
(DEFSTRUCT (SHARP-COMMA (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
|
||||
(WRITE-STRING "#," STREAM)
|
||||
(WRITE (SHARP-COMMA-CONTENTS SELF)
|
||||
:STREAM STREAM))))
|
||||
CONTENTS)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")
|
||||
|
||||
|
||||
(DEFUN QUOTED-SYMBOL-P (X)
|
||||
(AND (CONSP X)
|
||||
(EQ (CAR X)
|
||||
'QUOTE)
|
||||
(SYMBOLP (CADR X))
|
||||
(NULL (CDDR X))))
|
||||
|
||||
(DEFVAR *ORIGINAL-READTABLE* (COPY-READTABLE NIL))
|
||||
|
||||
(DEFUN OLD-CONVERT-FILE (INFILE OUTFILE)
|
||||
(WITH-OPEN-FILE (INSTREAM INFILE)
|
||||
(IF OUTFILE
|
||||
(WITH-OPEN-STREAM (OUTSTREAM (COND
|
||||
((EQ OUTFILE 'T)
|
||||
(MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
|
||||
(T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS
|
||||
:SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
|
||||
(CONVERT-FILE-INTERNAL INSTREAM OUTSTREAM))
|
||||
(CONVERT-FILE-INTERNAL INSTREAM NIL))))
|
||||
|
||||
(EXPORT 'CONVERT-FILE)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")"
|
||||
)
|
||||
|
||||
|
||||
(EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES))
|
||||
|
||||
(DEFUN READ-EXPORTS (FILE)
|
||||
|
||||
(IL:* IL:|;;| "Read the exported-symbols file if it exists")
|
||||
|
||||
(WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
|
||||
(WHEN STREAM
|
||||
(READ STREAM) (IL:* IL:\;
|
||||
"Read the \"(in-package)\" form")
|
||||
(SETQ *EXPORTED-IL-SYMBOLS* (CADADR (READ STREAM))))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:\; "Get the symbol list")
|
||||
|
||||
|
||||
(DEFUN WRITE-EXPORTS (FILE)
|
||||
(WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
|
||||
(SETQ *EXPORTED-IL-SYMBOLS* (SORT *EXPORTED-IL-SYMBOLS* #'STRING< :KEY #'SYMBOL-NAME))
|
||||
(LET ((*PACKAGE* *IL-PACKAGE*))
|
||||
(FORMAT STREAM "(lisp:in-package \"IL\")~%(lisp:export '(")
|
||||
(DOLIST (SYM *EXPORTED-IL-SYMBOLS*)
|
||||
(FORMAT STREAM "~% ~s" SYM))
|
||||
(FORMAT STREAM ")~%"))))
|
||||
|
||||
(DEFUN READ-RECORD-TYPES (FILE) (IL:* IL:\;
|
||||
"Read the record-types file if it exists")
|
||||
(WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
|
||||
(WHEN STREAM (READ-HASH-TABLE *RECORD-TYPES* STREAM))))
|
||||
|
||||
(DEFUN WRITE-RECORD-TYPES (FILE)
|
||||
(WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
|
||||
(WRITE-HASH-TABLE *RECORD-TYPES* STREAM)
|
||||
(TERPRI STREAM)))
|
||||
|
||||
(DEFUN READ-HASH-TABLE (HT STREAM &AUX ITEM)
|
||||
(LOOP (WHEN (EQ (SETQ ITEM (READ STREAM NIL 'STOP))
|
||||
'STOP)
|
||||
(RETURN))
|
||||
(SETF (GETHASH (CAR ITEM)
|
||||
HT)
|
||||
(CDR ITEM))))
|
||||
|
||||
(DEFUN WRITE-HASH-TABLE (HT STREAM)
|
||||
(LET* ((COUNT (HASH-TABLE-COUNT HT))
|
||||
(SORTED-TABLE (MAKE-ARRAY COUNT))
|
||||
(I 0))
|
||||
(MAPHASH #'(LAMBDA (KEY VALUE)
|
||||
(SETF (SVREF SORTED-TABLE I)
|
||||
(CONS KEY VALUE))
|
||||
(INCF I))
|
||||
HT)
|
||||
(SORT SORTED-TABLE #'STRING< :KEY #'(LAMBDA (X)
|
||||
(SYMBOL-NAME (CAR X))))
|
||||
(DOTIMES (I COUNT)
|
||||
(PPRINT (SVREF SORTED-TABLE I)
|
||||
STREAM))))
|
||||
|
||||
(DEFUN CONVERT-FILE (FILENAME OUTFILE)
|
||||
(LET* ((REAL-FILENAME (FIND-SYMBOL (STRING FILENAME)
|
||||
(FIND-PACKAGE 'IL)))
|
||||
(COMS (SYMBOL-VALUE (OR (CAAR (GET REAL-FILENAME 'IL:FILE))
|
||||
(ERROR "~a has no FILES definition." FILENAME)))))
|
||||
(IF OUTFILE
|
||||
(WITH-OPEN-STREAM (OUTSTREAM (COND
|
||||
((EQ OUTFILE 'T)
|
||||
(MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
|
||||
(T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS
|
||||
:SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
|
||||
(CONVERT-FILECOMS COMS REAL-FILENAME OUTSTREAM))
|
||||
(CONVERT-FILECOMS COMS REAL-FILENAME NIL))))
|
||||
|
||||
(DEFUN CONVERT-FILECOMS (COMS FILENAME &OPTIONAL OUTSTREAM)
|
||||
(LET ((*EXPORTED-IL-SYMBOLS* NIL)
|
||||
REORDERED-FILECOMS CONVERTED-FILE-LIST)
|
||||
(FORMAT T "~&Processing Forms...~%")
|
||||
(SETQ REORDERED-FILECOMS (REORDER-FILECOMS COMS)
|
||||
CONVERTED-FILE-LIST
|
||||
(EXPURGATE-EXTRANEOUS-PROGNS (MAPCAR 'CONVERT-ONE-FILECOM REORDERED-FILECOMS)))
|
||||
(WHEN OUTSTREAM
|
||||
(FORMAT T "~&Writing output...")
|
||||
(LET* ((MFE (GET FILENAME 'IL:MAKEFILE-ENVIRONMENT))
|
||||
(*PACKAGE* (OR (FIND-PACKAGE (EVAL (GETF MFE :PACKAGE)))
|
||||
*IL-PACKAGE*))
|
||||
(*PRINT-PRETTY* T)
|
||||
(*PRINT-CASE* :DOWNCASE))
|
||||
(WHEN MFE
|
||||
(PRINT '(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL"))
|
||||
OUTSTREAM))
|
||||
(PRINT (IF MFE
|
||||
(LIST 'IN-PACKAGE (GETF MFE ':PACKAGE))
|
||||
'(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL")))
|
||||
OUTSTREAM)
|
||||
(TERPRI OUTSTREAM)
|
||||
(WHEN *EXPORTED-IL-SYMBOLS*
|
||||
(PRINT (MAKE-EXPORT-FORM *EXPORTED-IL-SYMBOLS*)
|
||||
OUTSTREAM)
|
||||
(TERPRI OUTSTREAM))
|
||||
(DOLIST (FORM CONVERTED-FILE-LIST)
|
||||
(WHEN FORM
|
||||
(PRINT FORM OUTSTREAM)
|
||||
(TERPRI OUTSTREAM)))))))
|
||||
|
||||
(DEFUN CONVERT-ONE-FILECOM (COM)
|
||||
(UNLESS (CONSP COM)
|
||||
(ERROR "Invalid filecom: ~s" COM))
|
||||
(LET (
|
||||
(IL:* IL:|;;| "We bind these for the warnings mechanism in case the filecom type is unknown... They'll be rebound lower down.")
|
||||
|
||||
(*CURRENT-EXPRESSION* COM)
|
||||
(*CURRENT-DEFINITION* (CAR COM))
|
||||
(*CURRENT-DEFINITION-TYPE* "Filecom")
|
||||
(*WARNINGS-MADE* NIL)
|
||||
(CONVERTER (GET (CAR COM)
|
||||
'CONVERT-COM))
|
||||
|
||||
(IL:* IL:|;;| "FILEVARS are handled at this level, except in PROP and IFPROP coms.")
|
||||
|
||||
(FILEVAR-P (AND (EQ (SECOND COM)
|
||||
'IL:*)
|
||||
(NOT (MEMBER (FIRST COM)
|
||||
' (IL:* IL:PROP IL:IFPROP))))))
|
||||
(FUNCALL (OR CONVERTER 'CONVERT-UNKNOWN-COM)
|
||||
(IF CONVERTER
|
||||
(IF FILEVAR-P
|
||||
(IL:EVAL (THIRD COM))
|
||||
(CDR COM))
|
||||
COM))))
|
||||
|
||||
(DEFUN EXPURGATE-EXTRANEOUS-PROGNS (FORMS-LIST)
|
||||
(LET (RESULT)
|
||||
(DOLIST (FORM FORMS-LIST)
|
||||
(SETQ RESULT (NCONC RESULT (IF (AND (CONSP FORM)
|
||||
(EQ (CAR FORM)
|
||||
'PROGN))
|
||||
(EXPURGATE-EXTRANEOUS-PROGNS (CDR FORM))
|
||||
(CONS FORM NIL)))))
|
||||
RESULT))
|
||||
|
||||
(DEFUN REORDER-FILECOMS (COMS-LIST)
|
||||
(LET (EARLY-LIST LATE-LIST)
|
||||
(LABELS ((EARLY-P (COM)
|
||||
(AND (CONSP COM)
|
||||
(OR (MEMBER (CAR COM)
|
||||
'(IL:CONSTANTS IL:MACROS))
|
||||
(AND (MEMBER (CAR COM)
|
||||
'(IL:DECLARE\:))
|
||||
(SOME #'EARLY-P (CDR COM)))))))
|
||||
(DOLIST (COM COMS-LIST)
|
||||
(IF (EARLY-P COM)
|
||||
(PUSH COM EARLY-LIST)
|
||||
(PUSH COM LATE-LIST)))
|
||||
(NCONC (NREVERSE EARLY-LIST)
|
||||
(NREVERSE LATE-LIST)))))
|
||||
|
||||
(DEFUN MAKE-EXPORT-FORM (LIST-OF-SYMBOLS)
|
||||
(LET (SORTED)
|
||||
(DOLIST (S LIST-OF-SYMBOLS)
|
||||
(LET ((A (ASSOC (SYMBOL-PACKAGE S)
|
||||
SORTED)))
|
||||
(IF A
|
||||
(PUSH S (CDR A))
|
||||
(PUSH (CONS (SYMBOL-PACKAGE S)
|
||||
(LIST S))
|
||||
SORTED))))
|
||||
(CONS 'PROGN (MAPCAR #'(LAMBDA (P)
|
||||
`(EXPORT (MAPCAR 'INTERN ',(MAPCAR 'STRING (CDR P))
|
||||
',(PACKAGE-NAME (CAR P)))))
|
||||
SORTED))))
|
||||
|
||||
(DEFPARAMETER *WALKER-TEMPLATES*
|
||||
'(BLOCK (NIL NIL REPEAT (EVAL))
|
||||
CATCH
|
||||
(NIL EVAL REPEAT (EVAL))
|
||||
CHECK-TYPE
|
||||
(NIL EVAL REPEAT (NIL))
|
||||
COMPILER-LET
|
||||
(NIL (REPEAT (NIL EVAL))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
DECLARE
|
||||
(REPEAT (NIL))
|
||||
EVAL-WHEN
|
||||
(NIL QUOTE REPEAT (EVAL))
|
||||
FLET
|
||||
(NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
FUNCTION
|
||||
(NIL CALL)
|
||||
GO
|
||||
(NIL QUOTE)
|
||||
IF
|
||||
(NIL REPEAT (EVAL))
|
||||
LABELS
|
||||
(NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
LAMBDA
|
||||
(NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||
LET
|
||||
(NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
LET*
|
||||
(NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
LOCALLY
|
||||
(NIL REPEAT (EVAL))
|
||||
MACROLET
|
||||
(NIL (REPEAT ((NIL NIL REPEAT (EVAL))))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
MULTIPLE-VALUE-CALL
|
||||
(NIL EVAL REPEAT (EVAL))
|
||||
MULTIPLE-VALUE-LIST
|
||||
(NIL EVAL)
|
||||
MULTIPLE-VALUE-PROG1
|
||||
(NIL RETURN REPEAT (EVAL))
|
||||
MULTIPLE-VALUE-SETQ
|
||||
(NIL (REPEAT (SET))
|
||||
EVAL)
|
||||
MULTIPLE-VALUE-BIND
|
||||
(NIL BINDING-CONTOUR (REPEAT (SET))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
IL:NLSETQ
|
||||
(NIL REPEAT (EVAL))
|
||||
PROGN
|
||||
(NIL REPEAT (EVAL))
|
||||
PROGV
|
||||
(NIL EVAL EVAL REPEAT (EVAL))
|
||||
QUOTE
|
||||
(NIL QUOTE)
|
||||
RETURN-FROM
|
||||
(NIL QUOTE REPEAT (RETURN))
|
||||
SETQ
|
||||
(NIL REPEAT (SET EVAL))
|
||||
SETF
|
||||
(NIL REPEAT (SET EVAL))
|
||||
TAGBODY
|
||||
(NIL REPEAT (EVAL))
|
||||
THE
|
||||
(NIL QUOTE EVAL)
|
||||
THROW
|
||||
(NIL EVAL EVAL)
|
||||
UNLESS
|
||||
(NIL REPEAT (EVAL))
|
||||
UNWIND-PROTECT
|
||||
(NIL RETURN REPEAT (EVAL))
|
||||
WHEN
|
||||
(NIL REPEAT (EVAL))
|
||||
DO
|
||||
(NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
|
||||
(EVAL EVAL)
|
||||
REPEAT
|
||||
(EVAL))
|
||||
DO*
|
||||
(NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
|
||||
(EVAL EVAL)
|
||||
REPEAT
|
||||
(EVAL))
|
||||
DOLIST
|
||||
(NIL (NIL EVAL)
|
||||
REPEAT
|
||||
(EVAL))
|
||||
DOTIMES
|
||||
(NIL (NIL EVAL)
|
||||
REPEAT
|
||||
(EVAL))
|
||||
PROG
|
||||
(NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
PROG*
|
||||
(NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
COND
|
||||
(NIL REPEAT ((TEST REPEAT (EVAL))))
|
||||
DEFINE-SETF-METHOD
|
||||
(NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||
DEFUN
|
||||
(NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||
DEFMACRO
|
||||
(NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||
CASE
|
||||
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||
ECASE
|
||||
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||
TYPECASE
|
||||
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||
ETYPECASE
|
||||
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||
XCL:DEFDEFINER
|
||||
(NIL NIL NIL NIL REPEAT (EVAL))
|
||||
INCF
|
||||
(NIL EVAL EVAL)
|
||||
DECF
|
||||
(NIL EVAL EVAL)
|
||||
WITH-INPUT-FROM-STRING
|
||||
(NIL (NIL EVAL REPEAT (EVAL))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
WITH-OUTPUT-TO-STRING
|
||||
(NIL (NIL EVAL)
|
||||
REPEAT
|
||||
(EVAL))
|
||||
WITH-OPEN-FILE
|
||||
(NIL (NIL REPEAT (EVAL))
|
||||
REPEAT
|
||||
(EVAL))
|
||||
LOOP
|
||||
(NIL REPEAT (EVAL))
|
||||
POP
|
||||
(NIL EVAL)
|
||||
PUSH
|
||||
(NIL EVAL EVAL)
|
||||
PUSHNEW
|
||||
(NIL EVAL EVAL REPEAT EVAL)))
|
||||
|
||||
(DEFUN GET-WALKER-TEMPLATE (FN)
|
||||
(GETF *WALKER-TEMPLATES* FN NIL))
|
||||
|
||||
(DEFUN WALK-FORM-INTERNAL (FORM &AUX NEWFORM NEWNEWFORM WALK-NO-MORE-P MACROP FN TEMPLATE)
|
||||
(COND
|
||||
((ATOM FORM)
|
||||
(WHEN (AND (SYMBOLP FORM)
|
||||
(NOT (NULL *CURRENT-FREE-REFERENCES*))
|
||||
(NOT (KEYWORDP FORM))
|
||||
(NOT (MEMBER FORM '(T NIL)))
|
||||
(NULL (ASSOC FORM *LOCALS*)))
|
||||
|
||||
(IL:* IL:|;;| "Almost certainly a free ref. Note for later analysis.")
|
||||
|
||||
(PUSHNEW FORM *CURRENT-FREE-REFERENCES*))
|
||||
FORM)
|
||||
((SETQ TEMPLATE (GET-WALKER-TEMPLATE (SETQ FN (CAR FORM))))
|
||||
(IF (SYMBOLP TEMPLATE)
|
||||
(FUNCALL TEMPLATE FORM)
|
||||
(WALK-TEMPLATE FORM TEMPLATE)))
|
||||
((AND (SYMBOLP FN)
|
||||
(OR (GET FN 'CONVERT-FORM)
|
||||
(EQ (CAR (GET FN 'IL:CLISPWORD))
|
||||
'IL:FORWORD)))
|
||||
(CONVERT FORM))
|
||||
((AND (SYMBOLP FN)
|
||||
(MACRO-FUNCTION FN))
|
||||
(LET ((*CURRENT-EXPRESSION* FORM))
|
||||
(WARN "Macro form ~s not translated" FN))
|
||||
FORM)
|
||||
((AND (SYMBOLP FN)
|
||||
(NOT (FBOUNDP FN))
|
||||
(SPECIAL-FORM-P FN))
|
||||
(UNKNOWN-MACRO-FORM FORM))
|
||||
(T
|
||||
(IL:* IL:|;;| "Otherwise, walk the form as if its just a standard ")
|
||||
|
||||
(IL:* IL:|;;| "functioncall using a template for standard function")
|
||||
|
||||
(IL:* IL:|;;| "call.")
|
||||
|
||||
(WALK-TEMPLATE FORM '(CALL REPEAT (EVAL))))))
|
||||
|
||||
(DEFUN WALK-TEMPLATE (FORM TEMPLATE)
|
||||
(IF (ATOM TEMPLATE)
|
||||
(ECASE TEMPLATE
|
||||
((EVAL SET FUNCTION TEST EFFECT RETURN)
|
||||
(WHEN *WALKER-FIND-PARAMETER-LIST*
|
||||
(THROW 'PARAMETER-LIST NIL))
|
||||
(WALK-FORM-INTERNAL FORM))
|
||||
((NIL QUOTE) FORM)
|
||||
((BINDING)
|
||||
|
||||
(IL:* IL:|;;| "This should only appear inside (after) a BINDING-CONTOUR...")
|
||||
|
||||
(WHEN (SYMBOLP FORM)
|
||||
|
||||
(IL:* IL:|;;| "Perhaps this should note if FORM is declared special somehow...")
|
||||
|
||||
(PUSH (CONS FORM ':LOCAL)
|
||||
*LOCALS*)
|
||||
(PUSHNEW FORM *CURRENT-LOCALS*))
|
||||
FORM)
|
||||
((LAMBDA CALL) (COND
|
||||
((SYMBOLP FORM)
|
||||
(UNLESS (NULL *CURRENT-FUNCTION-CALLS*)
|
||||
(PUSHNEW FORM *CURRENT-FUNCTION-CALLS*))
|
||||
FORM)
|
||||
(T
|
||||
(IL:* IL:|;;| "Have we a \"#'foo\" here?")
|
||||
|
||||
(WHEN (AND (CONSP FORM)
|
||||
(EQ (CAR FORM)
|
||||
'FUNCTION)
|
||||
(NULL (CDDR FORM))
|
||||
(SYMBOLP (SECOND FORM)))
|
||||
|
||||
(IL:* IL:|;;| "Record it if we do...")
|
||||
|
||||
(PUSHNEW (SECOND FORM)
|
||||
*CURRENT-FUNCTION-CALLS*))
|
||||
(WALK-FORM-INTERNAL FORM))))
|
||||
((NAME)
|
||||
(WHEN (NULL *CURRENT-FUNCTION-CALLS*)
|
||||
|
||||
(IL:* IL:|;;| "Don't record name in a nested def, if we ever see one.")
|
||||
|
||||
(SETQ *CURRENT-DEFINITION* FORM)
|
||||
(PUSH FORM *CURRENT-FUNCTION-CALLS*)
|
||||
(PUSH FORM *CURRENT-FREE-REFERENCES*))
|
||||
FORM)
|
||||
((PARAMETER) (IF (SYMBOLP FORM)
|
||||
(WALK-TEMPLATE FORM 'BINDING)
|
||||
(WALK-TEMPLATE FORM '(BINDING EVAL REPEAT (BINDING)))))
|
||||
((PARAMETER-LIST)
|
||||
(WHEN *WALKER-FIND-PARAMETER-LIST*
|
||||
|
||||
(IL:* IL:|;;| "Some code-analysis stuff uses this.")
|
||||
|
||||
(THROW 'PARAMETER-LIST FORM))
|
||||
(WALK-TEMPLATE FORM '(REPEAT (PARAMETER)))))
|
||||
(CASE (CAR TEMPLATE)
|
||||
(REPEAT (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE)
|
||||
|
||||
(IL:* IL:|;;| "For the case where nothing happens")
|
||||
|
||||
(IL:* IL:|;;| "after the repeat optimize out the")
|
||||
|
||||
(IL:* IL:|;;| "call to length.")
|
||||
|
||||
(IF (NULL (CDDR TEMPLATE))
|
||||
NIL
|
||||
(NTHCDR (- (LENGTH FORM)
|
||||
(LENGTH (CDDR TEMPLATE)))
|
||||
FORM))))
|
||||
(IF (WALK-TEMPLATE FORM (IF (IF (LISTP (CADR TEMPLATE))
|
||||
(EVAL (CADR TEMPLATE))
|
||||
(FUNCALL (CADR TEMPLATE)
|
||||
FORM))
|
||||
(CADDR TEMPLATE)
|
||||
(CADDDR TEMPLATE))))
|
||||
(BINDING-CONTOUR (LET ((*LOCALS* *LOCALS*))
|
||||
(WALK-TEMPLATE FORM (CDR TEMPLATE))))
|
||||
(REMOTE (WALK-TEMPLATE FORM (CADR TEMPLATE)))
|
||||
(WARN
|
||||
(WARN (SECOND TEMPLATE))
|
||||
(IF (NULL (CDDR TEMPLATE))
|
||||
FORM
|
||||
(WALK-TEMPLATE FORM (CDDR TEMPLATE))))
|
||||
(OTHERWISE (COND
|
||||
((ATOM FORM)
|
||||
FORM)
|
||||
(T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
|
||||
(CAR TEMPLATE))
|
||||
(WALK-TEMPLATE (CDR FORM)
|
||||
(CDR TEMPLATE)))))))))
|
||||
|
||||
(DEFUN WALK-TEMPLATE-HANDLE-REPEAT (FORM TEMPLATE STOP-FORM)
|
||||
(IF (EQ FORM STOP-FORM)
|
||||
(WALK-TEMPLATE FORM (CDR TEMPLATE))
|
||||
(WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
|
||||
STOP-FORM)))
|
||||
|
||||
(DEFUN WALK-TEMPLATE-HANDLE-REPEAT-1 (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM)
|
||||
(COND
|
||||
((NULL FORM)
|
||||
NIL)
|
||||
((EQ FORM STOP-FORM)
|
||||
(IF (NULL REPEAT-TEMPLATE)
|
||||
(WALK-TEMPLATE STOP-FORM (CDR TEMPLATE))
|
||||
(ERROR
|
||||
"While handling repeat:
|
||||
~%~Ran into stop while still in repeat template.")))
|
||||
((NULL REPEAT-TEMPLATE)
|
||||
(WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
|
||||
STOP-FORM))
|
||||
(T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
|
||||
(CAR REPEAT-TEMPLATE))
|
||||
(WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM)
|
||||
TEMPLATE
|
||||
(CDR REPEAT-TEMPLATE)
|
||||
STOP-FORM)))))
|
||||
|
||||
(DEFUN WALK-REPEAT-EVAL (FORM ENV)
|
||||
(AND FORM (RECONS FORM (WALK-FORM-INTERNAL (CAR FORM))
|
||||
(WALK-REPEAT-EVAL (CDR FORM)))))
|
||||
|
||||
(DEFUN RECONS (X CAR CDR)
|
||||
(IF (OR (NOT (EQ (CAR X)
|
||||
CAR))
|
||||
(NOT (EQ (CDR X)
|
||||
CDR)))
|
||||
(CONS CAR CDR)
|
||||
X))
|
||||
|
||||
(DEFUN RELIST (X &REST ARGS)
|
||||
(RELIST-INTERNAL X ARGS NIL))
|
||||
|
||||
(DEFUN RELIST* (X &REST ARGS)
|
||||
(RELIST-INTERNAL X ARGS 'T))
|
||||
|
||||
(DEFUN RELIST-INTERNAL (X ARGS *P)
|
||||
(IF (NULL (CDR ARGS))
|
||||
(IF *P
|
||||
(CAR ARGS)
|
||||
(LIST (CAR ARGS)))
|
||||
(RECONS X (CAR ARGS)
|
||||
(RELIST-INTERNAL (CDR X)
|
||||
(CDR ARGS)
|
||||
*P))))
|
||||
|
||||
(DEFVAR *GETVALUE-TRANSLATION* :SLOT-VALUE)
|
||||
|
||||
(DEFVAR *CURRENT-DEFINITION*)
|
||||
|
||||
(DEFVAR *CURRENT-DEFINITION-TYPE*)
|
||||
|
||||
(DEFVAR *CURRENT-EXPRESSION*)
|
||||
|
||||
(DEFVAR *CURRENT-LOCALS* NIL)
|
||||
|
||||
(DEFVAR *FILE-CONTEXT* NIL)
|
||||
|
||||
(DEFVAR *WALKER-FIND-PARAMETER-LIST* NIL)
|
||||
|
||||
(DEFVAR *WARNINGS-MADE* NIL)
|
||||
|
||||
(DEFVAR *PACKAGE-FOR-IL-SYMBOLS* NIL)
|
||||
|
||||
(DEFVAR *PACKAGE-FOR-RESULT-FILE* "CL")
|
||||
|
||||
(DEFVAR *PARAMETERS-ALWAYS-OPTIONAL* NIL)
|
||||
|
||||
(DEFVAR *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE* NIL)
|
||||
|
||||
(DEFVAR *UNKNOWN-MACRO-ACTION* :UM-WARN)
|
||||
|
||||
(DEFVAR *ALWAYS-INCLUDE-PROPS* NIL)
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
|
||||
(IL:PUTPROPS IL:IL-CONVERT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "IL-CONVERT" :BASE
|
||||
10))
|
||||
|
||||
(IL:PUTPROPS IL:IL-CONVERT IL:FILETYPE :COMPILE-FILE)
|
||||
)
|
||||
(IL:PUTPROPS IL:IL-CONVERT IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
1
lispusers/MIGRATION/IL-CONVERT.LCOM
Normal file
1
lispusers/MIGRATION/IL-CONVERT.LCOM
Normal file
File diff suppressed because one or more lines are too long
420
lispusers/MIGRATION/IL-LOOPS
Normal file
420
lispusers/MIGRATION/IL-LOOPS
Normal file
@@ -0,0 +1,420 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "26-Jan-90 10:12:33" {DSK}/users/welch/migration/IL-LOOPS.;8 28689
|
||||
|
||||
changes to%: (FUNCTIONS IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::GetValue IL-CONVERT::_Super)
|
||||
|
||||
previous date%: "25-Jan-90 14:14:46" {DSK}/users/welch/migration/IL-LOOPS.;6)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1989, 1990 by Savoir, Inc.. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT IL-LOOPSCOMS)
|
||||
|
||||
(RPAQQ IL-LOOPSCOMS
|
||||
((FUNCTIONS IL-CONVERT::@ IL-CONVERT::_ IL-CONVERT::$ IL-CONVERT::_! IL-CONVERT::_Super
|
||||
IL-CONVERT::_Super? IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
|
||||
IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER IL-CONVERT::CONVERT-CLASSES
|
||||
IL-CONVERT::CONVERT-METHODS IL-CONVERT::CONVERT-ONE-CLASS
|
||||
IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::Class
|
||||
IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||
IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER
|
||||
IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER IL-CONVERT::GETFROMIV-ACCESSOR-WRITER
|
||||
IL-CONVERT::GetValue)
|
||||
(PROP IL-CONVERT::CONVERT-COM CLASSES METHODS)
|
||||
(PROP IL-CONVERT::ACCESSOR-WRITER EveryFetch FFGetFromIV FFSendSelf FirstFetch GetFromIV
|
||||
AVSendSelf)))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::@ (&REST IL-CONVERT::ARGS)
|
||||
(LET [(IL-CONVERT::EXPANSION (Parse@ IL-CONVERT::ARGS
|
||||
'IV]
|
||||
(OR (AND IL-CONVERT::EXPANSION (IL-CONVERT:CONVERT
|
||||
IL-CONVERT::EXPANSION)
|
||||
)
|
||||
(PROGN (CL:WARN "Unrecognizable @ form")
|
||||
IL-CONVERT::*CURRENT-EXPRESSION*))))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_ (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
|
||||
`(,IL-CONVERT::METH ,(IL-CONVERT:CONVERT IL-CONVERT::INST)
|
||||
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::$ (IL-CONVERT::NAME)
|
||||
(LET ((IL-CONVERT::REC ($! IL-CONVERT::NAME)))
|
||||
(CL:IF (Class? IL-CONVERT::REC)
|
||||
`[,(IL-CONVERT::MAKE-FAKE-SYMBOL "FIND-CLASS")
|
||||
',(IL-CONVERT:CONVERT IL-CONVERT::NAME]
|
||||
(PROGN (CL:WARN
|
||||
"$ form doesn't refer to a known class"
|
||||
)
|
||||
IL-CONVERT::*CURRENT-EXPRESSION*))))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_! (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
|
||||
`(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::METH)
|
||||
,(IL-CONVERT:CONVERT IL-CONVERT::INST)
|
||||
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super (&OPTIONAL IL-CONVERT::OBJ IL-CONVERT::SEL &REST
|
||||
IL-CONVERT::ARGS)
|
||||
(DECLARE (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL))
|
||||
(CONS (IL-CONVERT::MAKE-FAKE-SYMBOL "CALL-NEXT-METHOD"
|
||||
)
|
||||
(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super? (IL-CONVERT::OBJ IL-CONVERT::SEL &REST
|
||||
IL-CONVERT::ARGS)
|
||||
(DECLARE (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL)
|
||||
)
|
||||
`[AND (,(IL-CONVERT::MAKE-FAKE-SYMBOL "NEXT-METHOD-P"
|
||||
))
|
||||
(,(IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||
"CALL-NEXT-METHOD")
|
||||
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS])
|
||||
|
||||
(CL:DEFUN IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
|
||||
IL-CONVERT::CLASS-NAME)
|
||||
(DECLARE (CL:DECLARATION CL:VALUES)
|
||||
(CL:VALUES IL-CONVERT::SLOT-SPEC &REST IL-CONVERT::AUX-DEFS))
|
||||
(CASE IL-CONVERT::*GETVALUE-TRANSLATION*
|
||||
(:SLOT-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
|
||||
(CL:WARN "Active value in SLOT-VALUE GetValue mode")
|
||||
IL-CONVERT::OBJ))
|
||||
(:ACCESSOR (CASE (ClassName IL-CONVERT::OBJ)
|
||||
(ExplicitFnActiveValue (IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||
IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
|
||||
IL-CONVERT::CLASS-NAME))
|
||||
(CL:OTHERWISE
|
||||
[LET* ((IL-CONVERT::GM (GetIt (Class IL-CONVERT::OBJ)
|
||||
'GetWrappedValue NIL 'METHOD))
|
||||
[IL-CONVERT::GMCLASS (CL:SECOND (GETDEF IL-CONVERT::GM 'METHODS]
|
||||
(IL-CONVERT::PM (GetIt (Class IL-CONVERT::OBJ)
|
||||
'PutWrappedValue NIL 'METHOD))
|
||||
(IL-CONVERT::PMCLASS (CL:SECOND (GETDEF IL-CONVERT::PM 'METHODS]
|
||||
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
|
||||
(CL:WARN "Unconvertable ~a in defclass" (ClassName IL-CONVERT::OBJ)))
|
||||
IL-CONVERT::OBJ)))
|
||||
(:ACTIVE-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
|
||||
(CL:WARN "Active value emulator not written yet")
|
||||
IL-CONVERT::OBJ))))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||
IL-CONVERT::LOCALSTATE)
|
||||
[IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)])
|
||||
|
||||
(CL:DEFUN IL-CONVERT::CONVERT-CLASSES (IL-CONVERT::CS)
|
||||
(IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::CS))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::CONVERT-METHODS (IL-CONVERT::MS)
|
||||
(CONS 'PROGN (IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::MS)))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::CONVERT-ONE-CLASS (IL-CONVERT::C)
|
||||
""
|
||||
[LET*
|
||||
((IL-CONVERT::SRC (_ [OR ($! IL-CONVERT::C)
|
||||
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::C))
|
||||
(CL:WARN "Class not found")
|
||||
(CL:RETURN-FROM IL-CONVERT::CONVERT-ONE-CLASS
|
||||
(LIST '* ';; (CL:FORMAT NIL "Class ~a not found."
|
||||
IL-CONVERT::C]
|
||||
MakeFileSource))
|
||||
(IL-CONVERT::CLASSNAME (IL-CONVERT:CONVERT (CL:SECOND IL-CONVERT::SRC)))
|
||||
(IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::CLASSNAME)
|
||||
(IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Class")
|
||||
(IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::CLASSNAME))
|
||||
(IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::CLASSNAME))
|
||||
(IL-CONVERT::ATTRIBUTES (CDDR IL-CONVERT::SRC))
|
||||
(IL-CONVERT::META (CDR (CL:ASSOC 'MetaClass IL-CONVERT::ATTRIBUTES)))
|
||||
(IL-CONVERT::SUPERS (CDR (CL:ASSOC 'Supers IL-CONVERT::ATTRIBUTES)))
|
||||
(IL-CONVERT::CVS (CDR (CL:ASSOC 'ClassVariables IL-CONVERT::ATTRIBUTES)))
|
||||
(IL-CONVERT::IVS (CDR (CL:ASSOC 'InstanceVariables IL-CONVERT::ATTRIBUTES)))
|
||||
IL-CONVERT::PROPS-ALIST IL-CONVERT::AUX-DEFS)
|
||||
(CL:LABELS
|
||||
([IL-CONVERT::LOOPS-CONVERT (IL-CONVERT::X)
|
||||
(COND
|
||||
[(Class? IL-CONVERT::X)
|
||||
`(IL-CONVERT::FIND-CLASS ',(IL-CONVERT:CONVERT (_ IL-CONVERT::X ClassName)]
|
||||
((AnnotatedValue? IL-CONVERT::X)
|
||||
(IL-CONVERT::AV-CONVERT IL-CONVERT::X))
|
||||
((CL:CONSP IL-CONVERT::X)
|
||||
(CL:MAPCAR #'IL-CONVERT::LOOPS-CONVERT IL-CONVERT::X))
|
||||
((Instance? IL-CONVERT::X)
|
||||
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::X))
|
||||
(CL:WARN "Unconvertable LOOPS object in defclass"))
|
||||
IL-CONVERT::X)
|
||||
(T (IL-CONVERT:CONVERT IL-CONVERT::X]
|
||||
(IL-CONVERT::AV-CONVERT (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ)
|
||||
(CL:SETQ IL-CONVERT::OBJ (fetch annotatedValue of IL-CONVERT::OBJ))
|
||||
(LET [(CL:VALUES (CL:MULTIPLE-VALUE-LIST (IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
|
||||
IL-CONVERT::NAME IL-CONVERT::DOC
|
||||
IL-CONVERT::OBJ IL-CONVERT::CLASSNAME]
|
||||
(CL:SETQ IL-CONVERT::AUX-DEFS (NCONC IL-CONVERT::AUX-DEFS (CDR CL:VALUES)))
|
||||
(CAR CL:VALUES)))
|
||||
(IL-CONVERT::PROCESS-IV
|
||||
(IL-CONVERT::SPEC &OPTIONAL IL-CONVERT::ALLOC &AUX IL-CONVERT::DOC)
|
||||
(LET* [(IL-CONVERT::NAME (IL-CONVERT:CONVERT (CL:FIRST IL-CONVERT::SPEC)))
|
||||
(IL-CONVERT::OBJ (CL:SECOND IL-CONVERT::SPEC))
|
||||
(IL-CONVERT::DOC (CL:GETF (CDDR IL-CONVERT::SPEC)
|
||||
'doc))
|
||||
[IL-CONVERT::CONVERSION (CL:IF (type? annotatedValue IL-CONVERT::OBJ)
|
||||
(IL-CONVERT::AV-CONVERT IL-CONVERT::NAME IL-CONVERT::DOC
|
||||
IL-CONVERT::OBJ)
|
||||
`[,IL-CONVERT::NAME
|
||||
,@[AND (CDR IL-CONVERT::SPEC)
|
||||
`(:INITFORM ,(IL-CONVERT::LOOPS-CONVERT
|
||||
IL-CONVERT::OBJ]
|
||||
:INITARG
|
||||
,(CL:INTERN (STRING (CL:FIRST IL-CONVERT::SPEC))
|
||||
*KEYWORD-PACKAGE*)
|
||||
,@[AND IL-CONVERT::ALLOC `(:ALLOCATION
|
||||
,IL-CONVERT::ALLOC]
|
||||
,@(AND IL-CONVERT::DOC `(:DOCUMENTATION ,IL-CONVERT::DOC])
|
||||
]
|
||||
(IL-CONVERT::PROPS (CL:COPY-LIST (CL:IF IL-CONVERT::DOC
|
||||
(AND (CDDR (CDDR IL-CONVERT::SPEC))
|
||||
(CDDR IL-CONVERT::SPEC))
|
||||
(CDDR IL-CONVERT::SPEC))]
|
||||
|
||||
(* ;; "The following (when not quoted) fails to compile, for some reason:")
|
||||
|
||||
'(CL:REMF IL-CONVERT::PROPS 'doc)
|
||||
(CL:WHEN IL-CONVERT::PROPS
|
||||
(CL:PUSH (CONS IL-CONVERT::NAME IL-CONVERT::PROPS)
|
||||
IL-CONVERT::PROPS-ALIST))
|
||||
IL-CONVERT::CONVERSION)))
|
||||
(LET [(IL-CONVERT::FORM `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFCLASS")
|
||||
,IL-CONVERT::CLASSNAME
|
||||
,(IL-CONVERT::MAPCONVERT IL-CONVERT::SUPERS)
|
||||
[,@(CL:REMOVE-IF 'NULL (CL:MAPCAR #'IL-CONVERT::PROCESS-IV
|
||||
IL-CONVERT::IVS))
|
||||
,@(CL:REMOVE-IF 'NULL (for IL-CONVERT::CV in IL-CONVERT::CVS
|
||||
collect (IL-CONVERT::PROCESS-IV
|
||||
IL-CONVERT::CV :CLASS)))
|
||||
,@(AND (OR IL-CONVERT::PROPS-ALIST IL-CONVERT::*ALWAYS-INCLUDE-PROPS*
|
||||
)
|
||||
`(IL-CONVERT::.PROPS-ALIST. :INITFORM '
|
||||
,
|
||||
IL-CONVERT::PROPS-ALIST
|
||||
]
|
||||
,@(CL:UNLESS (EQ (CAR IL-CONVERT::META)
|
||||
'Class)
|
||||
[LET [(IL-CONVERT::*CURRENT-EXPRESSION* (IL-CONVERT:CONVERT
|
||||
(CAR IL-CONVERT::META]
|
||||
(CL:WARN "Metaclass might be incorrect")
|
||||
`(:METACLASS ,IL-CONVERT::*CURRENT-EXPRESSION*])]
|
||||
(CL:IF IL-CONVERT::AUX-DEFS
|
||||
`(PROGN ,IL-CONVERT::FORM ,.IL-CONVERT::AUX-DEFS)
|
||||
IL-CONVERT::FORM)])
|
||||
|
||||
(CL:DEFUN IL-CONVERT::CONVERT-ONE-METHOD (IL-CONVERT::M)
|
||||
(LET* ((IL-CONVERT::METHOD-BODY (\DEFINE-TYPE-GETDEF IL-CONVERT::M 'METHOD-FNS))
|
||||
[IL-CONVERT::METHOD-CLASS (CL:FIRST (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
|
||||
[IL-CONVERT::METHOD-SELECTOR (CL:SECOND (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
|
||||
(IL-CONVERT::METHOD-ARGS (CDR (CL:SECOND IL-CONVERT::METHOD-BODY)))
|
||||
(IL-CONVERT::METHOD-FNBODY (CDDR IL-CONVERT::METHOD-BODY))
|
||||
(IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::M)
|
||||
(IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Function")
|
||||
(IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::M))
|
||||
(IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::M))
|
||||
(IL-CONVERT::*SELF-VARIABLE* (CL:FIRST IL-CONVERT::METHOD-ARGS)))
|
||||
(DECLARE (CL:SPECIAL IL-CONVERT::*SELF-VARIABLE*))
|
||||
(CL:VALUES [CL:MULTIPLE-VALUE-BIND (IL-CONVERT::NEW-VARLST IL-CONVERT::VARNAMES)
|
||||
(IL-CONVERT::EXPAND-VARLIST IL-CONVERT::METHOD-ARGS)
|
||||
[LET ((IL-CONVERT::*LOCALS* (CL:COPY-LIST IL-CONVERT::VARNAMES)))
|
||||
(CL:WHEN (AND (CDR IL-CONVERT::NEW-VARLST)
|
||||
IL-CONVERT::*PARAMETERS-ALWAYS-OPTIONAL*)
|
||||
(CL:PUSH '&OPTIONAL (CDR IL-CONVERT::NEW-VARLST)))]
|
||||
`(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::DEFMETHOD)
|
||||
,IL-CONVERT::METHOD-SELECTOR
|
||||
[(,(CL:FIRST IL-CONVERT::NEW-VARLST)
|
||||
,IL-CONVERT::METHOD-CLASS)
|
||||
,@(CDR IL-CONVERT::NEW-VARLST)
|
||||
,@(AND IL-CONVERT::*ADD-REST-ARG* '(&REST IL-CONVERT::$EXTRA-ARGS$]
|
||||
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::METHOD-FNBODY]
|
||||
(CL:NREVERSE IL-CONVERT::*CURRENT-FUNCTION-CALLS*)
|
||||
(CL:NREVERSE IL-CONVERT::*CURRENT-FREE-REFERENCES*))))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::Class (IL-CONVERT::X)
|
||||
`(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::CLASS-OF)
|
||||
,(IL-CONVERT:CONVERT IL-CONVERT::X)))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||
IL-CONVERT::LOCALSTATE)
|
||||
(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
|
||||
(IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
|
||||
`(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE))
|
||||
(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE)))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC (IL-CONVERT::NAME IL-CONVERT::DOC
|
||||
IL-CONVERT::OBJ
|
||||
IL-CONVERT::CLASS-NAME)
|
||||
|
||||
(* ;; "Old-style AVs done here. ")
|
||||
|
||||
(LET* ((IL-CONVERT::LS (@ IL-CONVERT::OBJ localState))
|
||||
(IL-CONVERT::GF (@ IL-CONVERT::OBJ getFn))
|
||||
(IL-CONVERT::PF (@ IL-CONVERT::OBJ putFn))
|
||||
(IL-CONVERT::CODEWRITER (GET IL-CONVERT::GF 'IL-CONVERT::ACCESSOR-WRITER))
|
||||
IL-CONVERT::DEFS)
|
||||
|
||||
(* ;; " Write the accessor...")
|
||||
|
||||
(CL:UNLESS IL-CONVERT::CODEWRITER
|
||||
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM IL-CONVERT::OBJ
|
||||
)))
|
||||
(CL:WARN "No accessor-writer for ~a" IL-CONVERT::GF)
|
||||
(CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||
IL-CONVERT::*CURRENT-EXPRESSION*)))
|
||||
(LET* [(CL:NAMESTRING (CL:IF (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::NAME)
|
||||
(IL-CONVERT::FAKE-SYMBOL-NAME IL-CONVERT::NAME)
|
||||
(STRING IL-CONVERT::NAME)))
|
||||
[IL-CONVERT::VARNAME (AND (CL:CONSP IL-CONVERT::CODEWRITER)
|
||||
(CDR IL-CONVERT::CODEWRITER)
|
||||
(IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING
|
||||
"!CACHE-FOR-"
|
||||
CL:NAMESTRING]
|
||||
(IL-CONVERT::CODE (CL:FUNCALL (CL:IF (CL:CONSP IL-CONVERT::CODEWRITER)
|
||||
(CAR IL-CONVERT::CODEWRITER)
|
||||
IL-CONVERT::CODEWRITER)
|
||||
IL-CONVERT::VARNAME
|
||||
'self IL-CONVERT::LS))
|
||||
(IL-CONVERT::ACCESSOR (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING
|
||||
"!ACCESSOR-FOR-"
|
||||
CL:NAMESTRING]
|
||||
(CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
|
||||
,IL-CONVERT::ACCESSOR
|
||||
((,(IL-CONVERT::MAKE-FAKE-SYMBOL "SELF")
|
||||
,IL-CONVERT::CLASS-NAME))
|
||||
,IL-CONVERT::CODE)
|
||||
IL-CONVERT::DEFS)
|
||||
|
||||
(* ;; "Look at putfn...")
|
||||
|
||||
(CL:UNLESS (CL:MEMBER IL-CONVERT::PF '(ReplaceMe NoUpdatePermitted))
|
||||
(LET [(IL-CONVERT::CODEWRITER (GET IL-CONVERT::PF 'IL-CONVERT::ACCESSOR-WRITER]
|
||||
(CL:UNLESS IL-CONVERT::CODEWRITER
|
||||
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM
|
||||
IL-CONVERT::OBJ)))
|
||||
(CL:WARN "No accessor-writer for ~a" IL-CONVERT::PF)
|
||||
(CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||
IL-CONVERT::*CURRENT-EXPRESSION*)))
|
||||
(LET ((IL-CONVERT::CODE (CL:FUNCALL IL-CONVERT::CODEWRITER
|
||||
IL-CONVERT::VARNAME 'self IL-CONVERT::LS)))
|
||||
(CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
|
||||
(CL:SETF ,IL-CONVERT::ACCESSOR)
|
||||
((self ,IL-CONVERT::CLASS-NAME))
|
||||
,IL-CONVERT::CODE)
|
||||
IL-CONVERT::DEFS))))
|
||||
|
||||
(* ;; "Make slot spec...")
|
||||
|
||||
(CL:APPLY 'CL:VALUES (* ; "values-list* y'might say")
|
||||
[AND IL-CONVERT::VARNAME
|
||||
`(,IL-CONVERT::VARNAME ,@(AND (EQ IL-CONVERT::PF 'ReplaceMe)
|
||||
`(:WRITER (CL:SETF ,IL-CONVERT::ACCESSOR]
|
||||
IL-CONVERT::DEFS))))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||
IL-CONVERT::LOCALSTATE)
|
||||
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
[CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE]))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||
IL-CONVERT::LOCALSTATE)
|
||||
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
[CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
,(IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)]))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||
IL-CONVERT::LOCALSTATE)
|
||||
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
(CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||
,(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
|
||||
(IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
|
||||
`(CL:FUNCALL ,IL-CONVERT::LOCALSTATE)
|
||||
IL-CONVERT::LOCALSTATE))))
|
||||
|
||||
(CL:DEFUN IL-CONVERT::GETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||
IL-CONVERT::LOCALSTATE)
|
||||
`(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE))
|
||||
|
||||
(IL-CONVERT::IL-DEFCONV IL-CONVERT::GetValue (IL-CONVERT::INST &OPTIONAL IL-CONVERT::VAR
|
||||
IL-CONVERT::PROP)
|
||||
[COND
|
||||
(IL-CONVERT::PROP (LIST (
|
||||
IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||
"SLOT-PROP-VALUE")
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::INST)
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::VAR)
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::PROP)))
|
||||
[IL-CONVERT::VAR
|
||||
(CL:ECASE IL-CONVERT::*GETVALUE-TRANSLATION*
|
||||
(:SLOT-VALUE (LIST
|
||||
IL-CONVERT::*SLOT-VALUE-FAKESYM*
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::INST)
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::VAR)))
|
||||
(:ACCESSOR
|
||||
(CL:IF (AND (CL:CONSP IL-CONVERT::VAR)
|
||||
(EQ (CAR IL-CONVERT::VAR)
|
||||
'QUOTE))
|
||||
(LIST
|
||||
[IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||
(CL:CONCATENATE
|
||||
'STRING "access-"
|
||||
(LET [(IL-CONVERT::NEWNAME
|
||||
(IL-CONVERT:CONVERT
|
||||
(CL:SECOND IL-CONVERT::VAR
|
||||
]
|
||||
(CL:IF (
|
||||
IL-CONVERT::FAKE-SYMBOL-P
|
||||
IL-CONVERT::NEWNAME)
|
||||
(
|
||||
IL-CONVERT::FAKE-SYMBOL-NAME
|
||||
IL-CONVERT::NEWNAME)
|
||||
(CL:SYMBOL-NAME
|
||||
IL-CONVERT::NEWNAME
|
||||
))]
|
||||
(IL-CONVERT:CONVERT IL-CONVERT::INST
|
||||
))
|
||||
(PROGN (CL:WARN
|
||||
"Unquoted IV spec in :ACCESSOR GetValue mode"
|
||||
)
|
||||
|
||||
IL-CONVERT::*CURRENT-EXPRESSION*
|
||||
)))
|
||||
(:ACTIVE-VALUE (IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||
"ACTIVE-VALUE"
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::INST)
|
||||
(IL-CONVERT:CONVERT
|
||||
IL-CONVERT::VAR))))]
|
||||
(T (IL-CONVERT:CONVERT `(GetValue self
|
||||
,IL-CONVERT::INST])
|
||||
|
||||
(PUTPROPS CLASSES IL-CONVERT::CONVERT-COM IL-CONVERT::CONVERT-CLASSES)
|
||||
|
||||
(PUTPROPS METHODS IL-CONVERT::CONVERT-COM IL-CONVERT::CONVERT-METHODS)
|
||||
|
||||
(PUTPROPS EveryFetch IL-CONVERT::ACCESSOR-WRITER IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER)
|
||||
|
||||
(PUTPROPS FFGetFromIV IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER . T))
|
||||
|
||||
(PUTPROPS FFSendSelf IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER . T))
|
||||
|
||||
(PUTPROPS FirstFetch IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER . T))
|
||||
|
||||
(PUTPROPS GetFromIV IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER))
|
||||
|
||||
(PUTPROPS AVSendSelf IL-CONVERT::ACCESSOR-WRITER IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER)
|
||||
(PUTPROPS IL-LOOPS COPYRIGHT ("Savoir, Inc." 1989 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
1
lispusers/MIGRATION/IL-LOOPS.LCOM
Normal file
1
lispusers/MIGRATION/IL-LOOPS.LCOM
Normal file
File diff suppressed because one or more lines are too long
214
lispusers/MIGRATION/IL-RECORD
Normal file
214
lispusers/MIGRATION/IL-RECORD
Normal file
@@ -0,0 +1,214 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "IL-CONVERT" READTABLE "XCL")
|
||||
(IL:FILECREATED "14-Sep-89 10:03:02" IL:|{DSK}/python2/aria/migration/interlisp/IL-RECORD.;2| 21305
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS MAKE-RECORD-ACCESSORS |fetch| |replace| |DO-create|)
|
||||
|
||||
IL:|previous| IL:|date:| " 2-Mar-89 13:12:40" IL:|{DSK}/users/eweaver/convert/IL-RECORD.;4|)
|
||||
|
||||
|
||||
; Copyright (c) 1989 by ENVOS Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:IL-RECORDCOMS)
|
||||
|
||||
(IL:RPAQQ IL:IL-RECORDCOMS ((IL:* IL:\| "chapter 8") (IL:VARIABLES *RECORD-TYPES*) (IL:FUNCTIONS ADD-EXPORTS ASSOCRECORD PROPRECORD ATOMRECORD BLOCKRECORD) (IL:FUNCTIONS ARRAYRECORD DEFINE-ARRAYRECORD-STRUCTURE) (IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)") (IL:FUNCTIONS INTERLISP-COMMENT-P) (IL:FUNCTIONS RECORD) (IL:FUNCTIONS TYPERECORD FLATTEN MAKE-RECORD-ACCESSORS DEFINE-RECORD-STRUCTURE) (IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ") (IL:* IL:|;;| "
|
||||
; this version defines a defstruct which is not really the same
|
||||
; as the IL record type.
|
||||
(defun
|
||||
define-record-structure (record-name record-fields named record-tail)
|
||||
(let* ((name-string (symbol-name record-name))
|
||||
(struct-name (intern name-string))
|
||||
(*current-record-name* record-name)
|
||||
(slots nil))
|
||||
(declare (special *current-record-name*))
|
||||
(setq record-fields (make-true-list record-fields))
|
||||
(do ((fields record-fields (rest fields))
|
||||
field)
|
||||
((null fields) (setq slots (nreverse slots)))
|
||||
(setq field (first fields))
|
||||
(cond
|
||||
((null field )
|
||||
(warn \"NIL as record field name not supported\"))
|
||||
((atom field) (push field slots))
|
||||
((eq (first field) '*)) ;Ignore comments
|
||||
(t (setq slots (append (reverse (flatten field)) slots)))))
|
||||
(setf (gethash struct-name *record-types*) slots)
|
||||
(multiple-value-bind
|
||||
(record-tail-forms record-tail-inits)
|
||||
(process-record-tail record-tail)
|
||||
(add-exports
|
||||
`((defstruct
|
||||
,struct-name
|
||||
(:type list)
|
||||
(:named ,named)
|
||||
,@(mapcar
|
||||
#'(lambda (slot &aux pair)
|
||||
(if (setq pair (assoc slot record-tail-inits))
|
||||
`(,slot ,(cdr pair))
|
||||
slot))
|
||||
slots))
|
||||
,@record-tail-forms)))))
|
||||
") (IL:* IL:|;;| "Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.") (IL:FUNCTIONS PROCESS-RECORD-TAIL) (IL:* IL:|;;| "Define user-created access functions. It doesn't matter if these fields are part of the structure or not. If so, they will redefine the access functions created by defstruct.") (IL:FUNCTIONS ACCESSFNS) (IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))") (IL:FUNCTIONS DATATYPE FIELD-TO-SLOT-TYPE /DECLAREDATATYPE FIND-RECORD-TYPE FIND-RECORD-FIELDS |fetch| |replace| TYPE? |create| |DO-create|) (IL:P (IL-COPYCONV |fetch| FETCH) (IL-COPYCONV |fetch| |ffetch|) (IL-COPYCONV |ffetch| FFETCH) (IL-COPYCONV |replace| REPLACE) (IL-COPYCONV |replace| |freplace|) (IL-COPYCONV |freplace| FREPLACE) (IL-COPYCONV TYPE? |type?|) (IL-COPYCONV |create| CREATE)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-RECORD))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:\| "chapter 8")
|
||||
|
||||
|
||||
(DEFVAR *RECORD-TYPES* (MAKE-HASH-TABLE :SIZE 100))
|
||||
|
||||
(DEFUN ADD-EXPORTS (FORMS &AUX (EXPORT-LIST NIL)) (DOLIST (FORM FORMS) (AND (CONSP FORM) (MEMBER (FIRST FORM) (QUOTE (DEFUN DEFMACRO)) :TEST (FUNCTION EQ)) (PUSH (SECOND FORM) EXPORT-LIST))) (IF EXPORT-LIST (IL:BQUOTE (PROGN (EXPORT (QUOTE (IL:\\\, (REVERSE EXPORT-LIST)))) (IL:\\\,@ FORMS))) (PROGN-IF-NEEDED FORMS)))
|
||||
|
||||
(IL-DEFCONV ASSOCRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ASSOCRECORD not supported") (IL:* IL:|;;| "
|
||||
(setf
|
||||
(gethash record-name *record-types*)
|
||||
(mapcar #'car record-fields))
|
||||
(process-record-tail record-tail)
|
||||
"))
|
||||
|
||||
(IL-DEFCONV PROPRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "PROPRECORD not supported") (IL:* IL:|;;| "
|
||||
(setf
|
||||
(gethash record-name *record-types*)
|
||||
(do ((fields record-fields (rest (rest fields)))
|
||||
(slots nil))
|
||||
((endp fields) (nreverse slots))
|
||||
(push (first fields) slots))
|
||||
(process-record-tail record-tail))
|
||||
"))
|
||||
|
||||
(IL-DEFCONV ATOMRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ATOMRECORD not supported"))
|
||||
|
||||
(IL-DEFCONV BLOCKRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-TAIL)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (WARN "BLOCKRECORD not supported") (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) (SLOTS NIL) FIELD) ((ENDP FIELDS) (SETF (GETHASH RECORD-NAME *RECORD-TYPES*) (IF (BOUNDP (QUOTE *ADD-TO-RECORD-DEFN*)) (APPEND (NREVERSE SLOTS) (GETHASH RECORD-NAME *RECORD-TYPES*)) (NREVERSE SLOTS)))) (SETQ FIELD (FIRST FIELDS)) (WHEN (CONSP FIELD) (SETQ FIELD (FIRST FIELD))) (WHEN (AND FIELD (NOT (INTEGERP FIELD))) (PUSH FIELD SLOTS))) NIL)
|
||||
|
||||
(IL-DEFCONV ARRAYRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DEFINE-ARRAYRECORD-STRUCTURE RECORD-NAME RECORD-FIELDS RECORD-TAIL))
|
||||
|
||||
(DEFUN DEFINE-ARRAYRECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS RECORD-TAIL) (LET ((*CURRENT-RECORD-NAME* RECORD-NAME)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (FIELD-FNS NIL) (INITS NIL) (KEYS NIL) CREATE-FN (LENGTH 0)) (DO ((I 0 (1+ I)) (FIELDS RECORD-FIELDS (REST FIELDS)) FIELD) ((ENDP FIELDS) (SETQ FIELD-FNS (NREVERSE FIELD-FNS)) (SETQ INITS (NREVERSE INITS)) (SETQ KEYS (NREVERSE KEYS))) (IL:* IL:|;;| "Define accessor functions. We don't need to define") (IL:* IL:|;;| "setf methods because the accessors are actually") (IL:* IL:|;;| "macros which generate calls to svref, and setf") (IL:* IL:\; "already knows how to handle svref.") (SETQ FIELD (FIRST FIELDS)) (INCF LENGTH) (COND ((INTEGERP FIELD) (INCF I (1- FIELD)) (INCF LENGTH (1- FIELD))) ((NULL FIELD)) (T (PUSH (IL:BQUOTE (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME FIELD)))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (SVREF (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X))) (IL:\\\, I))))))) FIELD-FNS) (LET ((SVAR (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME FIELD) "-SET")))) (PUSH (IL:BQUOTE (WHEN (IL:\\\, SVAR) (SETF (SVREF $X$ (IL:\\\, I)) (IL:\\\, FIELD)))) INITS) (PUSH (IL:BQUOTE ((IL:\\\, FIELD) (IL:\\\, (CDR (ASSOC FIELD RECORD-TAIL-INITS))) (IL:\\\, SVAR))) KEYS))))) (SETQ CREATE-FN (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ KEYS)) (LET (($X$) (MAKE-ARRAY (IL:\\\, LENGTH))) (IL:\\\,@ INITS) $X$)))) (ADD-EXPORTS (IL:BQUOTE ((IL:\\\, CREATE-FN) (IL:\\\,@ FIELD-FNS) (IL:\\\,@ RECORD-TAIL-FORMS))))))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)")
|
||||
|
||||
|
||||
(DEFUN INTERLISP-COMMENT-P (X) (AND (CONSP X) (EQ (FIRST X) (QUOTE *))))
|
||||
|
||||
(IL-DEFCONV RECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) NIL (REST (REST ARGS))))
|
||||
|
||||
(IL-DEFCONV TYPERECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) T (REST (REST ARGS))))
|
||||
|
||||
(DEFUN FLATTEN (X) (COND ((CONSP X) (APPEND (FLATTEN (CAR X)) (FLATTEN (CDR X)))) ((NULL X) NIL) (T (CONS X NIL))))
|
||||
|
||||
(DEFUN MAKE-RECORD-ACCESSORS (RECORD-NAME TREE PATH) (COND ((NULL TREE) NIL) ((ATOM TREE) (LET ((ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) RECORD-NAME "-" (SYMBOL-NAME TREE))))) (IL:BQUOTE ((DEFSETF (IL:\\\, ACCESSOR-NAME) (X) (VAL) (LIST (QUOTE SETF) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ)))) VAL)) (DEFMACRO (IL:\\\, ACCESSOR-NAME) (X) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ))))))))) ((EQ (CAR TREE) (QUOTE *)) NIL) (T (APPEND (MAKE-RECORD-ACCESSORS RECORD-NAME (CAR TREE) (IL:BQUOTE (CAR (IL:\\\, PATH)))) (MAKE-RECORD-ACCESSORS RECORD-NAME (CDR TREE) (IL:BQUOTE (CDR (IL:\\\, PATH))))))))
|
||||
|
||||
(DEFUN DEFINE-RECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS NAMED RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) (SLOTS (REMOVE-IF (FUNCTION NULL) (FLATTEN RECORD-FIELDS))) (ACCESSORS (MAKE-RECORD-ACCESSORS NAME-STRING RECORD-FIELDS (IF NAMED (QUOTE (CDR T)) T)))) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (ADD-EXPORTS (IL:BQUOTE ((DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT &AUX PAIR) (IF (SETQ PAIR (ASSOC SLOT RECORD-TAIL-INITS :TEST (FUNCTION EQ))) (LIST SLOT (CDR PAIR)) SLOT))) SLOTS))) (IL:\\\, (MAKE-BQ (LET ((FORM (SUBLIS (MAPCAR (FUNCTION (LAMBDA (SLOT) (CONS SLOT (MAKE-MACRO-ARG :ELEMENT SLOT)))) SLOTS) RECORD-FIELDS))) (IF NAMED (CONS RECORD-NAME FORM) FORM))))) (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (COPY-TREE (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X)))))))) (IL:\\\,@ ACCESSORS) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ")
|
||||
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"
|
||||
; this version defines a defstruct which is not really the same
|
||||
; as the IL record type.
|
||||
(defun
|
||||
define-record-structure (record-name record-fields named record-tail)
|
||||
(let* ((name-string (symbol-name record-name))
|
||||
(struct-name (intern name-string))
|
||||
(*current-record-name* record-name)
|
||||
(slots nil))
|
||||
(declare (special *current-record-name*))
|
||||
(setq record-fields (make-true-list record-fields))
|
||||
(do ((fields record-fields (rest fields))
|
||||
field)
|
||||
((null fields) (setq slots (nreverse slots)))
|
||||
(setq field (first fields))
|
||||
(cond
|
||||
((null field )
|
||||
(warn \"NIL as record field name not supported\"))
|
||||
((atom field) (push field slots))
|
||||
((eq (first field) '*)) ;Ignore comments
|
||||
(t (setq slots (append (reverse (flatten field)) slots)))))
|
||||
(setf (gethash struct-name *record-types*) slots)
|
||||
(multiple-value-bind
|
||||
(record-tail-forms record-tail-inits)
|
||||
(process-record-tail record-tail)
|
||||
(add-exports
|
||||
`((defstruct
|
||||
,struct-name
|
||||
(:type list)
|
||||
(:named ,named)
|
||||
,@(mapcar
|
||||
#'(lambda (slot &aux pair)
|
||||
(if (setq pair (assoc slot record-tail-inits))
|
||||
`(,slot ,(cdr pair))
|
||||
slot))
|
||||
slots))
|
||||
,@record-tail-forms)))))
|
||||
")
|
||||
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.")
|
||||
|
||||
|
||||
(DEFUN PROCESS-RECORD-TAIL (RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((SPECS RECORD-TAIL (REST SPECS)) SPEC (FORMS NIL) (INITS NIL)) ((ENDP SPECS) (VALUES FORMS (REVERSE INITS))) (COND ((AND (ATOM (FIRST SPECS)) (REST SPECS) (EQ (SECOND SPECS) (QUOTE IL:_))) (IF (EQ *CURRENT-RECORD-NAME* (FIRST SPECS)) (WARN "implicit CREATE record spec (by assignment to record name) not supported") (PUSH (CONS (FIRST SPECS) (CONVERT (THIRD SPECS))) INITS)) (IL:* IL:|;;| "A \"field-name _ form\" spec is not a list -- it is") (IL:* IL:|;;| "three separate entries in the record-tail.") (POP SPECS) (POP SPECS)) (T (IL:* IL:\; "All others are lists.") (SETQ SPEC (FIRST SPECS)) (CASE (FIRST SPEC) ((IL:CREATE IL:INIT IL:SUBRECORD IL:SYSTEM) (WARN "~:@(~s~) record spec not supported" (FIRST SPEC))) (IL:TYPE? (PUSH (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME *CURRENT-RECORD-NAME*) "-P"))) (DATUM) (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (IL:\\\,@ (MAPCONVERT (REST SPEC)))))) FORMS)) ((IL:ACCESSFNS IL:BLOCKRECORD) (LET ((*ADD-TO-RECORD-DEFN* T)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (SETQ FORMS (APPEND FORMS (LIST (CONVERT SPEC)))))) (T (WARN "unknown record spec ~s ignored" SPEC)))))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Define user-created access functions. It doesn't matter if these fields are part of the structure or not. If so, they will redefine the access functions created by defstruct."
|
||||
)
|
||||
|
||||
|
||||
(IL-DEFCONV ACCESSFNS (RECORD-NAME &OPTIONAL RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DECLARE (SPECIAL *LOCALS*)) (IL:* IL:|;;| "The manual says the record name is the first argument, but it appears that sometimes it is missing when this is a subdeclaration, so we get it from a special variable which is set while processing the main declaration.") (UNLESS (ATOM RECORD-NAME) (SETQ RECORD-FIELDS RECORD-NAME RECORD-NAME *CURRENT-RECORD-NAME*)) (WHEN) (DO ((FORMS NIL) FIELD FIELD-NAME ACCESSOR-NAME (FIELDS (IF (AND (= (LENGTH RECORD-FIELDS) 2) (ATOM (FIRST RECORD-FIELDS))) (IL:* IL:|;;| "Pidgin single accessfn declaration...") (LIST RECORD-FIELDS) RECORD-FIELDS) (REST FIELDS))) ((ENDP FIELDS) (ADD-EXPORTS (REVERSE FORMS))) (SETQ FIELD (FIRST FIELDS)) (SETQ FIELD-NAME (POP FIELD)) (SETQ ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:* IL:\; "Define the accessor function") (WHEN FIELD (IL:* IL:|;;| "Also remember that we know about this field") (PUSH FIELD-NAME (GETHASH RECORD-NAME *RECORD-TYPES*)) (PUSH (IL:BQUOTE (DEFUN (IL:\\\, ACCESSOR-NAME) (DATUM) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (CONVERT (POP FIELD)))))) FORMS) (IL:* IL:\; "Define the function to set a new value") (WHEN FIELD (PUSH (IL:BQUOTE (DEFSETF (IL:\\\, ACCESSOR-NAME) (DATUM) (NEWVALUE) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE NEWVALUE) :LOCAL (ACONS (QUOTE DATUM) :LOCAL *LOCALS*)))) (CONVERT (POP FIELD)))))) FORMS)))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))")
|
||||
|
||||
|
||||
(IL-DEFCONV DATATYPE (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) RECORD-TAIL-FORMS RECORD-TAIL-INITS (SLOTS NIL) (SLOT-DEFNS NIL) (FIELD-TYPES NIL)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) SLOT-NAME FIELD-TYPE FIELD) ((ENDP FIELDS) (SETQ SLOTS (NREVERSE SLOTS))) (SETQ FIELD (FIRST FIELDS)) (SETQ SLOT-NAME (COND ((CONSP FIELD) (CASE (FIRST FIELD) ((NIL) (IL:* IL:|;;| "Some code has field specs like \"(nil 5 word))\"") (WARN "record spec ~s ignored -- NIL not allowed as field name" FIELD) NIL) (IL:* NIL) (IL:* IL:\; "Ignore comments") (T (SETQ FIELD-TYPE (REST FIELD)) (FIRST FIELD)))) (T (SETQ FIELD-TYPE NIL) FIELD))) (WHEN SLOT-NAME (PUSH SLOT-NAME SLOTS) (PUSH FIELD-TYPE FIELD-TYPES))) (IL:* IL:|;;| "Have to set the field names defined here before calling") (IL:* IL:|;;| "process-record-tail since it will add to them.") (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-SETQ (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL)) (IL:* IL:|;;| "This could be changed to a mapcar. Previous definitions of il-defconv") (IL:* IL:|;;| "for some reason did not correctly handle lambda's.") (DO ((SLOTS SLOTS (REST SLOTS)) (FIELD-TYPES FIELD-TYPES (REST FIELD-TYPES)) SLOT-NAME FIELD-TYPE) ((ENDP SLOTS) (SETQ SLOT-DEFNS (NREVERSE SLOT-DEFNS))) (SETQ SLOT-NAME (FIRST SLOTS) FIELD-TYPE (FIRST FIELD-TYPES)) (PUSH (IL:BQUOTE ((IL:\\\, SLOT-NAME) (IL:\\\, (CDR (ASSOC SLOT-NAME RECORD-TAIL-INITS))) :TYPE (IL:\\\, (FIELD-TO-SLOT-TYPE FIELD-TYPE SLOT-NAME)))) SLOT-DEFNS)) (LET ((NAME-STRING (SYMBOL-NAME STRUCT-NAME))) (PROGN-IF-NEEDED (IL:BQUOTE ((EXPORT (QUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-P"))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT) (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME SLOT))))) SLOTS))))) (DEFSTRUCT (IL:\\\, STRUCT-NAME) (IL:\\\,@ SLOT-DEFNS)) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
|
||||
|
||||
(DEFUN FIELD-TO-SLOT-TYPE (TYPE &OPTIONAL SLOT-NAME) (IF (NULL TYPE) T (CASE (FIRST TYPE) (INTEGER (QUOTE INTEGER)) ((IL:FIXP IL:SIGNEDWORD) (QUOTE FIXNUM)) ((IL:FLOATING IL:FLOATP) (QUOTE FLOAT)) (IL:FLAG (QUOTE (OR NIL T))) (IL:BITS (IF (<= (1- (EXPT 2 (SECOND TYPE))) MOST-POSITIVE-FIXNUM) (QUOTE FIXNUM) (QUOTE INTEGER))) (BYTE (QUOTE FIXNUM)) (IL:WORD (QUOTE FIXNUM)) ((IL:POINTER IL:XPOINTER IL:FULLPOINTER IL:FULLXPOINTER) T) (T (WARN "Unknown type spec ~:@(~a~)~:[~; for slot ~:*~:@(~a~)~]" (FIRST TYPE) SLOT-NAME) T))))
|
||||
|
||||
(IL-DEFCONV /DECLAREDATATYPE (&REST ARGS) (WARN "/DECLAREDATATYPE ignored") NIL)
|
||||
|
||||
(DEFUN FIND-RECORD-TYPE (FIELDNAME) (LET ((RECORD-TYPES NIL)) (MAPHASH (FUNCTION (LAMBDA (RECORD-NAME FIELDS) (WHEN (MEMBER FIELDNAME FIELDS :TEST (FUNCTION EQ)) (PUSH RECORD-NAME RECORD-TYPES)))) *RECORD-TYPES*) (CASE (LENGTH RECORD-TYPES) (0 (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELDNAME FIELDNAME) (QUOTE XXXXX)) (1 (CAR RECORD-TYPES)) (T (CERROR "use ~a" "~*multiple record types have a field named ~s: ~s" (CAR RECORD-TYPES) FIELDNAME RECORD-TYPES) (CAR RECORD-TYPES)))))
|
||||
|
||||
(DEFUN FIND-RECORD-FIELDS (RECORD-TYPE) (MULTIPLE-VALUE-BIND (RECORD FOUND) (GETHASH RECORD-TYPE *RECORD-TYPES*) (IF FOUND RECORD (PROGN (WARN "no record type ~a, initializations may not be done" RECORD-TYPE) NIL))))
|
||||
|
||||
(IL-DEFCONV |fetch| (FIELD-NAME OF &OPTIONAL X &AUX RECORD-TYPE) (DECLARE (SPECIAL IL:USERRECLST)) (WHEN (NOT (STRING-EQUAL OF "of")) (SETQ X OF)) (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/RECFIELDLOOK IL:USERRECLST FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X)))))
|
||||
|
||||
(IL-DEFCONV |replace| (FIELD-NAME OF X WITH Y &AUX RECORD-TYPE) (COND ((NOT (STRING-EQUAL OF "OF")) (CERROR "Skip this form" "Missing |of| in |replace|") *CURRENT-FORM*) ((NOT (STRING-EQUAL WITH "WITH")) (CERROR "Skip this form" "Missing |with| in |replace|") *CURRENT-FORM*) (T (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/ACCESSDEF FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE (SETF ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X))) (IL:\\\, (CONVERT Y)))))))
|
||||
|
||||
(IL-DEFCONV TYPE? (RECORD-NAME FORM) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-P"))) (IL:\\\, (CONVERT FORM)))))
|
||||
|
||||
(IL-DEFCONV |create| (RECORD-NAME &REST ASSIGNMENTS) (|DO-create| RECORD-NAME ASSIGNMENTS))
|
||||
|
||||
(DEFUN |DO-create| (RECORD-NAME ASSIGNMENTS) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (INITS NIL) (SMASHING NIL) (USING NIL) (VAR (MAKE-FAKE-SYMBOL (STRING (GENSYM "G"))))) (DO ((ASSIGNMENTS ASSIGNMENTS (REST ASSIGNMENTS))) ((ENDP ASSIGNMENTS) (SETQ INITS (REVERSE INITS))) (COND ((AND (CONSP (FIRST ASSIGNMENTS)) (STRING-EQUAL (CAAR ASSIGNMENTS) (QUOTE "*")))) ((AND (SYMBOLP (SECOND ASSIGNMENTS)) (STRING-EQUAL (SECOND ASSIGNMENTS) "_")) (PUSH (CONS (FIRST ASSIGNMENTS) (CONVERT (THIRD ASSIGNMENTS))) INITS) (SETQ ASSIGNMENTS (CDDR ASSIGNMENTS))) (T (CASE (FIRST ASSIGNMENTS) ((IL:USING IL:|using|) (SETQ USING (CONVERT (SECOND ASSIGNMENTS)))) ((IL:COPYING IL:|copying|) (WARN "COPYING assignment not supported")) ((IL:REUSING IL:|reusing|) (WARN "REUSING assignment not supported")) ((IL:SMASHING IL:|smashing|) (SETQ SMASHING (CONVERT (SECOND ASSIGNMENTS)))) (T (WARN "unknown assignment ~s" (FIRST ASSIGNMENTS)))) (POP ASSIGNMENTS)))) (COND (USING (IL:BQUOTE (LET (((IL:\\\, VAR) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, USING)))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR)))) (SMASHING (IF INITS (IL:BQUOTE (LET (((IL:\\\, VAR) (IL:\\\, SMASHING))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR))) SMASHING)) (T (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (IL:BQUOTE ((IL:\\\, (INTERN (STRING (CAR INIT)) (QUOTE KEYWORD))) (IL:\\\, (CDR INIT)))))) INITS))))))))
|
||||
|
||||
(IL-COPYCONV |fetch| FETCH)
|
||||
|
||||
(IL-COPYCONV |fetch| |ffetch|)
|
||||
|
||||
(IL-COPYCONV |ffetch| FFETCH)
|
||||
|
||||
(IL-COPYCONV |replace| REPLACE)
|
||||
|
||||
(IL-COPYCONV |replace| |freplace|)
|
||||
|
||||
(IL-COPYCONV |freplace| FREPLACE)
|
||||
|
||||
(IL-COPYCONV TYPE? |type?|)
|
||||
|
||||
(IL-COPYCONV |create| CREATE)
|
||||
|
||||
(IL:PUTPROPS IL:IL-RECORD IL:MAKEFILE-ENVIRONMENT (:PACKAGE "IL-CONVERT" :READTABLE "XCL"))
|
||||
(IL:PUTPROPS IL:IL-RECORD IL:COPYRIGHT ("ENVOS Corporation" 1989))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
1
lispusers/MIGRATION/IL-RECORD.LCOM
Normal file
1
lispusers/MIGRATION/IL-RECORD.LCOM
Normal file
File diff suppressed because one or more lines are too long
1356
lispusers/MIGRATION/IL-SIM
Normal file
1356
lispusers/MIGRATION/IL-SIM
Normal file
File diff suppressed because one or more lines are too long
1
lispusers/MIGRATION/IL-SIM.LCOM
Normal file
1
lispusers/MIGRATION/IL-SIM.LCOM
Normal file
File diff suppressed because one or more lines are too long
90
lispusers/MIGRATION/IL-STARTUP
Normal file
90
lispusers/MIGRATION/IL-STARTUP
Normal file
@@ -0,0 +1,90 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CL IN-PACKAGE "IL-CONVERT")
|
||||
*PACKAGE*) BASE 10)
|
||||
(IL:FILECREATED "14-Sep-89 10:01:13" IL:|{DSK}/python2/aria/migration/interlisp/IL-STARTUP.;2| 6548
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS NOTE-EXPORTED-SYMBOL CONVERT)
|
||||
|
||||
IL:|previous| IL:|date:| " 7-Jul-89 16:55:06" IL:|{DSK}/users/eweaver/convert/IL-STARTUP.;17|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1989 by ENVOS Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:IL-STARTUPCOMS)
|
||||
|
||||
(IL:RPAQQ IL:IL-STARTUPCOMS ((IL:* IL:|;;;| "This should be loaded before any other files.") (EVAL-WHEN (LOAD COMPILE EVAL) (IL:VARIABLES *IL-PACKAGE*)) (IL:VARIABLES *IL-SIM-PACKAGE*) (IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ") (IL:STRUCTURES BQ MACRO-ARG) (IL:* IL:|;;;| "") (IL:VARIABLES *CURRENT-CONVERT-FORM* *CURRENT-CONVERT-FUNCTION* *GLOBALS* *LOCALS* *FUNCTION-CALLS* *CURRENT-FUNCTION-CALLS* *CURRENT-FREE-REFERENCES* *EXPORTED-IL-SYMBOLS*) (IL:P (EXPORT (QUOTE CONVERT))) (IL:FUNCTIONS CONVERT MAPCONVERT EXTERN NOTE-EXPORTED-SYMBOL) (IL:FUNCTIONS TRUE-LIST-P) (IL:* IL:\; "true if this is nil or a true list") (IL:* IL:|;;| "make a true list out of a pseudo-list (make-true-list '(A B . C)) => (A B C)") (IL:FUNCTIONS MAKE-TRUE-LIST) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-STARTUP))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;;| "This should be loaded before any other files.")
|
||||
|
||||
(EVAL-WHEN (LOAD COMPILE EVAL)
|
||||
|
||||
(DEFVAR *IL-PACKAGE* (FIND-PACKAGE "INTERLISP"))
|
||||
)
|
||||
|
||||
(DEFVAR *IL-SIM-PACKAGE* (MAKE-PACKAGE "IL-SIM" :USE NIL))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ")
|
||||
|
||||
|
||||
(DEFSTRUCT (BQ (:TYPE LIST) (:CONSTRUCTOR MAKE-BQ (ELEMENT))) (BQFLAG (QUOTE IL:BQUOTE)) ELEMENT)
|
||||
|
||||
(DEFSTRUCT (MACRO-ARG (:TYPE LIST) (:CONSTRUCTOR MAKE-MACRO-ARG (&KEY ELEMENT APPEND-P (FLAG (IF APPEND-P (QUOTE IL:\\\,@) (QUOTE IL:\\\,)))))) FLAG ELEMENT)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;;| "")
|
||||
|
||||
|
||||
(DEFVAR *CURRENT-CONVERT-FORM*)
|
||||
|
||||
(DEFVAR *CURRENT-CONVERT-FUNCTION*)
|
||||
|
||||
(DEFVAR *GLOBALS* NIL)
|
||||
|
||||
(DEFVAR *LOCALS* NIL)
|
||||
|
||||
(DEFVAR *FUNCTION-CALLS* NIL)
|
||||
|
||||
(DEFVAR *CURRENT-FUNCTION-CALLS* NIL)
|
||||
|
||||
(DEFVAR *CURRENT-FREE-REFERENCES* NIL)
|
||||
|
||||
(DEFVAR *EXPORTED-IL-SYMBOLS* NIL)
|
||||
|
||||
(EXPORT (QUOTE CONVERT))
|
||||
|
||||
(DEFUN CONVERT (FORM &AUX FN VAR) (IL:BLOCK) (LET ((*CURRENT-EXPRESSION* FORM)) (COND (IL:* IL:|;;| "Forms in which the car is a symbol...") ((AND (CONSP FORM) (ATOM (FIRST FORM))) (COND ((NOT (TRUE-LIST-P FORM)) (LET ((TAIL (CDR (LAST FORM)))) (IL:* IL:|;;| "dotted lists ending in a macro arg are okay.") (IF (AND (SYMBOLP TAIL) (EQ (CDR (ASSOC TAIL *LOCALS*)) :MACRO-ARG)) (LET ((MARG (MAKE-MACRO-ARG :ELEMENT TAIL)) (VAL (COPY-LIST FORM))) (SETF (CDR (LAST VAL)) MARG) VAL) (PROGN (WARN "~s not a list, left as is" FORM) FORM)))) ((LET ((FOO (GET (CAR FORM) (QUOTE IL:CLISPWORD)))) (AND (CONSP FOO) (EQ (CAR FOO) (QUOTE IL:FORWORD)) (NOT (EQ (CAR FORM) (QUOTE DECLARE))))) (CONVERT-ITERATION-STATEMENT (CAR FORM) (CDR FORM))) ((SETQ FN (GET (FIRST FORM) (QUOTE CONVERT-FORM))) (SETQ *CURRENT-CONVERT-FORM* FORM *CURRENT-CONVERT-FUNCTION* FN) (APPLY FN (REST FORM))) ((OR (MACRO-FUNCTION (FIRST FORM)) (SPECIAL-FORM-P (FIRST FORM))) (IL:* IL:|;;| "Use CL code walker for this") (WALK-FORM-INTERNAL FORM)) ((EQ (CHAR (STRING (FIRST FORM)) 0) #\\) (WARN "Untranslatable function ~a" (STRING (FIRST FORM))) FORM) (T (IL:* IL:|;;| "(setq fn (first form) (extern (symbol-name (first form)) *il-package*))") (WHEN *CURRENT-FUNCTION-CALLS* (PUSHNEW FN *CURRENT-FUNCTION-CALLS*)) (NOTE-EXPORTED-SYMBOL (FIRST FORM)) (CONS (FIRST FORM) (MAPCAR (QUOTE CONVERT) (REST FORM)))))) (IL:* IL:|;;| "Forms in which the car is a Lambda...") ((AND (CONSP FORM) (IL:* IL:|;;| "But car is cons") (SYMBOLP (CAAR FORM)) (STRING-EQUAL (CAAR FORM) "LAMBDA")) (CONS (CONVERT (CAR FORM)) (MAPCONVERT (CDR FORM)))) (IL:* IL:|;;| "Other non-atomic forms...") ((CONSP FORM) (WARN "Unknown kind of form ~s, not converted." FORM) FORM) (IL:* IL:|;;| "Atomic forms...") ((NULL FORM) NIL) ((EQ FORM T) T) ((KEYWORDP FORM) FORM) ((SYMBOLP FORM) (IF (SETQ VAR (ASSOC FORM *LOCALS*)) (CASE (CDR VAR) (:LOCAL (CAR VAR)) (:MACRO-ARG (MAKE-MACRO-ARG :ELEMENT (CAR VAR))) (T (ERROR "unexpected value ~s in *LOCALS*" VAR))) (PROGN (NOTE-EXPORTED-SYMBOL FORM) (WHEN *CURRENT-FREE-REFERENCES* (PUSHNEW FORM *CURRENT-FREE-REFERENCES*)) FORM))) (T FORM))))
|
||||
|
||||
(DEFUN MAPCONVERT (FORM-OR-FORMS) (IF (ATOM FORM-OR-FORMS) (CONVERT FORM-OR-FORMS) (DO* ((TAIL FORM-OR-FORMS (CDR TAIL)) (SUBFORM (IF (CONSP TAIL) (CAR TAIL) TAIL) (IF (CONSP TAIL) (CAR TAIL) TAIL)) RESULT) ((ATOM TAIL) (IF (NULL TAIL) (NREVERSE RESULT) (PROGN (SETF (CDR (LAST (SETQ RESULT (NREVERSE RESULT)))) (CONVERT TAIL)) RESULT))) (PUSH (CONVERT SUBFORM) RESULT))))
|
||||
|
||||
(DEFUN EXTERN (STRING &OPTIONAL (PACKAGE *PACKAGE*)) (IL:* (LET ((SYM (INTERN STRING PACKAGE))) (EXPORT SYM PACKAGE) (IF (EQ PACKAGE *IL-PACKAGE*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*)) SYM)) (ERROR "Old leftover call to EXTERN!"))
|
||||
|
||||
(DEFUN NOTE-EXPORTED-SYMBOL (SYM &AUX PKG PKGNM) "" (WHEN (NULL (SETQ PKG (SYMBOL-PACKAGE SYM))) (RETURN-FROM NOTE-EXPORTED-SYMBOL SYM)) (WHEN (AND (EQ PKG IL:*INTERLISP-PACKAGE*) (NOT (EQ (FIND-SYMBOL (SYMBOL-NAME SYM) IL:*LISP-PACKAGE*) SYM)) (OR *WARN-FOR-ALL-IL-SYMBOLS* (< (IL:\\LOLOC SYM) (IL:\\LOLOC *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS*)))) (LET ((*CURRENT-EXPRESSION* SYM)) (WARN "Use of IL symbol ~a" SYM))) (WHEN (OR (EQ PKG IL:*INTERLISP-PACKAGE*) (AND (NOT (OR (EQ PKG IL:*KEYWORD-PACKAGE*) (EQ PKG IL:*LISP-PACKAGE*))) (MULTIPLE-VALUE-BIND (IGNORE TYPE) (FIND-SYMBOL (SYMBOL-NAME SYM) PKG) (EQ TYPE :EXTERNAL)))) (IF (NULL *FILE-CONTEXT*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*) (PUSHNEW SYM (FILE-CONTEXT-EXPORTED-SYMS *FILE-CONTEXT*)))) SYM)
|
||||
|
||||
(DEFUN TRUE-LIST-P (PSEUDO-LIST) (DO ((PL PSEUDO-LIST (CDR PL))) ((NULL PL) T) (IF (ATOM PL) (RETURN NIL))))
|
||||
|
||||
|
||||
|
||||
(IL:* IL:\; "true if this is nil or a true list")
|
||||
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "make a true list out of a pseudo-list (make-true-list '(A B . C)) => (A B C)")
|
||||
|
||||
|
||||
(DEFUN MAKE-TRUE-LIST (PSEUDO-LIST) (COND ((TRUE-LIST-P PSEUDO-LIST) PSEUDO-LIST) (T (DO ((TRUE-LIST NIL)) ((ATOM PSEUDO-LIST) (NREVERSE (CONS PSEUDO-LIST TRUE-LIST))) (IF (ENDP PSEUDO-LIST) (RETURN (NREVERSE TRUE-LIST))) (PUSH (POP PSEUDO-LIST) TRUE-LIST)))))
|
||||
|
||||
(IL:PUTPROPS IL:IL-STARTUP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (IN-PACKAGE "IL-CONVERT") *PACKAGE*) :BASE 10)
|
||||
)
|
||||
|
||||
(IL:PUTPROPS IL:IL-STARTUP IL:FILETYPE :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:IL-STARTUP IL:COPYRIGHT ("ENVOS Corporation" 1989))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
1
lispusers/MIGRATION/IL-STARTUP.LCOM
Normal file
1
lispusers/MIGRATION/IL-STARTUP.LCOM
Normal file
File diff suppressed because one or more lines are too long
25
lispusers/MIGRATION/MIGRATION-TOOL
Normal file
25
lispusers/MIGRATION/MIGRATION-TOOL
Normal file
@@ -0,0 +1,25 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")
|
||||
(IL:FILECREATED "26-Jan-90 10:27:59" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;2| 1091
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FILES IL:IL-CONVERT)
|
||||
|
||||
IL:|previous| IL:|date:| "11-Aug-89 16:19:28" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;1|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:MIGRATION-TOOLCOMS)
|
||||
|
||||
(IL:RPAQQ IL:MIGRATION-TOOLCOMS ((IL:PROP IL:MAKEFILE-ENVIRONMENT IL:MIGRATION-TOOL)
|
||||
(IL:FILES IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD
|
||||
IL:TRANSLATOR-ASSISTANT)))
|
||||
|
||||
(IL:PUTPROPS IL:MIGRATION-TOOL IL:MAKEFILE-ENVIRONMENT (:PACKAGE (XCL:DEFPACKAGE "IL-CONVERT")
|
||||
:READTABLE "XCL"))
|
||||
|
||||
(IL:FILESLOAD IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD IL:TRANSLATOR-ASSISTANT)
|
||||
(IL:PUTPROPS IL:MIGRATION-TOOL IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
1
lispusers/MIGRATION/MIGRATION-TOOL.LCOM
Normal file
1
lispusers/MIGRATION/MIGRATION-TOOL.LCOM
Normal file
@@ -0,0 +1 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")
|
||||
242
lispusers/MIGRATION/SEDIT-DECLS
Normal file
242
lispusers/MIGRATION/SEDIT-DECLS
Normal file
File diff suppressed because one or more lines are too long
1
lispusers/MIGRATION/SEDIT-DECLS.LCOM
Normal file
1
lispusers/MIGRATION/SEDIT-DECLS.LCOM
Normal file
File diff suppressed because one or more lines are too long
35
lispusers/MIGRATION/TABLEBROWSERDECLS
Normal file
35
lispusers/MIGRATION/TABLEBROWSERDECLS
Normal file
@@ -0,0 +1,35 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "27-Jan-88 17:04:01" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;5 5052
|
||||
|
||||
changes to%: (RECORDS TABLEBROWSER)
|
||||
|
||||
previous date%: "18-Oct-85 18:10:50" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;2)
|
||||
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS)
|
||||
|
||||
(RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; "True if creator set explicit item height or baseline") (NIL 6 FLAG) (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; "Number of lines occupied by each item, normally 1 (dunno if any other values work)") (TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item. If none selected, is > TB#ITEMS") (TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item. If none selected, is 0") (TBITEMHEIGHT WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; "Pointer to the display window. Need to snap this link when browser is closed") (TBLOCK POINTER) (* ; "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; "Window's extent, updated as items are added, deleted, or printfn prints farther to right") (TBUPDATEFROMHERE POINTER) (* ; "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; "Y position of the top of the first item") (TBTAILHINT POINTER) (* ; "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))
|
||||
)
|
||||
|
||||
(DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))
|
||||
)
|
||||
)
|
||||
(/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER))) (QUOTE 48))
|
||||
(/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)) (QUOTE ((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 (FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 0 POINTER) (TABLEITEM 2 (BITS . 15)) (TABLEITEM 3 (BITS . 15)))) (QUOTE 4))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ TB.LEFT.MARGIN 8)
|
||||
|
||||
(CONSTANTS TB.LEFT.MARGIN)
|
||||
)
|
||||
(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Xerox Corporation" 1985 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
1
lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM
Normal file
1
lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM
Normal file
File diff suppressed because one or more lines are too long
1646
lispusers/MIGRATION/TRANSLATOR-ASSISTANT
Normal file
1646
lispusers/MIGRATION/TRANSLATOR-ASSISTANT
Normal file
File diff suppressed because it is too large
Load Diff
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Oct-2021 15:42:11"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;41 30305
|
||||
(FILECREATED "25-Dec-2021 22:27:41"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MODERNIZE.;39 30532
|
||||
|
||||
changes to%: (FNS MODERNIZED.TB.BUTTONEVENTFN)
|
||||
:CHANGES-TO (FNS MODERN-MENUBUTTONFN)
|
||||
|
||||
previous date%: "16-Oct-2021 15:29:38"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;40)
|
||||
:PREVIOUS-DATE "25-Dec-2021 22:20:10"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MODERNIZE.;38)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MODERNIZECOMS)
|
||||
@@ -216,8 +216,9 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MODERNWINDOW.BUTTONEVENTFN
|
||||
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION CORNERREGION TOPMARGIN)
|
||||
(* ; "Edited 16-Oct-2021 15:25 by rmk:")
|
||||
[LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION CORNERREGION TOPMARGIN)
|
||||
(* ; "Edited 25-Dec-2021 22:19 by rmk")
|
||||
(* ; "Edited 16-Oct-2021 15:25 by rmk:")
|
||||
|
||||
(* ;; "WINDOW is the window that received the click and that should be passed through to the original function, if we don't pick it off here.")
|
||||
|
||||
@@ -232,81 +233,78 @@
|
||||
(LET (CORNER ATTACHEDREGION)
|
||||
(IF CORNERREGION
|
||||
THEN
|
||||
(* ;; "Caller tells us whether the corner window has a title.")
|
||||
|
||||
(* ;; "Caller tells us whether the corner window has a title.")
|
||||
|
||||
(CL:UNLESS (FIXP TOPMARGIN)
|
||||
(SETQ TOPMARGIN (if TOPMARGIN
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
(CL:UNLESS (FIXP TOPMARGIN)
|
||||
(SETQ TOPMARGIN (if TOPMARGIN
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
ELSE (SETQ CORNERREGION (WINDOWPROP WINDOW 'REGION))
|
||||
(* ; "WINDOW is the corner window")
|
||||
(SETQ TOPMARGIN (if (WINDOWPROP WINDOW 'TOPMARGIN)
|
||||
elseif (WINDOWPROP WINDOW 'TITLE)
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
(SETQ TOPMARGIN (if (WINDOWPROP WINDOW 'TOPMARGIN)
|
||||
elseif (WINDOWPROP WINDOW 'TITLE)
|
||||
then (FONTPROP WindowTitleDisplayStream 'HEIGHT)
|
||||
else MODERN-WINDOW-MARGIN)))
|
||||
(if (AND (MOUSESTATE (ONLY LEFT))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(INSIDE? CORNERREGION LASTMOUSEX LASTMOUSEY))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(INSIDE? CORNERREGION LASTMOUSEX LASTMOUSEY))
|
||||
then
|
||||
(* ;; "INSIDE? check because we may be called by a click in WINDOW that is outside the corner region, we just pass it through.")
|
||||
|
||||
(* ;; "INSIDE? check because we may be called by a click in WINDOW that is outside the corner region, we just pass it through.")
|
||||
(TOTOPW WINDOW)
|
||||
(SETQ ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW)))
|
||||
|
||||
(TOTOPW WINDOW)
|
||||
(SETQ ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW)))
|
||||
(* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.")
|
||||
|
||||
(* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window. The TOPMARGIN should be 0 in that case.")
|
||||
(* ;; "This is particularly the case of FILEBROWSER windows, where the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")
|
||||
|
||||
(* ;; "This is particularly the case of FILEBROWSER windows, where the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")
|
||||
(SETQ CORNER (INCORNER.REGION CORNERREGION TOPMARGIN))
|
||||
(if [AND CORNER (NOT (MEMB 'SHAPEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS]
|
||||
then
|
||||
(* ;;
|
||||
"The upper corners may be in the title bar, near the side, so test corners before titlebar.")
|
||||
|
||||
(SETQ CORNER (INCORNER.REGION CORNERREGION TOPMARGIN))
|
||||
(if CORNER
|
||||
then
|
||||
(* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")
|
||||
|
||||
(* ;;
|
||||
"The upper corners may be in the title bar, near the side, so test corners before titlebar.")
|
||||
(* ;; "WINDOWREGION includes the attached windows")
|
||||
|
||||
(* ;; "We are in the corner of the main window, so we are reshaping. But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")
|
||||
(LET ((LEFT (fetch (REGION LEFT) of ATTACHEDREGION))
|
||||
(RIGHT (fetch (REGION RIGHT) of ATTACHEDREGION))
|
||||
(TOP (fetch (REGION TOP) of ATTACHEDREGION))
|
||||
(BOTTOM (fetch (REGION BOTTOM) of ATTACHEDREGION))
|
||||
STARTINGREGION)
|
||||
|
||||
(* ;; "WINDOWREGION includes the attached windows")
|
||||
(* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")
|
||||
|
||||
(LET ((LEFT (fetch (REGION LEFT) of ATTACHEDREGION))
|
||||
(RIGHT (fetch (REGION RIGHT) of ATTACHEDREGION))
|
||||
(TOP (fetch (REGION TOP) of ATTACHEDREGION))
|
||||
(BOTTOM (fetch (REGION BOTTOM) of ATTACHEDREGION))
|
||||
STARTINGREGION)
|
||||
|
||||
(* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")
|
||||
|
||||
(CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
|
||||
[SETQ STARTINGREGION
|
||||
(GETREGION NIL NIL NIL NIL NIL
|
||||
(SELECTQ CORNER
|
||||
(RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT TOP RIGHT BOTTOM))
|
||||
(LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST RIGHT TOP LEFT BOTTOM))
|
||||
(RIGHTTOP (\CURSORPOSITION RIGHT TOP)
|
||||
(CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
|
||||
[SETQ STARTINGREGION
|
||||
(GETREGION NIL NIL NIL NIL NIL
|
||||
(SELECTQ CORNER
|
||||
(RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT TOP RIGHT BOTTOM))
|
||||
(LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT BOTTOM RIGHT TOP))
|
||||
(LEFTTOP (\CURSORPOSITION LEFT TOP)
|
||||
(GETMOUSESTATE)
|
||||
(LIST RIGHT BOTTOM LEFT TOP))
|
||||
(SHOULDNT])
|
||||
(SHAPEW (CENTRALWINDOW WINDOW)
|
||||
STARTINGREGION))
|
||||
T
|
||||
elseif (OR ANYWHERE (NEARTOP CORNERREGION TOPMARGIN TITLEPROPORTION))
|
||||
then (NEARESTCORNER ATTACHEDREGION)
|
||||
(MOVEW (CENTRALWINDOW WINDOW))
|
||||
T
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
|
||||
'PREMODERN-BUTTONEVENTFN]
|
||||
then (APPLY* ORIGFUNCTION WINDOW))
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
|
||||
'PREMODERN-BUTTONEVENTFN]
|
||||
(LIST RIGHT TOP LEFT BOTTOM))
|
||||
(RIGHTTOP (\CURSORPOSITION RIGHT TOP)
|
||||
(GETMOUSESTATE)
|
||||
(LIST LEFT BOTTOM RIGHT TOP))
|
||||
(LEFTTOP (\CURSORPOSITION LEFT TOP)
|
||||
(GETMOUSESTATE)
|
||||
(LIST RIGHT BOTTOM LEFT TOP))
|
||||
(SHOULDNT])
|
||||
(SHAPEW (CENTRALWINDOW WINDOW)
|
||||
STARTINGREGION))
|
||||
T
|
||||
elseif (AND [NOT (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS]
|
||||
(OR ANYWHERE (NEARTOP CORNERREGION TOPMARGIN TITLEPROPORTION)))
|
||||
then (NEARESTCORNER ATTACHEDREGION)
|
||||
(MOVEW (CENTRALWINDOW WINDOW))
|
||||
T
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW
|
||||
'PREMODERN-BUTTONEVENTFN]
|
||||
then (APPLY* ORIGFUNCTION WINDOW))
|
||||
elseif [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN]
|
||||
then (APPLY* ORIGFUNCTION WINDOW])
|
||||
|
||||
(NEARTOP
|
||||
@@ -406,19 +404,21 @@
|
||||
(MODERNWINDOW.BUTTONEVENTFN MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))])
|
||||
|
||||
(MODERN-MENUBUTTONFN
|
||||
[LAMBDA (WINDOW) (* ; "Edited 23-May-2021 20:37 by rmk:")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 25-Dec-2021 22:26 by rmk")
|
||||
(* ; "Edited 23-May-2021 20:37 by rmk:")
|
||||
|
||||
(* ;; "Replaces the button fn for a Menu window, allowing title clicks to do the move. Sometimes the title isn't in the window, it's in the menu.")
|
||||
(* ;; "Replaces the button fn for a Menu window, allowing title clicks to do the move. Sometimes the title isn't in the window, it's in the menu.")
|
||||
|
||||
(LET (MENU)
|
||||
(IF [AND (MOUSESTATE (ONLY LEFT))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(OR (WINDOWPROP WINDOW 'TITLE)
|
||||
(AND [NULL (CDR (SETQ MENU (MKLIST (WINDOWPROP WINDOW 'MENU]
|
||||
(TYPE? MENU (SETQ MENU (CAR MENU)))
|
||||
(FETCH (MENU TITLE) OF MENU)))
|
||||
(NEARTOP (WINDOWPROP WINDOW 'REGION)
|
||||
(FONTPROP WindowTitleDisplayStream 'HEIGHT]
|
||||
(IF [AND [NOT (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS]
|
||||
(MOUSESTATE (ONLY LEFT))
|
||||
(EQ LASTKEYBOARD 0)
|
||||
(OR (WINDOWPROP WINDOW 'TITLE)
|
||||
(AND [NULL (CDR (SETQ MENU (MKLIST (WINDOWPROP WINDOW 'MENU]
|
||||
(TYPE? MENU (SETQ MENU (CAR MENU)))
|
||||
(FETCH (MENU TITLE) OF MENU)))
|
||||
(NEARTOP (WINDOWPROP WINDOW 'REGION)
|
||||
(FONTPROP WindowTitleDisplayStream 'HEIGHT]
|
||||
THEN (MOVEW WINDOW)
|
||||
ELSE (MODERN-ORIG-MENUBUTTONFN WINDOW])
|
||||
)
|
||||
@@ -532,7 +532,7 @@
|
||||
|
||||
|
||||
(* (MODERNWINDOW.SETUP
|
||||
(QUOTE ONEDINSPECT.BUTTONEVENTFN)))
|
||||
(QUOTE ONEDINSPECT.BUTTONEVENTFN)))
|
||||
|
||||
(MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
|
||||
|
||||
@@ -571,7 +571,7 @@
|
||||
|
||||
|
||||
(MODERNWINDOW (PROCESSPROP (TTY.PROCESS)
|
||||
'WINDOW))
|
||||
'WINDOW))
|
||||
|
||||
|
||||
(* ;; "Table browser and filebrowser)")
|
||||
@@ -612,12 +612,12 @@
|
||||
(ADDTOVAR LAMA MODERN-ADD-EXEC)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5135 11412 (MODERNWINDOW 5145 . 6600) (MODERNWINDOW.SETUP 6602 . 9551) (UNMODERNWINDOW
|
||||
9553 . 9947) (MODERNWINDOW.UNSETUP 9949 . 10761) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10763 . 11410)) (
|
||||
11477 21412 (MODERNWINDOW.BUTTONEVENTFN 11487 . 18287) (NEARTOP 18289 . 19217) (NEARESTCORNER 19219 .
|
||||
20098) (INCORNER.REGION 20100 . 21410)) (21470 23792 (MODERN-ADD-EXEC 21480 . 21911) (MODERN-SNAPW
|
||||
21913 . 22456) (TOTOPW.MODERNIZE 22458 . 22886) (MODERN-MENUBUTTONFN 22888 . 23790)) (23793 26222 (
|
||||
\MODERNIZED.FREEMENU.BUTTONEVENTFN 23803 . 24450) (MODERNIZED.TB.BUTTONEVENTFN 24452 . 26220)) (26263
|
||||
28542 (TEDIT.MODERNIZE 26273 . 27087) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27089 . 28211) (TEDIT.SELECTALL
|
||||
28213 . 28540)))))
|
||||
(FILEMAP (NIL (5122 11399 (MODERNWINDOW 5132 . 6587) (MODERNWINDOW.SETUP 6589 . 9538) (UNMODERNWINDOW
|
||||
9540 . 9934) (MODERNWINDOW.UNSETUP 9936 . 10748) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10750 . 11397)) (
|
||||
11464 21491 (MODERNWINDOW.BUTTONEVENTFN 11474 . 18366) (NEARTOP 18368 . 19296) (NEARESTCORNER 19298 .
|
||||
20177) (INCORNER.REGION 20179 . 21489)) (21549 24021 (MODERN-ADD-EXEC 21559 . 21990) (MODERN-SNAPW
|
||||
21992 . 22535) (TOTOPW.MODERNIZE 22537 . 22965) (MODERN-MENUBUTTONFN 22967 . 24019)) (24022 26451 (
|
||||
\MODERNIZED.FREEMENU.BUTTONEVENTFN 24032 . 24679) (MODERNIZED.TB.BUTTONEVENTFN 24681 . 26449)) (26492
|
||||
28771 (TEDIT.MODERNIZE 26502 . 27316) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27318 . 28440) (TEDIT.SELECTALL
|
||||
28442 . 28769)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
1501
lispusers/OBJECTWINDOW
Normal file
1501
lispusers/OBJECTWINDOW
Normal file
File diff suppressed because it is too large
Load Diff
BIN
lispusers/OBJECTWINDOW.LCOM
Normal file
BIN
lispusers/OBJECTWINDOW.LCOM
Normal file
Binary file not shown.
BIN
lispusers/OBJECTWINDOW.TEDIT
Normal file
BIN
lispusers/OBJECTWINDOW.TEDIT
Normal file
Binary file not shown.
@@ -1,11 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED " 9-Jul-2021 21:55:15"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;5 93788
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS PRETTYFILEINDEX PFI.PRINT.FILECREATED)
|
||||
(FILECREATED "30-Nov-2021 22:12:37" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;2 94399
|
||||
|
||||
previous date%: " 9-Jul-2021 08:04:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;4)
|
||||
:CHANGES-TO (FNS PFI.PRINT.FILECREATED)
|
||||
|
||||
:PREVIOUS-DATE " 9-Jul-2021 21:55:15" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -16,7 +15,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
|
||||
(RPAQQ PRETTYFILEINDEXCOMS
|
||||
[(COMS
|
||||
(* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")
|
||||
(* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")
|
||||
|
||||
(FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX)
|
||||
(FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN
|
||||
@@ -25,25 +24,25 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER
|
||||
PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE
|
||||
PFI.ESTIMATE.SIZE1))
|
||||
(COMS (* ; "Expression handlers")
|
||||
(COMS (* ; "Expression handlers")
|
||||
(FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER
|
||||
PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF
|
||||
PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS
|
||||
PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE))
|
||||
(COMS (* ; "Previewers")
|
||||
(COMS (* ; "Previewers")
|
||||
(FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ))
|
||||
(COMS (* ; "Printing the index")
|
||||
(COMS (* ; "Printing the index")
|
||||
(FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE
|
||||
PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME)
|
||||
(FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES))
|
||||
(COMS (* ; "Combined listings")
|
||||
(COMS (* ; "Combined listings")
|
||||
(FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST
|
||||
PFI.MERGE.INDICES))
|
||||
(COMS (* ;
|
||||
"Hooks for seeing files pretty elsewhere")
|
||||
(COMS (* ;
|
||||
"Hooks for seeing files pretty elsewhere")
|
||||
(FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION)
|
||||
(INITVARS (*PRINT-PRETTY-FROM-FILES* T)))
|
||||
(COMS (* ; "Bitmap hack")
|
||||
(COMS (* ; "Bitmap hack")
|
||||
(FNS PFI.PRINT.BITMAP)
|
||||
(INITVARS (*PRINT-PRETTY-BITMAPS* T)))
|
||||
(INITVARS [*PFI-PRINTOPTIONS* '(REGION (72 54 504 702]
|
||||
@@ -57,8 +56,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
then *INTERLISP-PACKAGE* else
|
||||
*KEYWORD-PACKAGE*)))
|
||||
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
|
||||
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
|
||||
(FUNCTION CL:INTERN]
|
||||
@@ -66,7 +65,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX"))
|
||||
(\PFI.PROCESS))
|
||||
(COMS
|
||||
(* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex")
|
||||
(* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex")
|
||||
|
||||
(INITVARS (*PFI-TITLE*)
|
||||
(*PFI-PAGE-COUNT* 0)))
|
||||
@@ -102,8 +101,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(*PFI-PROPERTIES* (COPYRIGHT)
|
||||
(READVICE ADVICE))
|
||||
(*PFI-FILTERS* (VARIABLES . CONSTANTS)))
|
||||
(COMS (* ;
|
||||
"Prettyprint augmentation to mimic system makefile dumping")
|
||||
(COMS (* ;
|
||||
"Prettyprint augmentation to mimic system makefile dumping")
|
||||
(FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT
|
||||
MAYBE.PRETTYPRINT.BOLD)
|
||||
(ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM)))
|
||||
@@ -119,8 +118,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES
|
||||
MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS*
|
||||
*COMMON-LISP-READ-ENVIRONMENT*))
|
||||
[DECLARE%: EVAL@COMPILE DOCOPY (* ;
|
||||
"Public variables to declare special")
|
||||
[DECLARE%: EVAL@COMPILE DOCOPY (* ;
|
||||
"Public variables to declare special")
|
||||
(P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS*
|
||||
*PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS*
|
||||
*PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS*
|
||||
@@ -130,24 +129,24 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(P (OR (GETD 'CODEWRAPPER.PRETTYPRINT)
|
||||
(FILESLOAD (SYSLOAD)
|
||||
DEFINERPRINT))
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
(MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
|
||||
S)
|
||||
(* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
(* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
LP
|
||||
(COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
|
||||
(GETD S))
|
||||
(RETURN (PROG1 S
|
||||
(COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE"
|
||||
))
|
||||
(* ; "Also fix SEE")
|
||||
(* ; "Also fix SEE")
|
||||
(MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
|
||||
((SETQ SYMS (CDR SYMS))
|
||||
(GO LP))
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(RETURN 'LISTFILES1]
|
||||
'PFI.ORIGINAL.LISTFILES1 NIL T)
|
||||
(MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T)
|
||||
@@ -459,12 +458,17 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(PFI.PRINT.FILECREATED
|
||||
[LAMBDA (EXPR ENV) (* ; "Edited 9-Jul-2021 07:59 by rmk:")
|
||||
[LAMBDA (EXPR ENV) (* ;
|
||||
"Edited 30-Nov-2021 22:08 by larry")
|
||||
(* ;
|
||||
"Edited 30-Nov-2021 21:40 by larry")
|
||||
(* ;
|
||||
"Edited 9-Jul-2021 07:59 by rmk:")
|
||||
|
||||
(* ;; "Display the FILECREATED expression and environment prettily")
|
||||
(* ;; "Display the FILECREATED expression and environment prettily")
|
||||
|
||||
(* ;;
|
||||
"Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
|
||||
(* ;;
|
||||
"Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
|
||||
|
||||
(pop EXPR)
|
||||
(CHANGEFONT ITALICFONT)
|
||||
@@ -477,34 +481,41 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
STRWIDTHS]
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "File created:")
|
||||
TABSTOP) (* ; "File created:")
|
||||
(PRINTOUT NIL (pop EXPR)
|
||||
" " .FONT LAMBDAFONT (pop EXPR)
|
||||
T T) (* ; "date and file name")
|
||||
T T) (* ; "date and file name")
|
||||
(if (OR (NULL (CAR EXPR))
|
||||
(FIXP (CAR EXPR)))
|
||||
then (* ; "Skip over filemaploc")
|
||||
then (* ; "Skip over filemaploc")
|
||||
(pop EXPR))
|
||||
(if (EQ (CAR EXPR)
|
||||
'changes)
|
||||
then (* ; "handle %"Changes to:%"")
|
||||
(if (SELECTQ (CAR EXPR)
|
||||
(changes (SETQ EXPR (CDR EXPR))
|
||||
T)
|
||||
(:CHANGES-TO T)
|
||||
NIL)
|
||||
then (* ; "handle %"Changes to:%"")
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP)
|
||||
(SETQ EXPR (CDDR EXPR))
|
||||
(SETQ EXPR (CDR EXPR))
|
||||
(PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR))
|
||||
T NIL T)
|
||||
(TERPRI)
|
||||
(TERPRI)
|
||||
else (pop STRINGS)
|
||||
(pop STRWIDTHS))
|
||||
(if (EQ (CAR EXPR)
|
||||
'previous)
|
||||
then (* ; "Handle %"Previous date:%"")
|
||||
(if (SELECTQ (CAR EXPR)
|
||||
(previous (SETQ EXPR (CDR EXPR))
|
||||
T)
|
||||
(:PREVIOUS-DATE
|
||||
T)
|
||||
NIL)
|
||||
then (* ; "Handle %"Previous date:%"")
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP)
|
||||
(SETQ EXPR (CDDR EXPR))
|
||||
(SETQ EXPR (CDR EXPR))
|
||||
(PRINTOUT NIL (pop EXPR)
|
||||
" "
|
||||
(pop EXPR)
|
||||
@@ -512,25 +523,25 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
else (pop STRINGS)
|
||||
(pop STRWIDTHS))
|
||||
|
||||
(* ;; "Show environment")
|
||||
(* ;; "Show environment")
|
||||
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "Read table")
|
||||
TABSTOP) (* ; "Read table")
|
||||
(PFI.PRINT.ENVIRONMENT ENV :READTABLE)
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "Package")
|
||||
TABSTOP) (* ; "Package")
|
||||
(PFI.PRINT.ENVIRONMENT ENV :PACKAGE)
|
||||
(if (NEQ *PRINT-BASE* 10)
|
||||
then (PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP)
|
||||
(PFI.PRINT.ENVIRONMENT ENV :BASE)
|
||||
ELSE (pop STRINGS))
|
||||
else (pop STRINGS))
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "Format")
|
||||
TABSTOP) (* ; "Format")
|
||||
(PFI.PRINT.ENVIRONMENT ENV :FORMAT])
|
||||
|
||||
(PFI.PRINT.TO.TAB
|
||||
@@ -819,8 +830,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))
|
||||
)
|
||||
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
|
||||
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
|
||||
(FUNCTION CL:INTERN))))
|
||||
@@ -948,24 +959,24 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(FILESLOAD (SYSLOAD)
|
||||
DEFINERPRINT))
|
||||
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
|
||||
(MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
|
||||
S) (* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
S) (* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
LP (COND
|
||||
[(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
|
||||
(GETD S))
|
||||
(RETURN (PROG1 S
|
||||
(COND
|
||||
((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE"))
|
||||
(* ; "Also fix SEE")
|
||||
(* ; "Also fix SEE")
|
||||
(MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
|
||||
((SETQ SYMS (CDR SYMS))
|
||||
(GO LP))
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(RETURN 'LISTFILES1]
|
||||
'PFI.ORIGINAL.LISTFILES1 NIL T)
|
||||
|
||||
@@ -983,28 +994,28 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (10148 12383 (PFI.NEW.LISTFILES1 10158 . 10652) (PFI.ENQUEUE 10654 . 11278) (
|
||||
\PFI.DO.HARDCOPY 11280 . 11866) (MAYBE.PRETTYFILEINDEX 11868 . 12381)) (12384 35298 (PRETTYFILEINDEX
|
||||
12394 . 26826) (PFI.MAKE.LPT.STREAM 26828 . 29879) (PFI.SETUP.TRANSLATIONS 29881 . 31395) (
|
||||
PFI.OUTCHARFN 31397 . 33371) (PFI.COLLECT.DEFINERS 33373 . 34185) (PFI.AFTER.NEW.PAGE 34187 . 35296))
|
||||
(35299 40558 (PFI.PRINT.FILECREATED 35309 . 38825) (PFI.PRINT.TO.TAB 38827 . 39192) (
|
||||
PFI.PRINT.ENVIRONMENT 39194 . 40556)) (40559 47743 (PFI.PROCESS.FILE 40569 . 41799) (PFI.PASS.COMMENT
|
||||
41801 . 42771) (PFI.HANDLE.EXPR 42773 . 43440) (PFI.DEFAULT.HANDLER 43442 . 45495) (PFI.PRETTYPRINT
|
||||
45497 . 45832) (PFI.LINES.REMAINING 45834 . 46161) (PFI.MAYBE.NEW.PAGE 46163 . 46666) (
|
||||
PFI.ESTIMATE.SIZE 46668 . 47199) (PFI.ESTIMATE.SIZE1 47201 . 47741)) (47780 57267 (PFI.HANDLE.RPAQQ
|
||||
47790 . 49198) (PFI.HANDLE.DECLARE 49200 . 50139) (PFI.HANDLE.EVAL-WHEN 50141 . 50624) (
|
||||
PFI.HANDLE.DEFDEFINER 50626 . 51916) (PFI.HANDLE.DEFINEQ 51918 . 52162) (PFI.PRINT.LAMBDA 52164 .
|
||||
52502) (PFI.PRINT.LAMBDA.BODY 52504 . 52839) (PFI.HANDLE.PUTDEF 52841 . 53338) (PFI.HANDLE.PUTPROPS
|
||||
53340 . 53955) (PFI.HANDLE./DECLAREDATATYPE 53957 . 54504) (PFI.HANDLE.* 54506 . 55768) (
|
||||
PFI.PRINT.COMMENTS 55770 . 56670) (PFI.HANDLE.FILEMAP 56672 . 56960) (PFI.HANDLE.PACKAGE 56962 . 57265
|
||||
)) (57295 58287 (PFI.PREVIEW.DECLARE 57305 . 57967) (PFI.PREVIEW.DEFINEQ 57969 . 58285)) (58323 69311
|
||||
(PFI.PRINT.INDEX 58333 . 59184) (PFI.CONDENSE.INDEX 59186 . 60993) (PFI.SORT.INDICES 60995 . 62134) (
|
||||
PFI.COMPUTE.INDEX.SHAPE 62136 . 63600) (PFI.PRINT.INDICES 63602 . 68144) (PFI.CENTER.PRINT 68146 .
|
||||
68716) (PFI.INDEX.BREAK 68718 . 69176) (PFI.LOOKUP.NAME 69178 . 69309)) (69312 70543 (PFI.ADD.TO.INDEX
|
||||
69322 . 69832) (PFI.VARNAME 69834 . 70244) (PFI.CONSTANTNAMES 70246 . 70541)) (70578 78891 (
|
||||
MULTIFILEINDEX 70588 . 71384) (MULTIFILEINDEX1 71386 . 72842) (PFI.PRINT.MULTI.INDEX 72844 . 77947) (
|
||||
PFI.CHOOSE.BEST 77949 . 78176) (PFI.MERGE.INDICES 78178 . 78889)) (78948 80566 (PFI.MAYBE.SEE.PRETTY
|
||||
78958 . 79888) (PFI.MAYBE.PP.DEFINITION 79890 . 80564)) (80636 84471 (PFI.PRINT.BITMAP 80646 . 84469))
|
||||
(87316 90430 (PUTPROPS.PRETTYPRINT 87326 . 88737) (RPAQX.PRETTYPRINT 88739 . 89464) (
|
||||
COURIERPROGRAM.PRETTYPRINT 89466 . 90166) (MAYBE.PRETTYPRINT.BOLD 90168 . 90428)))))
|
||||
(FILEMAP (NIL (10070 12305 (PFI.NEW.LISTFILES1 10080 . 10574) (PFI.ENQUEUE 10576 . 11200) (
|
||||
\PFI.DO.HARDCOPY 11202 . 11788) (MAYBE.PRETTYFILEINDEX 11790 . 12303)) (12306 35220 (PRETTYFILEINDEX
|
||||
12316 . 26748) (PFI.MAKE.LPT.STREAM 26750 . 29801) (PFI.SETUP.TRANSLATIONS 29803 . 31317) (
|
||||
PFI.OUTCHARFN 31319 . 33293) (PFI.COLLECT.DEFINERS 33295 . 34107) (PFI.AFTER.NEW.PAGE 34109 . 35218))
|
||||
(35221 41169 (PFI.PRINT.FILECREATED 35231 . 39436) (PFI.PRINT.TO.TAB 39438 . 39803) (
|
||||
PFI.PRINT.ENVIRONMENT 39805 . 41167)) (41170 48354 (PFI.PROCESS.FILE 41180 . 42410) (PFI.PASS.COMMENT
|
||||
42412 . 43382) (PFI.HANDLE.EXPR 43384 . 44051) (PFI.DEFAULT.HANDLER 44053 . 46106) (PFI.PRETTYPRINT
|
||||
46108 . 46443) (PFI.LINES.REMAINING 46445 . 46772) (PFI.MAYBE.NEW.PAGE 46774 . 47277) (
|
||||
PFI.ESTIMATE.SIZE 47279 . 47810) (PFI.ESTIMATE.SIZE1 47812 . 48352)) (48391 57878 (PFI.HANDLE.RPAQQ
|
||||
48401 . 49809) (PFI.HANDLE.DECLARE 49811 . 50750) (PFI.HANDLE.EVAL-WHEN 50752 . 51235) (
|
||||
PFI.HANDLE.DEFDEFINER 51237 . 52527) (PFI.HANDLE.DEFINEQ 52529 . 52773) (PFI.PRINT.LAMBDA 52775 .
|
||||
53113) (PFI.PRINT.LAMBDA.BODY 53115 . 53450) (PFI.HANDLE.PUTDEF 53452 . 53949) (PFI.HANDLE.PUTPROPS
|
||||
53951 . 54566) (PFI.HANDLE./DECLAREDATATYPE 54568 . 55115) (PFI.HANDLE.* 55117 . 56379) (
|
||||
PFI.PRINT.COMMENTS 56381 . 57281) (PFI.HANDLE.FILEMAP 57283 . 57571) (PFI.HANDLE.PACKAGE 57573 . 57876
|
||||
)) (57906 58898 (PFI.PREVIEW.DECLARE 57916 . 58578) (PFI.PREVIEW.DEFINEQ 58580 . 58896)) (58934 69922
|
||||
(PFI.PRINT.INDEX 58944 . 59795) (PFI.CONDENSE.INDEX 59797 . 61604) (PFI.SORT.INDICES 61606 . 62745) (
|
||||
PFI.COMPUTE.INDEX.SHAPE 62747 . 64211) (PFI.PRINT.INDICES 64213 . 68755) (PFI.CENTER.PRINT 68757 .
|
||||
69327) (PFI.INDEX.BREAK 69329 . 69787) (PFI.LOOKUP.NAME 69789 . 69920)) (69923 71154 (PFI.ADD.TO.INDEX
|
||||
69933 . 70443) (PFI.VARNAME 70445 . 70855) (PFI.CONSTANTNAMES 70857 . 71152)) (71189 79502 (
|
||||
MULTIFILEINDEX 71199 . 71995) (MULTIFILEINDEX1 71997 . 73453) (PFI.PRINT.MULTI.INDEX 73455 . 78558) (
|
||||
PFI.CHOOSE.BEST 78560 . 78787) (PFI.MERGE.INDICES 78789 . 79500)) (79559 81177 (PFI.MAYBE.SEE.PRETTY
|
||||
79569 . 80499) (PFI.MAYBE.PP.DEFINITION 80501 . 81175)) (81247 85082 (PFI.PRINT.BITMAP 81257 . 85080))
|
||||
(87927 91041 (PUTPROPS.PRETTYPRINT 87937 . 89348) (RPAQX.PRETTYPRINT 89350 . 90075) (
|
||||
COURIERPROGRAM.PRETTYPRINT 90077 . 90777) (MAYBE.PRETTYPRINT.BOLD 90779 . 91039)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
598
lispusers/REGIONMANAGER
Normal file
598
lispusers/REGIONMANAGER
Normal file
@@ -0,0 +1,598 @@
|
||||
(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
|
||||
|
||||
:CHANGES-TO (FNS SET-TYPED-REGIONS \RELCREATEREGION.REF \RELCREATEREGION.SIZE)
|
||||
|
||||
:PREVIOUS-DATE " 1-Jan-2022 23:14:42"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGIONMANAGER.;95)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT REGIONMANAGERCOMS)
|
||||
|
||||
(RPAQQ REGIONMANAGERCOMS
|
||||
[
|
||||
(* ;; "Typed regions")
|
||||
|
||||
[COMS (FNS SET-TYPED-REGIONS)
|
||||
(FNS RM-CREATEW RM-CLOSEW RM-GETREGION CLOSE-TYPED-W)
|
||||
(INITVARS (TYPED-REGIONS))
|
||||
(GLOBALVARS TYPED-REGIONS)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TYPED-REGION REGION-SOURCE))
|
||||
(INITRECORDS TYPED-REGION REGION-SOURCE)
|
||||
(P (MOVD? 'CREATEW 'CREATEW.ORIG)
|
||||
(MOVD? 'CLOSEW 'CLOSEW.ORIG)
|
||||
(MOVD? 'GETREGION 'GETREGION.ORIG)
|
||||
(MOVD 'RM-CREATEW 'CREATEW)
|
||||
(MOVD 'RM-CLOSEW 'CLOSEW)
|
||||
(MOVD 'RM-GETREGION 'GETREGION]
|
||||
|
||||
(* ;; "Relative regions")
|
||||
|
||||
(COMS (FNS RELCREATEREGION RELGETREGION)
|
||||
(FNS \RELCREATEREGION.REF \RELCREATEREGION.SIZE))
|
||||
|
||||
(* ;; "Composite application construction")
|
||||
|
||||
(COMS (FNS RM-ATTACHWINDOW)
|
||||
(P (MOVD? 'ATTACHWINDOW 'ATTACHWINDOW.ORIG)
|
||||
(MOVD 'RM-ATTACHWINDOW 'ATTACHWINDOW))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (MACROS RFIELDDIFF])
|
||||
|
||||
|
||||
|
||||
(* ;; "Typed regions")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(SET-TYPED-REGIONS
|
||||
[LAMBDA (TYPELISTS REPLACE) (* ; "Edited 2-Jan-2022 16:01 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 16:17 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 12:59 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 08:55 by rmk:")
|
||||
(* ; "Edited 26-Oct-2021 18:04 by rmk:")
|
||||
|
||||
(* ;; "User can pre-initialize a sequence of regions for a given type. Generally, TYPELISTS is a list of the form")
|
||||
|
||||
(* ;; " ((TYPEATOM1 . REGIONS)...(TYPEATOMn . REGIONS). Copies of the regions of TYPELIST are added in front of any regions that might already be present for that type. The regions have haslinks to its type and an inuse status indicator.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Convenience cases:")
|
||||
|
||||
(* ;;
|
||||
" TYPEATOM: Interpreted as ((TYPEATOM)): No region specified, but regions can accumulate")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " (TYPEATOM .REGIONS): Interpreted as ((TYPEATOM . REGIONS).")
|
||||
|
||||
(if (LITATOM TYPELISTS)
|
||||
then (SETQ TYPELISTS (CONS (CONS TYPELISTS)))
|
||||
elseif (LITATOM (LISTP TYPELISTS))
|
||||
then (SETQ TYPELISTS (CONS TYPELISTS)))
|
||||
(for TL TYPE REGIONS PREV in TYPELISTS
|
||||
do (SETQ TYPE (CAR TL))
|
||||
(SETQ REGIONS (CDR TL))
|
||||
(CL:UNLESS (AND TYPE (LITATOM TYPE)
|
||||
(for R in REGIONS always (REGIONP R)))
|
||||
(ERROR "Not a TYPED-REGIONS specification" REGIONS))
|
||||
(SETQ REGIONS (COPY REGIONS)) (* ;
|
||||
"Not to be confused with any other equal regions.")
|
||||
(if (SETQ PREV (ASSOC TYPE TYPED-REGIONS))
|
||||
then [RPLACD PREV (CL:IF REPLACE
|
||||
REGIONS
|
||||
(NCONC REGIONS (CDR PREV)))]
|
||||
else (push TYPED-REGIONS (CONS TYPE REGIONS])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(RM-CREATEW
|
||||
[LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 1-Jan-2022 23:12 by rmk")
|
||||
(* ; "Edited 29-Dec-2021 19:25 by rmk")
|
||||
|
||||
(* ;; "Generic CREATEW function for managed regions. If REGIONTYPE is specified (as REGION or in PROPS), then we try to find a previous region for that type that is currently unused, create one if needed.")
|
||||
|
||||
(* ;; "We have to bracket the original window creation because the we have to mark that the window uses that region, to put it back in the pool when the window is closed.")
|
||||
|
||||
(LET (WINDOW REGIONTYPE TYPEDREGION TYPELIST)
|
||||
[SETQ REGIONTYPE (if (AND REGION (LITATOM REGION))
|
||||
then (PROG1 REGION (SETQ REGION NIL))
|
||||
else (LISTGET PROPS 'REGION-TYPE]
|
||||
(SETQ TYPELIST (ASSOC REGIONTYPE TYPED-REGIONS))
|
||||
|
||||
(* ;; "We have REGIONTYPE, but maybe also a region that already has a source. Maybe we should make sure that the source is of that type?")
|
||||
|
||||
(* ;; "Note: REGION can also be a screenregion, that falls through.")
|
||||
|
||||
(IF (REGIONP REGION)
|
||||
THEN (SETQ TYPEDREGION (FETCH REGION-SOURCE OF REGION))
|
||||
ELSEIF TYPELIST
|
||||
THEN
|
||||
(* ;;
|
||||
"If we don't find an unused region, CREATEW will create one in the ordinary way. We type it below.")
|
||||
|
||||
[SETQ TYPEDREGION (FIND R FOUND in (CDR TYPELIST)
|
||||
SUCHTHAT (NOT (fetch REGION-INUSE of R]
|
||||
(SETQ REGION TYPEDREGION))
|
||||
(SETQ WINDOW (CREATEW.ORIG REGION TITLE BORDERSIZE NOOPENFLG PROPS))
|
||||
|
||||
(* ;; "CREATEW doesn't call the user-entry GETREGION, so we have to trap and install its return region here.")
|
||||
|
||||
(CL:WHEN (AND TYPELIST (NULL TYPEDREGION)) (* ;
|
||||
"If not, we don't record this even if typed.")
|
||||
(SETQ TYPEDREGION (OR (FETCH REGION-SOURCE OF (SETQ REGION (WINDOWREGION WINDOW)))
|
||||
(COPY REGION)))
|
||||
(NCONC1 TYPELIST TYPEDREGION))
|
||||
(CL:WHEN TYPEDREGION
|
||||
(replace REGION-INUSE of TYPEDREGION with T)
|
||||
(WINDOWPROP WINDOW 'TYPED-REGION TYPEDREGION)
|
||||
(WINDOWPROP WINDOW 'REGION-TYPE REGIONTYPE))
|
||||
WINDOW])
|
||||
|
||||
(RM-CLOSEW
|
||||
[LAMBDA (WINDOW) (* ; "Edited 29-Dec-2021 15:44 by rmk")
|
||||
(* ; "Edited 28-Dec-2021 11:02 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 10:00 by rmk:")
|
||||
(* ; "Edited 26-Oct-2021 21:54 by rmk:")
|
||||
(* ;
|
||||
"Edited 25-Apr-94 10:08 by sybalsky")
|
||||
(* ; "")
|
||||
|
||||
(* ;;
|
||||
"Makes the window's typed region available for reuse, if the window is marked with a TYPEDREGION.")
|
||||
|
||||
(* ;; "It's possible that the window exists and can be reopened after it has been closed. The glitch in that case is that we may have decided to make the window's region available to another window, and if this window is opened again it will come on top of that other one (if it hasn't moved). Oh well.")
|
||||
|
||||
(LET [(TYPEDREGION (WINDOWPROP WINDOW 'TYPED-REGION]
|
||||
(CL:WHEN (AND (CLOSEW.ORIG WINDOW)
|
||||
TYPEDREGION)
|
||||
(REPLACE REGION-INUSE OF TYPEDREGION WITH NIL)
|
||||
(WINDOWPROP WINDOW 'TYPED-REGION NIL)
|
||||
T)])
|
||||
|
||||
(RM-GETREGION
|
||||
[LAMBDA (MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS)
|
||||
(* ; "Edited 1-Jan-2022 21:49 by rmk")
|
||||
|
||||
(* ;; "If INITREGION is a type atom and a region of that type is available, then use it as the INITREGION. Otherwise, add a copy of the new region to the available list, and assert that the new region has the copy as its source.")
|
||||
|
||||
(* ;; "We don't know what will happen to the new region, but if it ends up as a region for CREATEW, the source information enables us to mark its source as inuse.")
|
||||
|
||||
(* ;; "This allows for the possibility that the application is actually asking the user for a constellation region that will be shrunk in anticipation of future satellite attachments. A future retrieval will return the original size and position, and it will then presumably be shrunk in the same way.")
|
||||
|
||||
(LET (REGION (TYPELIST (ASSOC (CL:WHEN (AND INITREGION (LITATOM INITREGION))
|
||||
INITREGION)
|
||||
TYPED-REGIONS)))
|
||||
(FOR R in (CDR TYPELIST) UNLESS (fetch REGION-INUSE of R)
|
||||
WHEN [AND (OR (NULL MINWIDTH)
|
||||
(ILEQ MINWIDTH (FETCH WIDTH OF R)))
|
||||
(OR (NULL MINHEIGHT)
|
||||
(ILEQ MINHEIGHT (FETCH HEIGHT OF R]
|
||||
DO
|
||||
(* ;; "Copy so the caller can update the region without affecting the recyclable source, but remember what it is based on. We don't mark it as used here, maybe a window won't be built around it and it will fade away. However, there is the risk that another GETREGION will find the same source before it is given to a window, in which case 2 windows might open up in the same place.")
|
||||
|
||||
(SETQ REGION (COPY R))
|
||||
(REPLACE REGION-SOURCE OF REGION WITH R)
|
||||
(RETURN))
|
||||
|
||||
(* ;; "If we found a good one, we're done. Otherwise, run the normal code, but save the new region if it is typed.")
|
||||
|
||||
(CL:UNLESS REGION
|
||||
(SETQ REGION (GETREGION.ORIG MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG
|
||||
INITCORNERS))
|
||||
(CL:WHEN TYPELIST
|
||||
|
||||
(* ;;
|
||||
"The new region is based on a typed region. The saved source is a copy of what we return.")
|
||||
|
||||
(NCONC1 TYPELIST (REPLACE REGION-SOURCE OF REGION WITH (COPY REGION)))))
|
||||
REGION])
|
||||
|
||||
(CLOSE-TYPED-W
|
||||
[LAMBDA (TYPE) (* ; "Edited 29-Dec-2021 15:58 by rmk")
|
||||
(* ; "Edited 27-Nov-2021 11:50 by rmk:")
|
||||
|
||||
(* ;; "Closes all windows of REGIONTYPE inside TYPE")
|
||||
|
||||
(CL:WHEN TYPE
|
||||
(for W R in (OPENWINDOWS) when (AND (SETQ WT (WINDOWPROP W 'REGION-TYPE))
|
||||
(EQMEMB WT TYPE)) do (CLOSEW W)))])
|
||||
)
|
||||
|
||||
(RPAQ? TYPED-REGIONS )
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS TYPED-REGIONS)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(HASHLINK TYPED-REGION (REGION-INUSE REGION-INUSE-HASH))
|
||||
|
||||
(HASHLINK REGION-SOURCE (REGION-SOURCE REGION-SOURCE-HASH))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-INUSE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-INUSE-HASH NIL)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-SOURCE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-SOURCE-HASH NIL)
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-INUSE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-INUSE-HASH NIL)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE (GLOBALVARS REGION-SOURCE-HASH))
|
||||
|
||||
(SETUPHASHARRAY 'REGION-SOURCE-HASH NIL)
|
||||
|
||||
(MOVD? 'CREATEW 'CREATEW.ORIG)
|
||||
|
||||
(MOVD? 'CLOSEW 'CLOSEW.ORIG)
|
||||
|
||||
(MOVD? 'GETREGION 'GETREGION.ORIG)
|
||||
|
||||
(MOVD 'RM-CREATEW 'CREATEW)
|
||||
|
||||
(MOVD 'RM-CLOSEW 'CLOSEW)
|
||||
|
||||
(MOVD 'RM-GETREGION 'GETREGION)
|
||||
|
||||
|
||||
|
||||
(* ;; "Relative regions")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(RELCREATEREGION
|
||||
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) (* ; "Edited 30-Dec-2021 20:54 by rmk")
|
||||
(* ; "Edited 27-Dec-2021 15:54 by rmk")
|
||||
|
||||
(* ;; "The region is oriented so that he REFX and REFY are at the corner named by CORNERX/Y. ")
|
||||
|
||||
(* ;; "Creates a WIDTH-HEIGHT region relative to the CORNER and REF parameters.")
|
||||
|
||||
(* ;; "CORNERX and CORNERY default to LEFT and BOTTOM. ")
|
||||
|
||||
(* ;; "REFX and REFY default to the current cursor screen coordinates. Otherwise, ")
|
||||
|
||||
(* ;; " REFX is a position and REFY is NIL: REFX and REFY are extracted from the position")
|
||||
|
||||
(* ;; " Positive integers: absolute screen coordinates")
|
||||
|
||||
(* ;;
|
||||
" (region spec) or (window spec) pairs: coordinates relative to the region or the window's region")
|
||||
|
||||
(* ;; " Spec can name the X/Y endpoints (e.g. LEFT/0 or RIGHT/1) or a floating point proportion of the distance on the relevant dimension (e.g. .5= the midpoint.")
|
||||
|
||||
(* ;; "If ONSCREEN, the width or height is adjusted so that the corner opposite to the fixed corner is always visible.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Resolve the width and height, if based on a region or window ")
|
||||
|
||||
(SETQ WIDTH (\RELCREATEREGION.SIZE WIDTH 'X))
|
||||
(SETQ HEIGHT (\RELCREATEREGION.SIZE HEIGHT 'Y))
|
||||
|
||||
(* ;; "Resolve the corner")
|
||||
|
||||
(CL:UNLESS CORNERX
|
||||
(SETQ CORNERX 'LEFT))
|
||||
(CL:UNLESS CORNERY
|
||||
(SETQ CORNERY 'BOTTOM))
|
||||
(CL:WHEN (AND (LISTP CORNERX)
|
||||
(NULL CORNERY))
|
||||
(SETQ CORNERY (CADR CORNERX))
|
||||
(SETQ CORNERX (CAR CORNERX)))
|
||||
|
||||
(* ;; "Resolve the reference point")
|
||||
|
||||
[IF (AND (POSITIONP REFX)
|
||||
(NULL REFY))
|
||||
THEN (SETQ REFY (FETCH (POSITION YCOORD) OF REFX))
|
||||
(SETQ REFX (FETCH (POSITION XCOORD) OF REFX))
|
||||
ELSE (GETMOUSESTATE)
|
||||
(SETQ REFX (\RELCREATEREGION.REF REFX 'X))
|
||||
(SETQ REFY (\RELCREATEREGION.REF REFY 'Y]
|
||||
|
||||
(* ;; "Align the new-region corner with the reference point")
|
||||
|
||||
(LET* ((LEFT REFX)
|
||||
(BOTTOM REFY)
|
||||
(RIGHT (IPLUS LEFT WIDTH))
|
||||
(TOP (IPLUS BOTTOM HEIGHT)))
|
||||
(CL:WHEN (EQ 'RIGHT CORNERX)
|
||||
(SETQ RIGHT LEFT)
|
||||
(SETQ LEFT (IDIFFERENCE LEFT WIDTH)))
|
||||
(CL:WHEN (EQ 'TOP CORNERY)
|
||||
(SETQ TOP BOTTOM)
|
||||
(SETQ BOTTOM (IDIFFERENCE BOTTOM HEIGHT)))
|
||||
(CL:WHEN ONSCREEN (* ; "Keep the region on the screen. ")
|
||||
(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])
|
||||
|
||||
(RELGETREGION
|
||||
[LAMBDA (WIDTH HEIGHT CORNERX CORNERY REFX REFY MINSIZE) (* ; "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)))
|
||||
|
||||
(* ;; "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])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\RELCREATEREGION.REF
|
||||
[LAMBDA (REF WHICH) (* ; "Edited 2-Jan-2022 11:01 by rmk")
|
||||
|
||||
(* ;; "REF can be NIL, an absolute screen position, the atom SCREEN, or a list of (anchor fraction adjustment) where anchor can be a region, window, or the atom SCREEN, fraction can be a number or atoms LEFT/RIGHT/BOTTOM/TOP as apropriate.")
|
||||
(* ; "Edited 30-Dec-2021 17:49 by rmk")
|
||||
(LET (ANCHOR VAL SIZE FRACTION SPEC (BASE 0))
|
||||
|
||||
(* ;; "Would be nice if the screen had a region")
|
||||
|
||||
(IF (NULL REF)
|
||||
THEN (CL:IF (EQ WHICH 'X)
|
||||
LASTMOUSEX
|
||||
LASTMOUSEY)
|
||||
ELSEIF (AND (FIXP REF)
|
||||
(NOT (MINUSP REF)))
|
||||
THEN REF
|
||||
ELSEIF (EQ REF 'SCREEN)
|
||||
THEN
|
||||
(* ;; "LEFT and BOTTOM are 0")
|
||||
|
||||
0
|
||||
ELSEIF [AND (LISTP REF)
|
||||
(SETQ ANCHOR (OR (REGIONP (CAR REF))
|
||||
(AND (WINDOWP (CAR REF))
|
||||
(WINDOWREGION (CAR REF)))
|
||||
(AND (EQ (CAR REF)
|
||||
'SCREEN)
|
||||
'SCREEN]
|
||||
THEN (SETQ SPEC (CDR REF))
|
||||
[IF (EQ WHICH 'X)
|
||||
THEN (IF (EQ ANCHOR 'SCREEN)
|
||||
THEN (SETQ SIZE SCREENWIDTH)
|
||||
ELSE (SETQ BASE (FETCH (REGION LEFT) OF ANCHOR))
|
||||
(SETQ SIZE (FETCH (REGION WIDTH) OF ANCHOR)))
|
||||
(SETQ FRACTION (SELECTQ (CAR SPEC)
|
||||
((NIL LEFT)
|
||||
0)
|
||||
(RIGHT 1)
|
||||
(CAR SPEC)))
|
||||
ELSE (IF (EQ ANCHOR 'SCREEN)
|
||||
THEN (SETQ SIZE SCREENHEIGHT)
|
||||
ELSE (SETQ BASE (FETCH (REGION BOTTOM) OF ANCHOR))
|
||||
(SETQ SIZE (FETCH (REGION HEIGHT) OF ANCHOR)))
|
||||
(SETQ FRACTION (SELECTQ (CAR SPEC)
|
||||
((NIL BOTTOM)
|
||||
0)
|
||||
(TOP 1)
|
||||
(CAR SPEC]
|
||||
[SETQ VAL (IPLUS BASE (ROUND (TIMES FRACTION SIZE]
|
||||
(CL:WHEN (CADR SPEC)
|
||||
(ADD VAL (CADR SPEC)))
|
||||
VAL
|
||||
ELSE (\ILLEGAL.ARG REF])
|
||||
|
||||
(\RELCREATEREGION.SIZE
|
||||
[LAMBDA (PARAM WHICH) (* ; "Edited 2-Jan-2022 11:00 by rmk")
|
||||
(* ; "Edited 30-Dec-2021 17:51 by rmk")
|
||||
|
||||
(* ;;
|
||||
"PARAM can be FIXP or (region anchor adjustment) which determine size relative to the region.")
|
||||
|
||||
(LET (VAL ANCHOR SPEC)
|
||||
(IF (FIXP PARAM)
|
||||
ELSEIF [SETQ ANCHOR (OR (REGIONP PARAM)
|
||||
(AND (WINDOWP PARAM)
|
||||
(WINDOWREGION PARAM]
|
||||
THEN (CL:IF (EQ WHICH 'X)
|
||||
(FETCH WIDTH OF ANCHOR)
|
||||
(FETCH HEIGHT OF ANCHOR))
|
||||
ELSEIF (LISTP PARAM)
|
||||
THEN (IF (SETQ ANCHOR (OR (REGIONP (CAR PARAM))
|
||||
(AND (WINDOWP (CAR PARAM))
|
||||
(WINDOWREGION (CAR PARAM)))
|
||||
(AND (EQ (CAR PARAM)
|
||||
'SCREEN)
|
||||
'SCREEN)
|
||||
(\ILLEGAL.ARG PARAM)))
|
||||
THEN [SETQ VAL (CL:IF (EQ WHICH 'X)
|
||||
(CL:IF (EQ ANCHOR 'SCREEN)
|
||||
SCREENWIDTH
|
||||
(FETCH WIDTH OF ANCHOR))
|
||||
(CL:IF (EQ ANCHOR 'SCREEN)
|
||||
SCREENHEIGHT
|
||||
(FETCH HEIGHT OF ANCHOR)))]
|
||||
(SETQ SPEC (CDR PARAM))
|
||||
(CL:WHEN (CAR SPEC)
|
||||
(SETQ VAL (ROUND (TIMES (CAR SPEC)
|
||||
VAL))))
|
||||
(CL:WHEN (CADR SPEC)
|
||||
(ADD VAL (CADR SPEC)))
|
||||
VAL)
|
||||
ELSEIF (EQ PARAM 'SCREEN)
|
||||
THEN (CL:IF (EQ WHICH 'X)
|
||||
SCREENWIDTH
|
||||
SCREENHEIGHT)
|
||||
ELSE (\ILLEGAL.ARG PARAM])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Composite application construction")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(RM-ATTACHWINDOW
|
||||
[LAMBDA (WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION TAKEFROMCENTRAL)
|
||||
(* ; "Edited 29-Dec-2021 09:36 by rmk")
|
||||
(* ; "Edited 28-Nov-2021 16:10 by rmk:")
|
||||
|
||||
(* ;; "MAINWINDOW may not be the central window, could be attached to an attachment.")
|
||||
|
||||
(* ;; "If the central window is under construction, we shrink it down so that the new attachment fits within the original footprint of the central window and all of its previous attachments.")
|
||||
|
||||
(* ;; "This addresses the common situation where the user provides a region for the central window and the constellation of windows that will surround it, and the whole constellation is supposed to stay within that original bounding box, even as new attachments (promptwindows, menus...) are tacked on.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "A second extension: If WINDOWCOMACTION is a list, smash it into the PASSTOMAINCOMS. ATTACHWINDOW.ORIG only allows a few atomic-value options.")
|
||||
|
||||
(LET (MIN (CENTRALWINDOW (CENTRALWINDOW MAINWINDOW))
|
||||
CENTRALREGION NEWALLREGION ORIGALLREGION NEWCENTRALREGION VAL)
|
||||
(CL:WHEN (OR TAKEFROMCENTRAL (WINDOWPROP CENTRALWINDOW 'UNDERCONSTRUCTION))
|
||||
(SETQ ORIGALLREGION (ATTACHEDWINDOWREGION CENTRALWINDOW))
|
||||
(SETQ CENTRALREGION (WINDOWREGION CENTRALWINDOW)))
|
||||
(SETQ VAL (ATTACHWINDOW.ORIG WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION))
|
||||
(CL:WHEN ORIGALLREGION
|
||||
(SETQ NEWALLREGION (ATTACHEDWINDOWREGION CENTRALWINDOW))
|
||||
(CL:UNLESS (EQUAL ORIGALLREGION NEWALLREGION)
|
||||
|
||||
(* ;; "Something changed, presumably the total region expanded, so something has to shrink to stay within the original region. We want to shrink the main window only, keeping everything else as it was. Hopefully, previously attached windows that wanted a fixed size on the relevant dimension have a MINSIZE that won't let them shrink. And hopefully the central window does allow shrinking, otherwise nothing happens.")
|
||||
|
||||
(* ;; "It also could be that the region hasn't changed, if the new window hides in the shadow of a previously attached one.")
|
||||
|
||||
(SETQ NEWCENTRALREGION (SELECTQ EDGE
|
||||
(LEFT (CREATE REGION USING CENTRALREGION LEFT _
|
||||
(PLUS (FETCH (REGION LEFT)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF LEFT
|
||||
ORIGALLREGION
|
||||
NEWALLREGION))
|
||||
WIDTH _
|
||||
(DIFFERENCE
|
||||
(FETCH (REGION WIDTH)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF WIDTH
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(RIGHT (CREATE REGION USING CENTRALREGION WIDTH _
|
||||
(DIFFERENCE
|
||||
(FETCH (REGION WIDTH)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF WIDTH
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(TOP (CREATE REGION USING CENTRALREGION HEIGHT _
|
||||
(DIFFERENCE (FETCH (REGION
|
||||
HEIGHT)
|
||||
OF CENTRALREGION
|
||||
)
|
||||
(RFIELDDIFF HEIGHT
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(BOTTOM (CREATE REGION
|
||||
USING CENTRALREGION BOTTOM _
|
||||
(PLUS (FETCH (REGION BOTTOM)
|
||||
OF CENTRALREGION)
|
||||
(RFIELDDIFF BOTTOM ORIGALLREGION
|
||||
NEWALLREGION))
|
||||
HEIGHT _ (DIFFERENCE (FETCH (REGION
|
||||
HEIGHT)
|
||||
OF CENTRALREGION
|
||||
)
|
||||
(RFIELDDIFF HEIGHT
|
||||
NEWALLREGION
|
||||
ORIGALLREGION))))
|
||||
(SHOULDNT)))
|
||||
|
||||
(* ;; "We want to reshape only the central window. We detach the new (just attached) window, do the shrinking, then reattach. If other attached windows get reshaped, that's par for the course. Presumably they are specified as fixed on the relevant dimension, or the user doesn't care.")
|
||||
|
||||
(* ;; "Maybe this little wrinkle is solving a non-problem--if the user cares about whether or not the new window will shrink, now or with later reshaping, then he should have specified its own minsize property.")
|
||||
|
||||
(* ;; "On the otherhand, maybe we should remove all of the SHAPEW's (or but in DONT) in the PASSTOMAIN coms of all the windows attached directly or indirectly to the central window, do the reshaping, and then restore.")
|
||||
|
||||
(DETACHWINDOW WINDOWTOATTACH MAINWINDOW)
|
||||
(SHAPEW CENTRALWINDOW NEWCENTRALREGION)
|
||||
|
||||
(* ;; "Now reattach the new window")
|
||||
|
||||
(SETQ VAL (ATTACHWINDOW.ORIG WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE
|
||||
WINDOWCOMACTION))
|
||||
|
||||
(* ;; "This is a little error check for debugging, to catch cases where there might be interactions with other interfering strategies. If the new window turned out to be bigger on the relevant dimension than the original set up, then we simply have to relax.")
|
||||
|
||||
(* ;; "If the new window is bigger than the original region on the other dimenion dimension, then we have to relax our requirement. We use ATTACHEDWINDOWREGION in case the new window is already a conglomerate.")
|
||||
|
||||
(CL:UNLESS (OR (EQUAL ORIGALLREGION (ATTACHEDWINDOWREGION CENTRALWINDOW))
|
||||
(SELECTQ EDGE
|
||||
((TOP BOTTOM)
|
||||
(GEQ (FETCH (REGION WIDTH) OF (ATTACHEDWINDOWREGION
|
||||
WINDOWTOATTACH
|
||||
'REGION))
|
||||
(FETCH (REGION WIDTH) OF ORIGALLREGION)))
|
||||
((LEFT RIGHT)
|
||||
(GEQ (FETCH (REGION HEIGHT) OF (ATTACHEDWINDOWREGION
|
||||
WINDOWTOATTACH
|
||||
'REGION))
|
||||
(FETCH (REGION HEIGHT) OF ORIGALLREGION)))
|
||||
NIL))
|
||||
(HELP ORIGALLREGION (ATTACHEDWINDOWREGION MAINWINDOW)))
|
||||
(CL:WHEN (LISTP WINDOWCOMACTION)
|
||||
|
||||
(* ;; "Maybe this should be done in the ORIG function--an oversight?")
|
||||
|
||||
(WINDOWPROP WINDOWTOATTACH 'PASSTOMAINCOMS WINDOWCOMACTION))))
|
||||
VAL])
|
||||
)
|
||||
|
||||
(MOVD? 'ATTACHWINDOW 'ATTACHWINDOW.ORIG)
|
||||
|
||||
(MOVD 'RM-ATTACHWINDOW 'ATTACHWINDOW)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS RFIELDDIFF MACRO ((FIELD R1 R2)
|
||||
(DIFFERENCE (FETCH (REGION FIELD) OF R1)
|
||||
(FETCH (REGION FIELD) OF R2))))
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (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)))))
|
||||
STOP
|
||||
BIN
lispusers/REGIONMANAGER.LCOM
Normal file
BIN
lispusers/REGIONMANAGER.LCOM
Normal file
Binary file not shown.
59
lispusers/REGIONMANAGER.TEDIT
Normal file
59
lispusers/REGIONMANAGER.TEDIT
Normal file
@@ -0,0 +1,59 @@
|
||||
Medley REGIONMANAGER2
|
||||
|
||||
4
|
||||
|
||||
1
|
||||
|
||||
REGIONMANAGER
|
||||
1
|
||||
|
||||
4
|
||||
|
||||
By:
|
||||
Ron Kaplan
|
||||
This document created in December 2021.
|
||||
|
||||
Medley comes equipped with a core set of functions for specifying regions and creating the windows that occupy those regions on the screen. But it can be disruptive if not irritating to have to draw out a new ghost region for every invocation of a particular application. Thus the common applications (e.g. TEDIT, SEDIT, DINFO...) implement particular strategies to reduce the number of times that a user has to sweep out a new region. They instead default to regions that were allocated for earlier invocations that are no longer active. TEDIT for example recycles the region of a session that was recently shut down, SEDIT allocates from a list of previous regions, DINFO always uses the same region, but FILEBROWSER always prompts for a new one. Applications that do recycle their regions tend to do so indiscrimately, without regard to the current arrangement of other windows on the screen or the role that those windows may play in higher-level applications.
|
||||
The REGIONMANAGER package provides simple extensions to the core region and window functions. These are aimed at giving users and application implementors more flexible and systematic control over the specification and reuse of screen regions. It introduces three new notions:
|
||||
A "typed region" allows the regions of particular applications to be specified, classified, and recycled according to their types.
|
||||
The size, location, and orientation of a "relative region" is specified with respect to particular screen points and the location of other windows.
|
||||
A "constellation region" encloses the collection of satellite windows (prompts, menus, etc) that surround the central window of an application.
|
||||
REGIONMANAGER is innocuous in that explicit user action is required to change the default behavior of any system components.
|
||||
|
||||
Typed regions
|
||||
REGIONMANAGER adds overlay veneers to the core CREATEW, CLOSEW, and GETREGION functions to make it easier to predict and control how different applications arrange their windows on the screen without always needing to respond to a ghost-region prompt.
|
||||
The REGION/INITREGION arguments may now be region-type atoms in addition to either NIL or particular regions as CREATEW and GETREGION otherwise allow. The type-atom will resolve to a region drawn from a predefined pool of regions associated with that type, if the pool has at least one that is not currently allocated to another window. If the pool has no available regions, then the pool will be enlarged with a region that the user produces from a normal ghost-region prompt, and the type-atom will then resolve to the newly installed region.
|
||||
A typed-region is marked as "inuse" and therefore unavailable when CREATEW assigns it to a window, and the extended CLOSEW marks it as again available when the window is closed.
|
||||
An example of how an application can take advantage of this facility is the TEDIT-PF-SEE package. This provides lightweight alternatives to the PF and SEE commands that print their output to scrollable read-only Tedit windows, specifying PF-TEDIT and SEE-TEDIT as their region types. The user can predefine a preference-ordered sequence of recyclable regions that bring up multiple output windows in a predictable tiled arrangement, without region-prompting for each invocation.
|
||||
The global variable TYPED-REGIONS is an alist that maintains the relationship between atomic type-names and the list of regions that belong to each type. The list is ordered according to preferences set by the user, and a type-atom is always resolved to the first unused region in its list. If the user is asked to sweep out a new region, that region is added at the end, as the least preferable. The function SET-TYPED-REGIONS is provided to add or replace TYPED-REGION entries.
|
||||
(SET-TYPED-REGIONS TYPELISTS REPLACE) [Function]
|
||||
TYPELISTS is an alist of the form
|
||||
((type1 . regions1)(type2 . regions2)...)
|
||||
where each regioni is a possibly empty list of regions. For convenience, if TYPELISTS is just a literal type-atom, it is interpreted as ((type)), and if it is a list (type . regions) begining with an atom, it is interpreted as ((type . regions). The new regions replace preexisting regions if REPLACE, otherwise they are added at the front.
|
||||
Typically, a call to SET-TYPED-REGIONS would be placed in a user's INIT file to set up the preference order for the regions that the user wants to participate in this reallocation scheme. If an application uses a type that is not on TYPED-REGIONS, then that type-atom is treated as NIL and always gives rise to the normal ghost-region prompting. Thus a user will observe no change in system behavior if TYPED-REGIONS is left with its initial value NIL. A type that is added with an empty region list (as opposed to not being on the list at all) will allow new regions to accumulate for recycling.
|
||||
|
||||
Relative regions
|
||||
Two functions are provided to make it easy to create regions relative and oriented with respect to a specified reference point. These may be useful for constructing an application that includes a constellation of windows arranged in a particular relative way.
|
||||
(RELCREATEREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY ONSCREEN) [Function]
|
||||
RELCREATEREGION creates a region of dimensions WIDTH and HEIGHT. One of its corners is identified by CORNERX and CORNERY and that corner will be aligned with a reference screen-point determined by REFX and REFY. If ONSCREEN, the WIDTH or HEIGHT will be adjusted with respect to that alignment so that the resulting region is entirely within the screen.
|
||||
WIDTH and HEIGHT can be given as absolute (natural) numbers) or specified relative to the WIDTH and HEIGHT of another region or of the screen. The possibilities are interpreted as follows:
|
||||
natural number: the number of screen points
|
||||
list of the form (anchor fraction adjustment), where anchor is a region, window, or the atom SCREEN. The corres-ponding dimension of the anchor is mutiplied by fraction and adjustment is added to the result. For example, specifying (<window> .5 -1) results in a WIDTH that is one point smaller than half the width of window's region. Fraction and adjustment default to 1 and 0 respectively.
|
||||
region/window/SCREEN: equivalent to (region/window/SCREEN 1 0).
|
||||
CORNERX can be LEFT, RIGHT, or NIL=LEFT, CORNERY can be BOTTOM, TOP, or NIL=BOTTOM. If LEFT/TOP are specified, for example, the region will be splayed down and to the right of the reference point. If RIGHT/BOTTOM, then up and to the left.
|
||||
The reference-point arguments REFX and REFY are interpreted as follows:
|
||||
NIL: LASTMOUSEX/LASTMOUSEY
|
||||
natural number: an absolute screen coordinate
|
||||
(anchor fraction adjustment) or just region/window/SCREEN: the quantity determined relative to the size of anchor (as above) is added to the anchors left/bottom produce the REFX/REFY coordinate. In this case, fractions specified as LEFT/BOTTOM/NIL are interpreted as 0 and RIGHT/TOP are interpreted as 1. For example, a specification (<window> .4 -2) for REFY will produce a coordinate 2 points below the level that is 40% of the distance between the bottom and top of the window's region.
|
||||
For convenience, if REFX is a position and REFY is NIL, then the XCOORD and YCOORD of REFX are taken as absolute values for REFX and REFY.
|
||||
|
||||
(RELGETREGION WIDTH HEIGHT CORNERX CORNERY REFX REFY MINSIZE) [Function]
|
||||
Calls GETREGION with an initial ghost region as created by RELCREATEREGION. CORNERX and CORNERY determine the ghost region's fixed corner, and the cursor starts at the region's diagonally opposite corner. If MINSIZE is true, then WIDTH and HEIGHT are taken as the minimum sizes of the region, except for adjustments that may be needed to ensure that all corners of the ghost region are initially visible on the screen.
|
||||
|
||||
Constellation regions
|
||||
Applications are often set up as a constellation of windows, a central or primary window surrounded by some number of satellites for menus, headers, prompts, and secondary outputs. The main panel of a file browser, for example, displays the list of files, but above it are carefully arranged windows for the column headers, summary information, and prompts, and off to the side is the menu of file browser commands. FILEBROWSER interprets the screen region that the user sweeps out for a new browser as the region for the whole constellation,the smallest region that will enclose the central window and all of its satellites. Similarly, the screen region given to TEDIT and SEDIT is divided between the prompt window and the central editing window, again so that the whole constellation (a pair in these cases) fit within the provided region.
|
||||
Each of these applications is constructed by anticipating the subregions that the satellite windows will occupy after they are attached, decreasing the constellation region by their estimated (using WIDTHIFWINDOW HEIGHTIFWINDOW) or actual sizes, and then using remainder as the region for the central window.
|
||||
An alternative approach is to construct the central window first, giving it the entire constellation region, and then to have ATTACHWINDOW reshape that window to accomodate the satellite windows as they are attached in sequence. This leads to the same final configuration, but there is no need for separate calculations to pre-adjust the region of the central window.
|
||||
REGIONMANAGER provides an overlay veneer for ATTACHWINDOW that implements this strategy. If the new argument TAKEFROMCENTRAL is true, then the region of the WINDOWTOATTACH will be substracted from the region of the existing central window according to the EDGE parameter of the attachment.
|
||||
(ATTACHWINDOW WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION TAKEFROMCENTRAL) [Function]
|
||||
This behavior is also triggered if the UNDERCONSTRUCTION property of the central window is true. Thus, a constellation can be set up by creating all of the satellites and the central window, marking the central window as under construction, and then doing the sequence of attachments. The property can be reset to NIL when the construction is complete, so the central window does not shrink if other other attachments (e.g. expanded menus) by later user actions. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC)) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) 4 È È 4 È È 4 È È 4 È È . $È . È . È 4 È È . È . Š Š8 . Š Š8 J È È PAGEHEADING RUNNINGHEAD TERMINAL ÿü TERMINAL ÿü
|
||||
@@ -1,220 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "10-Sep-87 12:12:37" {DSK}<OST>STREAMDECLS.\;1 10202
|
||||
|
||||
|changes| |to:| (VARS STREAMDECLSCOMS)
|
||||
(RECORDS STREAM))
|
||||
|
||||
|
||||
(PRETTYCOMPRINT STREAMDECLSCOMS)
|
||||
|
||||
(RPAQQ STREAMDECLSCOMS ((RECORDS STREAM)))
|
||||
(DECLARE\: EVAL@COMPILE
|
||||
|
||||
(DATATYPE STREAM
|
||||
(
|
||||
|
||||
(* |;;| "First 8 words are fixed for BIN, BOUT opcodes. Used to require length of whole datatype be multiple of 4, but Dolphin dead now.")
|
||||
|
||||
(COFFSET WORD) (* \;
|
||||
"Offset in CPPTR of next bin or bout")
|
||||
|
||||
(CBUFSIZE WORD) (* \;
|
||||
"Offset past last byte in that buffer")
|
||||
|
||||
(BINABLE FLAG) (* \; "BIN punts unless this bit on")
|
||||
|
||||
(BOUTABLE FLAG) (* \; "BOUT punts unless this bit on")
|
||||
|
||||
(EXTENDABLE FLAG) (* \;
|
||||
"BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512")
|
||||
|
||||
(CBUFDIRTY FLAG) (* \;
|
||||
"true if BOUT has sullied the current buffer")
|
||||
|
||||
(PEEKEDCHARP FLAG) (* \;
|
||||
"if true, PEEKEDCHAR contains value of recent call to unread-char")
|
||||
|
||||
(ACCESSBITS BITS 3) (* \;
|
||||
"What kind of access file is open for (read, write, append)")
|
||||
|
||||
(CBUFPTR POINTER) (* \; "Pointer to current buffer")
|
||||
|
||||
(BYTESIZE BYTE) (* \;
|
||||
"Byte size of stream, always 8 for now")
|
||||
|
||||
(CHARSET BYTE) (* \; "the current character set for this stream. If 255, stream is not runcoded, so read-char consumes two bytes every time")
|
||||
|
||||
(PEEKEDCHAR WORD) (* \; "value of unread-char call")
|
||||
|
||||
(CHARPOSITION WORD) (* \; "Used by POSITION etc.")
|
||||
|
||||
(CBUFMAXSIZE WORD) (* \;
|
||||
"on output, the size of the physical buffer--can't extend beyond this")
|
||||
|
||||
(* |;;| "-------- Above fields (8 words) potentially known to microcode. --------")
|
||||
|
||||
(NONDEFAULTDATEFLG FLAG)
|
||||
(REVALIDATEFLG FLAG)
|
||||
(MULTIBUFFERHINT FLAG) (* \;
|
||||
"True if stream likes to read and write more than one buffer at a time")
|
||||
|
||||
(USERCLOSEABLE FLAG) (* \;
|
||||
"Can be closed by CLOSEF; NIL for terminal, dribble...")
|
||||
|
||||
(USERVISIBLE FLAG) (* \;
|
||||
"Listed by OPENP; NIL for terminal, dribble ...")
|
||||
|
||||
(EOLCONVENTION BITS 2) (* \; "End-of-line convention")
|
||||
|
||||
(NIL FLAG)
|
||||
(FULLFILENAME POINTER) (* \;
|
||||
"Name by which file is known to user")
|
||||
|
||||
(DEVICE POINTER) (* \; "FDEV of this guy")
|
||||
|
||||
(VALIDATION POINTER) (* \;
|
||||
"A number somehow identifying file, used to determine if file has changed in our absence")
|
||||
|
||||
(CPAGE POINTER) (* \;
|
||||
"CPAGE,,COFFSET constitutes current file pointer for most randaccess streams")
|
||||
|
||||
(EPAGE POINTER)
|
||||
(EOFFSET WORD) (* \; "Page, byte offset of eof")
|
||||
|
||||
(LINELENGTH WORD) (* \;
|
||||
"LINELENGTH of stream, or -1 for no line length")
|
||||
|
||||
(* |;;| "----Following are device-specific fields----")
|
||||
|
||||
(F1 POINTER)
|
||||
(F2 POINTER)
|
||||
(F3 POINTER)
|
||||
(F4 POINTER)
|
||||
(F5 POINTER)
|
||||
(FW6 WORD)
|
||||
(FW7 WORD)
|
||||
(FW8 WORD)
|
||||
(FW9 WORD)
|
||||
(F10 POINTER)
|
||||
|
||||
(* |;;| "----Following only filled in for open streams----")
|
||||
|
||||
(STRMBINFN POINTER) (* \;
|
||||
"Either the BIN fn from the FDEV, or a trap")
|
||||
|
||||
(STRMBOUTFN POINTER) (* \;
|
||||
"Either the BIN fn from the FDEV, or a trap")
|
||||
|
||||
(OUTCHARFN POINTER)
|
||||
(ENDOFSTREAMOP POINTER)
|
||||
(OTHERPROPS POINTER)
|
||||
(IMAGEOPS POINTER) (* \; "Image operations vector")
|
||||
|
||||
(IMAGEDATA POINTER) (* \;
|
||||
"Image instance variables--format depends on IMAGEOPS value")
|
||||
|
||||
(BUFFS POINTER) (* \; "Buffer chain for pmapped streams")
|
||||
|
||||
(MAXBUFFERS WORD)
|
||||
(NIL WORD)
|
||||
(EXTRASTREAMOP POINTER) (* \;
|
||||
"For use of applications programs, not devices")
|
||||
|
||||
)
|
||||
(BLOCKRECORD STREAM ((NIL 2 WORD)
|
||||
(UCODEFLAGS BITS 5)
|
||||
|
||||
(* |;;| "respecification of access bits:")
|
||||
|
||||
(RANDOMWRITEABLE FLAG) (* \;
|
||||
"File open for output (access = OUTPUT or BOTH)")
|
||||
|
||||
(APPENDABLE FLAG) (* \;
|
||||
"File open for append (OUTPUT or APPEND or BOTH)")
|
||||
|
||||
(READABLE FLAG) (* \;
|
||||
"File open for read (READ or BOTH)")
|
||||
|
||||
(NIL POINTER)))
|
||||
(ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS)
|
||||
(FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM)
|
||||
DATUM))
|
||||
(NAMEDP (AND (|fetch| (STREAM FULLFILENAME) |of| DATUM)
|
||||
T))))
|
||||
(SYNONYM CBUFPTR (CPPTR))
|
||||
USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ |NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL
|
||||
BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (GLOBALVARS
|
||||
\\STREAM.DEFAULT.MAXBUFFERS
|
||||
))
|
||||
\\STREAM.DEFAULT.MAXBUFFERS)
|
||||
CHARPOSITION _ 0 LINELENGTH _ (LET NIL (DECLARE (GLOBALVARS FILELINELENGTH))
|
||||
FILELINELENGTH)
|
||||
OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN)
|
||||
ENDOFSTREAMOP _ (FUNCTION \\EOSERROR)
|
||||
IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE)
|
||||
(D CR.EOLC)
|
||||
(VAX LF.EOLC)
|
||||
(JERICHO CRLF.EOLC)
|
||||
CR.EOLC)
|
||||
STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN)
|
||||
STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN))
|
||||
)
|
||||
(/DECLAREDATATYPE 'STREAM
|
||||
'(WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 3)
|
||||
POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 2)
|
||||
FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER
|
||||
POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER WORD WORD POINTER)
|
||||
'((STREAM 0 (BITS . 15))
|
||||
(STREAM 1 (BITS . 15))
|
||||
(STREAM 2 (FLAGBITS . 0))
|
||||
(STREAM 2 (FLAGBITS . 16))
|
||||
(STREAM 2 (FLAGBITS . 32))
|
||||
(STREAM 2 (FLAGBITS . 48))
|
||||
(STREAM 2 (FLAGBITS . 64))
|
||||
(STREAM 2 (BITS . 82))
|
||||
(STREAM 2 POINTER)
|
||||
(STREAM 4 (BITS . 7))
|
||||
(STREAM 4 (BITS . 135))
|
||||
(STREAM 5 (BITS . 15))
|
||||
(STREAM 6 (BITS . 15))
|
||||
(STREAM 7 (BITS . 15))
|
||||
(STREAM 8 (FLAGBITS . 0))
|
||||
(STREAM 8 (FLAGBITS . 16))
|
||||
(STREAM 8 (FLAGBITS . 32))
|
||||
(STREAM 8 (FLAGBITS . 48))
|
||||
(STREAM 8 (FLAGBITS . 64))
|
||||
(STREAM 8 (BITS . 81))
|
||||
(STREAM 8 (FLAGBITS . 112))
|
||||
(STREAM 8 POINTER)
|
||||
(STREAM 10 POINTER)
|
||||
(STREAM 12 POINTER)
|
||||
(STREAM 14 POINTER)
|
||||
(STREAM 16 POINTER)
|
||||
(STREAM 18 (BITS . 15))
|
||||
(STREAM 19 (BITS . 15))
|
||||
(STREAM 20 POINTER)
|
||||
(STREAM 22 POINTER)
|
||||
(STREAM 24 POINTER)
|
||||
(STREAM 26 POINTER)
|
||||
(STREAM 28 POINTER)
|
||||
(STREAM 30 (BITS . 15))
|
||||
(STREAM 31 (BITS . 15))
|
||||
(STREAM 32 (BITS . 15))
|
||||
(STREAM 33 (BITS . 15))
|
||||
(STREAM 34 POINTER)
|
||||
(STREAM 36 POINTER)
|
||||
(STREAM 38 POINTER)
|
||||
(STREAM 40 POINTER)
|
||||
(STREAM 42 POINTER)
|
||||
(STREAM 44 POINTER)
|
||||
(STREAM 46 POINTER)
|
||||
(STREAM 48 POINTER)
|
||||
(STREAM 50 POINTER)
|
||||
(STREAM 52 (BITS . 15))
|
||||
(STREAM 53 (BITS . 15))
|
||||
(STREAM 54 POINTER))
|
||||
'56)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
@@ -1,143 +1,123 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "16-Oct-2021 19:23:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TEDIT-PF-SEE.;32 7178
|
||||
(FILECREATED " 2-Jan-2022 22:03:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;104 6489
|
||||
|
||||
changes to%: (FNS CLOSE-TYPED-WINDOW)
|
||||
:CHANGES-TO (VARS TEDIT-PF-SEECOMS)
|
||||
|
||||
previous date%: "12-Oct-2021 22:31:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TEDIT-PF-SEE.;31)
|
||||
:PREVIOUS-DATE "30-Dec-2021 23:17:58"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>TEDIT-PF-SEE.;103)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-PF-SEECOMS)
|
||||
|
||||
(RPAQQ TEDIT-PF-SEECOMS
|
||||
[(FNS SEE-TEDIT PF-TEDIT)
|
||||
(COMS (FNS GET-TYPED-WINDOW CLOSE-TYPED-WINDOW)
|
||||
(INITVARS (TYPED-WINDOWS)))
|
||||
(COMMANDS ts tpf)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
(RPAQQ TEDIT-PF-SEECOMS [(FNS PF-TEDIT)
|
||||
(COMMANDS ts tf)
|
||||
(FILES (SYSLOAD)
|
||||
REGIONMANAGER)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
|
||||
(NLAMA)
|
||||
(NLAML)
|
||||
(LAMA])
|
||||
(DEFINEQ
|
||||
|
||||
(SEE-TEDIT
|
||||
[LAMBDA (FILE WINDOW FORMAT) (* ; "Edited 11-Oct-2021 08:51 by rmk:")
|
||||
(SETQ FILE (OR (FINDFILE-WITH-EXTENSIONS FILE NIL '(NIL TEDIT TED TXT TEXT TEX))
|
||||
(ERROR "FILE NOT FOUND" FILE)))
|
||||
(TEDIT-SEE FILE (GET-TYPED-WINDOW (OR WINDOW 'SEE-TEDIT)
|
||||
(CONCAT "SEE window for " FILE))
|
||||
FORMAT)
|
||||
FILE])
|
||||
|
||||
(PF-TEDIT
|
||||
[LAMBDA (FN IFILES) (* ; "Edited 12-Oct-2021 15:22 by rmk:")
|
||||
[LAMBDA (FN IFILES REPRINT) (* ; "Edited 30-Dec-2021 23:17 by rmk")
|
||||
|
||||
(* ;; "PF* to a read-only TEDIT window. First argument is the function name, second if given is the input file.")
|
||||
|
||||
(* ;; "This uses PFCOPYBYTES so we see what it looks like on the file. But some functions were not prettyprinted, so they appear as useless garbage.")
|
||||
|
||||
(* ;; "In that case, calling again with REPRINT=T will read and reprint. And, invoking tf again with no arguments at all will also reprint the last function in the same window")
|
||||
|
||||
(SETQ IFILES (MKLIST IFILES))
|
||||
(CL:WHEN (LISTP FN)
|
||||
(SETQ FN (CAR FN)))
|
||||
(IF FN
|
||||
THEN (* ; "FN name specified; use it.")
|
||||
(SETQ LASTWORD FN)
|
||||
ELSE (* ; "Not specified, use LASTWORD")
|
||||
(SETQ FN LASTWORD))
|
||||
(SELECTQ FN
|
||||
((t T NIL)
|
||||
(SETQ REPRINT T)
|
||||
(SETQ FN LASTWORD))
|
||||
(SETQ LASTWORD FN))
|
||||
(CL:UNLESS FN (ERROR "No function to print"))
|
||||
(CL:WHEN (INTERSECTION '(T t)
|
||||
IFILES)
|
||||
(SETQ REPRINT T)
|
||||
[SETQ IFILES (LDIFFERENCE IFILES '(t T])
|
||||
(IF [OR IFILES (SETQ IFILES (APPEND (WHEREIS FN 'FNS T)
|
||||
(WHEREIS FN 'FUNCTIONS T]
|
||||
THEN (* ; "skip compiled files")
|
||||
(FOR IFILE LOC TSTREAM ENV INSIDE IFILES
|
||||
UNLESS (MEMB (FILENAMEFIELD IFILE 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*)
|
||||
DO (SETQ LOC (FINDFNDEF FN IFILE))
|
||||
(IF (LISTP LOC)
|
||||
THEN [CL:WITH-OPEN-FILE (ISTREAM (POP LOC)
|
||||
:DIRECTION :INPUT)
|
||||
(SETQ ENV (LISPSOURCEFILEP ISTREAM))
|
||||
(SETFILEINFO ISTREAM 'FORMAT ENV)
|
||||
(SETQ TSTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(PRINT-READER-ENVIRONMENT ENV TSTREAM)
|
||||
(PFCOPYBYTES ISTREAM TSTREAM (POP LOC)
|
||||
(POP LOC))
|
||||
(TERPRI TSTREAM)
|
||||
(SETQ TSTREAM (TEDIT TSTREAM (GET-TYPED-WINDOW
|
||||
'PF-TEDIT
|
||||
(CONCAT FN " from "
|
||||
(FULLNAME ISTREAM)))
|
||||
NIL
|
||||
'(READONLY T]
|
||||
ELSEIF (EQ LOC 'FILE.NOT.FOUND)
|
||||
THEN (printout T "file " IFILE " not found." T)
|
||||
ELSE (printout T FN " not found on " LOC "." T)))
|
||||
(WHEREIS FN 'FUNCTIONS T]
|
||||
THEN (* ; "skip compiled files")
|
||||
|
||||
(* ;; "Since we are creating readonly Tedits, try to keep the TTY where it is.")
|
||||
|
||||
(FOR IFILE LOC TSTREAM ENV EXPR TFPROP WINDOW INSIDE IFILES
|
||||
UNLESS (MEMB (FILENAMEFIELD IFILE 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*)
|
||||
DO (SETQ LOC (FINDFNDEF FN IFILE))
|
||||
(IF (LISTP LOC)
|
||||
THEN (SETQ TFPROP (LIST FN (CAR LOC)))
|
||||
[SETQ WINDOW (FIND W IN (OPENWINDOWS)
|
||||
SUCHTHAT (AND (EQUAL TFPROP (WINDOWPROP W 'TF))
|
||||
(WINDOWPROP W 'TEXTOBJ]
|
||||
[IF (AND WINDOW (NOT REPRINT))
|
||||
THEN
|
||||
(* ;;
|
||||
"If already an open PF window on this function in this file, just raise it to the top")
|
||||
|
||||
(TOTOPW WINDOW)
|
||||
(RETURN)
|
||||
ELSE (CL:WITH-OPEN-FILE (ISTREAM (POP LOC)
|
||||
:DIRECTION :INPUT)
|
||||
(SETQ ENV (LISPSOURCEFILEP ISTREAM))
|
||||
(SETFILEINFO ISTREAM 'FORMAT ENV)
|
||||
(SETQ TSTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT TSTREAM)
|
||||
(PRINT-READER-ENVIRONMENT ENV TSTREAM)
|
||||
(IF REPRINT
|
||||
THEN (SETFILEPTR ISTREAM (POP LOC))
|
||||
(SETQ EXPR (WITH-READER-ENVIRONMENT ENV (READ ISTREAM))
|
||||
)
|
||||
(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))
|
||||
ELSE (PFCOPYBYTES ISTREAM TSTREAM (POP LOC)
|
||||
(POP LOC)))
|
||||
(TERPRI TSTREAM)
|
||||
[TEDIT TSTREAM (OR WINDOW 'PF-TEDIT)
|
||||
NIL
|
||||
`(READONLY T LEAVETTY T TITLE ,(CONCAT FN " from "
|
||||
(FULLNAME ISTREAM]
|
||||
|
||||
(* ;; "The windowprop allows for reprinting as a window action, or reprinting from a command that can find and reuse the previous (presumably unprettied) window.")
|
||||
|
||||
(WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TF TFPROP)
|
||||
|
||||
(* ;; "Remove this when TEDIT honors the TITLE property")
|
||||
|
||||
(WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TITLE
|
||||
(CONCAT FN " from " (FULLNAME ISTREAM]
|
||||
ELSEIF (EQ LOC 'FILE.NOT.FOUND)
|
||||
THEN (printout T "file " IFILE " not found." T)
|
||||
ELSE (printout T FN " not found on " LOC "." T)))
|
||||
(SETQ *LAST-DF* FN)
|
||||
ELSE (PRINTOUT T FN " has no function definition" T])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(GET-TYPED-WINDOW
|
||||
[LAMBDA (WINDOWTYPE TITLE NOOPENFLG) (* ; "Edited 11-Oct-2021 10:06 by rmk:")
|
||||
(DEFCOMMAND ts (FILE WINDOW FORMAT)
|
||||
(TEDIT-SEE (OR (FINDFILE-WITH-EXTENSIONS FILE NIL '(NIL TEDIT TED TXT TEXT TEX))
|
||||
(ERROR "FILE NOT FOUND" FILE))
|
||||
(OR WINDOW 'SEE-TEDIT)
|
||||
FORMAT))
|
||||
|
||||
(* ;; "WINDOWTYPE=T means always create a new window. If a WINDOW, then reuse it.")
|
||||
(DEFCOMMAND tf (FN . IFILES) (PF-TEDIT FN IFILES))
|
||||
|
||||
(* ;; "Otherwise, create a window of type WINDOWTYPE, using a previously specified region if one is available.")
|
||||
|
||||
(LET (WINDOW REGION WLIST)
|
||||
[IF (OR (EQ WINDOWTYPE T)
|
||||
(SETQ WINDOW (WINDOWP WINDOWTYPE)))
|
||||
THEN (SETQ WINDOWTYPE NIL)
|
||||
ELSE [SETQ WLIST (OR (ASSOC WINDOWTYPE TYPED-WINDOWS)
|
||||
(CAR (PUSH TYPED-WINDOWS (CONS WINDOWTYPE]
|
||||
(SETQ REGION (FIND X IN (CDR WLIST) SUCHTHAT (TYPE? REGION X]
|
||||
(CL:UNLESS WINDOW
|
||||
|
||||
(* ;; "Make sure we have a titlebar and promptwindow")
|
||||
|
||||
(SETQ WINDOW (CREATEW REGION "" NIL NOOPENFLG))
|
||||
(GETPROMPTWINDOW WINDOW)
|
||||
|
||||
(* ;;
|
||||
"Replace the region on WLIST with the window, so we can maintan a likely preference order.")
|
||||
|
||||
(IF REGION
|
||||
THEN (DSUBST WINDOW REGION WLIST)
|
||||
ELSE (NCONC1 WLIST WINDOW)))
|
||||
(CL:WHEN TITLE
|
||||
(WINDOWPROP WINDOW 'TITLE TITLE))
|
||||
(CL:WHEN WINDOWTYPE
|
||||
(WINDOWPROP WINDOW 'WINDOWTYPE WINDOWTYPE)
|
||||
(WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION CLOSE-TYPED-WINDOW)))
|
||||
WINDOW])
|
||||
|
||||
(CLOSE-TYPED-WINDOW
|
||||
[LAMBDA (WINDOW ALL) (* ; "Edited 16-Oct-2021 19:23 by rmk:")
|
||||
|
||||
(* ;; "Puts the region of WINDOW back on the region list for its type, for later reuse. If ALL, closes all windows of the type of WINDOW (and recursively puts their regions also on the list).")
|
||||
|
||||
(CL:WHEN (OPENWP WINDOW)
|
||||
[LET [(WINDOWTYPE (WINDOWPROP WINDOW 'WINDOWTYPE]
|
||||
(CL:WHEN WINDOWTYPE
|
||||
(IF ALL
|
||||
THEN (FOR W IN (OPENWINDOWS) WHEN (EQ WINDOWTYPE
|
||||
(WINDOWPROP W 'WINDOWTYPE)
|
||||
)
|
||||
UNLESS (EQ W WINDOW) DO (CLOSEW W))
|
||||
ELSE
|
||||
|
||||
(* ;; "This may no longer be needed, now that TEDIT removes the process for READONLY windows just as for ordinary edit windows.")
|
||||
|
||||
(AND NIL (CL:WHEN (TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS))
|
||||
(* ;
|
||||
"Otherwise, the window pops up if you don't click away")
|
||||
(TTY.PROCESS T)))
|
||||
(DSUBST (WINDOWPROP WINDOW 'REGION)
|
||||
WINDOW TYPED-WINDOWS)))])
|
||||
WINDOW])
|
||||
)
|
||||
|
||||
(RPAQ? TYPED-WINDOWS )
|
||||
|
||||
(DEFCOMMAND ts (FILE WINDOW FORMAT) (SEE-TEDIT FILE WINDOW FORMAT))
|
||||
|
||||
(DEFCOMMAND tpf (FN IFILES) (PF-TEDIT FN IFILES))
|
||||
(FILESLOAD (SYSLOAD)
|
||||
REGIONMANAGER)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
@@ -147,6 +127,5 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (843 3913 (SEE-TEDIT 853 . 1263) (PF-TEDIT 1265 . 3911)) (3914 6866 (GET-TYPED-WINDOW
|
||||
3924 . 5397) (CLOSE-TYPED-WINDOW 5399 . 6864)))))
|
||||
(FILEMAP (NIL (956 6010 (PF-TEDIT 966 . 6008)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
BIN
lispusers/TEDIT-PF-SEE.TEDIT
Normal file
BIN
lispusers/TEDIT-PF-SEE.TEDIT
Normal file
Binary file not shown.
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "11-Jun-2021 12:50:16"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;18 10803
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS ENABLEWHEELSCROLL)
|
||||
(FILECREATED "29-Nov-2021 22:06:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>WHEELSCROLL.;21 11690
|
||||
|
||||
previous date%: "11-Jun-2021 11:11:10"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;14)
|
||||
changes to%: (FNS INSTALL-WHEELSCROLL)
|
||||
|
||||
previous date%: "29-Nov-2021 21:58:55"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>WHEELSCROLL.;20)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT WHEELSCROLLCOMS)
|
||||
@@ -14,20 +15,21 @@
|
||||
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL
|
||||
LISPINTERRUPTS.WHEELSCROLL)
|
||||
|
||||
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
|
||||
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (UP 156)
|
||||
(DOWN 157)
|
||||
(LEFT 158)
|
||||
(RIGHT 159)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\WSUP 156)
|
||||
(\WSDOWN 157)
|
||||
(\WSLEFT 158)
|
||||
(\WSRIGHT 159)))
|
||||
(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
|
||||
|
||||
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
|
||||
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
|
||||
|
||||
[ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
|
||||
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
|
||||
(INITVARS (WHEELSCROLLENABLED NIL)
|
||||
(WHEELSCROLLDELTA 20)
|
||||
(HWHEELSCROLLDELTA NIL)
|
||||
(WHEELSCROLLSETTLETIME 50)
|
||||
(\WHEELSCROLLINPROGRESS NIL))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL)
|
||||
@@ -35,65 +37,69 @@
|
||||
(DEFINEQ
|
||||
|
||||
(ENABLEWHEELSCROLL
|
||||
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 11-Jun-2021 12:50 by rmk:")
|
||||
(* ; "Edited 28-May-2021 11:46 by rmk:")
|
||||
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ;
|
||||
"Edited 23-Oct-2021 16:31 by larry")
|
||||
(* ;
|
||||
"Edited 11-Jun-2021 12:50 by rmk:")
|
||||
(* ;
|
||||
"Edited 28-May-2021 11:46 by rmk:")
|
||||
|
||||
(* ;; "So we can toggle this scrolling.")
|
||||
(* ;; "So we can toggle this scrolling.")
|
||||
|
||||
(IF ON
|
||||
THEN (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
|
||||
(if ON
|
||||
then (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
|
||||
(GETD 'LISPINTERRUPTS.WHEELSCROLL))
|
||||
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||
(* ; "In case of LOADFROM?")
|
||||
(* ; "In case of LOADFROM?")
|
||||
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
|
||||
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)))
|
||||
|
||||
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
|
||||
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
|
||||
|
||||
[FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
DO ((FOR K IN [IF EXCLUDEHORIZONTAL
|
||||
THEN `((PAD1 ,UP)
|
||||
(PAD2 ,DOWN)
|
||||
(PAD4 IGNORE)
|
||||
(PAD5 IGNORE))
|
||||
ELSE `((PAD1 ,UP)
|
||||
(PAD2 ,DOWN)
|
||||
(PAD4 ,LEFT)
|
||||
(PAD5 ,RIGHT]
|
||||
DO (KEYACTION (CAR K)
|
||||
(CONS (CL:IF (EQ (CADR K)
|
||||
'IGNORE)
|
||||
'IGNORE
|
||||
`(,(CADR K)
|
||||
,(CADR K)))
|
||||
`IGNORE)
|
||||
KAT]
|
||||
(FOR I IN WHEELSCROLLINTERRUPTS
|
||||
DO (INTERRUPTCHAR (CAR I)
|
||||
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
do (for K in [if EXCLUDEHORIZONTAL
|
||||
then `((PAD1 ,\WSUP)
|
||||
(PAD2 ,\WSDOWN)
|
||||
(PAD4 IGNORE)
|
||||
(PAD5 IGNORE))
|
||||
else `((PAD1 ,\WSUP)
|
||||
(PAD2 ,\WSDOWN)
|
||||
(PAD4 ,\WSLEFT)
|
||||
(PAD5 ,\WSRIGHT]
|
||||
do (KEYACTION (CAR K)
|
||||
(CONS (CL:IF (EQ (CADR K)
|
||||
'IGNORE)
|
||||
'IGNORE
|
||||
`(,(CADR K)
|
||||
,(CADR K)))
|
||||
`IGNORE)
|
||||
KAT)))
|
||||
(for I in WHEELSCROLLINTERRUPTS
|
||||
do (INTERRUPTCHAR (CAR I)
|
||||
(CADR I)
|
||||
(CADDR I))
|
||||
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
||||
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
|
||||
(TEDIT.SETFUNCTION (CAR I)
|
||||
`[LAMBDA NIL
|
||||
,(CADR I]
|
||||
TEDIT.READTABLE)))
|
||||
(SETQ WHEELSCROLLENABLED T)
|
||||
ELSE (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||
else (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||
(GETD 'LISPINTERRUPTS))
|
||||
(MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
|
||||
(FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
|
||||
(for I in WHEELSCROLLINTERRUPTS do (INTERRUPTCHAR (CAR I)
|
||||
NIL)
|
||||
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
||||
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||
|
||||
(TEDIT.SETFUNCTION (CAR I)
|
||||
NIL TEDIT.READTABLE)))
|
||||
(FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
DO (KEYACTION 'PAD1 '(IGNORE . IGNORE)
|
||||
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||
do (KEYACTION 'PAD1 '(IGNORE . IGNORE)
|
||||
KAT)
|
||||
(KEYACTION 'PAD2 '(IGNORE . IGNORE)
|
||||
KAT)
|
||||
@@ -104,41 +110,42 @@
|
||||
(SETQ WHEELSCROLLENABLED NIL])
|
||||
|
||||
(WHEELSCROLL
|
||||
[LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:")
|
||||
[LAMBDA (DIRECTION DELTA) (* ;
|
||||
"Edited 21-Feb-2021 09:38 by rmk:")
|
||||
|
||||
(* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)")
|
||||
(* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(CL:WHEN (MOUSESTATE UP) (* ;
|
||||
"Ignore interrupt if a button is down")
|
||||
(CL:WHEN (MOUSESTATE UP) (* ;
|
||||
"Ignore interrupt if a button is down")
|
||||
[LET ((W (WHICHW)))
|
||||
|
||||
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within
|
||||
the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
|
||||
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within
|
||||
the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
|
||||
|
||||
(CL:WHEN W
|
||||
|
||||
(* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")
|
||||
(* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")
|
||||
|
||||
(IF (WINDOWPROP W 'SCROLLFN)
|
||||
THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
|
||||
(if (WINDOWPROP W 'SCROLLFN)
|
||||
then [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
|
||||
(CL:IF (EQ DIRECTION 'VERTICAL)
|
||||
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
||||
0
|
||||
,DELTA)
|
||||
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
||||
,DELTA 0))]
|
||||
ELSEIF (EQ DIRECTION 'VERTICAL)
|
||||
THEN
|
||||
elseif (EQ DIRECTION 'VERTICAL)
|
||||
then
|
||||
|
||||
(* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.")
|
||||
(* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.")
|
||||
|
||||
(CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
|
||||
(\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
|
||||
(GETMOUSESTATE))
|
||||
ELSEIF (EQ DIRECTION 'HORIZONTAL)
|
||||
THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
|
||||
elseif (EQ DIRECTION 'HORIZONTAL)
|
||||
then (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
|
||||
(\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
|
||||
LASTMOUSEY)
|
||||
(GETMOUSESTATE))))])])
|
||||
@@ -156,18 +163,22 @@
|
||||
(RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))])
|
||||
|
||||
(INSTALL-WHEELSCROLL
|
||||
[LAMBDA NIL (* ; "Edited 28-May-2021 11:46 by rmk:")
|
||||
(* ; "Edited 17-Feb-2021 11:53 by rmk:")
|
||||
[LAMBDA NIL (* ; "Edited 29-Nov-2021 21:56 by rmk:")
|
||||
(* ; "Edited 28-May-2021 11:46 by rmk:")
|
||||
(* ; "Edited 17-Feb-2021 11:53 by rmk:")
|
||||
|
||||
(* ;; "We want the UP, DOWN...constants to be compiled awsy")
|
||||
(* ;; "We want the UP, DOWN...constants to be compiled awsy")
|
||||
|
||||
(SETQ WHEELSCROLLINTERRUPTS `((,UP (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
|
||||
T)
|
||||
(,DOWN (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
|
||||
(SETQ WHEELSCROLLINTERRUPTS `((,\WSUP (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
|
||||
T)
|
||||
(,LEFT (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
|
||||
T))
|
||||
(,RIGHT (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T])
|
||||
(,\WSDOWN (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
|
||||
T)
|
||||
(,\WSLEFT (WHEELSCROLL 'HORIZONTAL (IMINUS (OR HWHEELSCROLLDELTA
|
||||
WHEELSCROLLDELTA))
|
||||
T))
|
||||
(,\WSRIGHT (WHEELSCROLL 'HORIZONTAL (OR HWHEELSCROLLDELTA
|
||||
WHEELSCROLLDELTA)
|
||||
WHEELSCROLLDELTA T])
|
||||
|
||||
(LISPINTERRUPTS.WHEELSCROLL
|
||||
[LAMBDA NIL (* ; "Edited 17-Feb-2021 11:09 by rmk:")
|
||||
@@ -186,19 +197,19 @@
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ UP 156)
|
||||
(RPAQQ \WSUP 156)
|
||||
|
||||
(RPAQQ DOWN 157)
|
||||
(RPAQQ \WSDOWN 157)
|
||||
|
||||
(RPAQQ LEFT 158)
|
||||
(RPAQQ \WSLEFT 158)
|
||||
|
||||
(RPAQQ RIGHT 159)
|
||||
(RPAQQ \WSRIGHT 159)
|
||||
|
||||
|
||||
(CONSTANTS (UP 156)
|
||||
(DOWN 157)
|
||||
(LEFT 158)
|
||||
(RIGHT 159))
|
||||
(CONSTANTS (\WSUP 156)
|
||||
(\WSDOWN 157)
|
||||
(\WSLEFT 158)
|
||||
(\WSRIGHT 159))
|
||||
)
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -219,6 +230,8 @@
|
||||
|
||||
(RPAQ? WHEELSCROLLDELTA 20)
|
||||
|
||||
(RPAQ? HWHEELSCROLLDELTA NIL)
|
||||
|
||||
(RPAQ? WHEELSCROLLSETTLETIME 50)
|
||||
|
||||
(RPAQ? \WHEELSCROLLINPROGRESS NIL)
|
||||
@@ -229,6 +242,6 @@
|
||||
(ENABLEWHEELSCROLL T)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1575 9814 (ENABLEWHEELSCROLL 1585 . 5542) (WHEELSCROLL 5544 . 8080) (WHEELSCROLL.DOIT
|
||||
8082 . 8718) (INSTALL-WHEELSCROLL 8720 . 9535) (LISPINTERRUPTS.WHEELSCROLL 9537 . 9812)))))
|
||||
(FILEMAP (NIL (1636 10642 (ENABLEWHEELSCROLL 1646 . 5903) (WHEELSCROLL 5905 . 8506) (WHEELSCROLL.DOIT
|
||||
8508 . 9144) (INSTALL-WHEELSCROLL 9146 . 10363) (LISPINTERRUPTS.WHEELSCROLL 10365 . 10640)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -15,6 +15,9 @@ The scrolling speed is controlled by the variable
|
||||
WHEELSCROLLDELTA (initially 20)
|
||||
The number of points to scroll for each click of the wheel. Higher values give faster scrolling. A negative value reverses the scrolling direction.
|
||||
|
||||
HWHEELSCROLLDELTA (initial NIL)
|
||||
If non-NIL, then this is the delta used for horizontal scrolling.
|
||||
|
||||
Implementation:
|
||||
|
||||
Lisp receives a key transition on PAD1 or PAD2 for vertical scrolling when the wheel rotates and no other keys are down. (ENABLEWHEELSCROLL T) modifies the keyaction table so that it maps these transitions to characters 156 and 157. Those characters are defined as interrupts that invoke the vertical scrolling action. For horizontal scrolling sideways pushes of a wheel (if it has that) produce transitions on PAD4 and PAD5, which map to interrupt-characters 158 and 159. (156-159 are the highest right-panel characters of character-set 0 that correspond to left-panel control characters, so typically have no other conflicting meaning.)
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
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.
310
sources/ATBL
310
sources/ATBL
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Oct-2021 21:53:59" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;28 92451
|
||||
(FILECREATED "26-Dec-2021 14:32:50" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;32 91860
|
||||
|
||||
changes to%: (FNS MAKE-READER-ENVIRONMENT)
|
||||
:CHANGES-TO (FNS MAKE-READER-ENVIRONMENT)
|
||||
|
||||
previous date%: "24-Oct-2021 20:14:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;27)
|
||||
:PREVIOUS-DATE "19-Dec-2021 14:09:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;31)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -16,7 +16,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(RPAQQ ATBLCOMS
|
||||
[(COMS (* ;
|
||||
"Common features of read and terminal tables")
|
||||
"Common features of read and terminal tables")
|
||||
(DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
|
||||
(RECORDS CHARTABLE))
|
||||
(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
|
||||
@@ -39,9 +39,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
\SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
|
||||
(PROP ARGNAMES READTABLEPROP)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
|
||||
"READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
|
||||
"READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
|
||||
(* ;
|
||||
"OTHER must be zero because of initialization.")
|
||||
"OTHER must be zero because of initialization.")
|
||||
[VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
|
||||
(FUNCTION (LAMBDA
|
||||
(PAIR)
|
||||
@@ -50,7 +50,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CADR PAIR]
|
||||
(MACROS \COMPUTED.FORM)
|
||||
(* ;
|
||||
"This macro ought to be official somehow")
|
||||
"This macro ought to be official somehow")
|
||||
(RECORDS CONTEXTS ESCAPES WAKEUPS)
|
||||
(EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
|
||||
(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
|
||||
@@ -66,7 +66,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(FNS \ATBLSET)
|
||||
(INITRECORDS READER-ENVIRONMENT)
|
||||
(* ;
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
|
||||
(INITVARS (*LISP-PACKAGE*)
|
||||
(*INTERLISP-PACKAGE*)
|
||||
@@ -85,30 +85,27 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ;
|
||||
"0 is either NONE.TC, REAL.CCE, or OTHER.RC")
|
||||
(COND
|
||||
((IGREATERP CHAR \MAXTHINCHAR)
|
||||
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
|
||||
(GETHASH CHAR (fetch (CHARTABLE NSCHARHASH)
|
||||
of TABLE)))
|
||||
0))
|
||||
(T (\GETBASEBYTE TABLE CHAR])
|
||||
(CHECK (type? CHARTABLE TABLE)) (* ;
|
||||
"0 is either NONE.TC, REAL.CCE, or OTHER.RC")
|
||||
(COND
|
||||
((IGREATERP CHAR \MAXTHINCHAR)
|
||||
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
|
||||
(GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE)))
|
||||
0))
|
||||
(T (\GETBASEBYTE TABLE CHAR])
|
||||
|
||||
(PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE)
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ;
|
||||
"0 is REAL.CCE, NONE.TC, OTHER.RC")
|
||||
(COND
|
||||
((ILEQ CHAR \MAXTHINCHAR)
|
||||
(\PUTBASEBYTE TABLE CHAR CODE))
|
||||
(T (\SETFATSYNCODE TABLE CHAR CODE])
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ; "0 is REAL.CCE, NONE.TC, OTHER.RC")
|
||||
(COND
|
||||
((ILEQ CHAR \MAXTHINCHAR)
|
||||
(\PUTBASEBYTE TABLE CHAR CODE))
|
||||
(T (\SETFATSYNCODE TABLE CHAR CODE])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE CHARTABLE ((CHARSET0 256 BYTE)
|
||||
(NSCHARHASH FULLPOINTER)))
|
||||
(NSCHARHASH FULLPOINTER)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'CHARTABLE
|
||||
@@ -402,11 +399,11 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
|
||||
"added size argument for creation of \ORIGTERMTABLE during initialization.")
|
||||
(LIST 'HASHARRAY (OR (CAR ARGS)
|
||||
'\NSCHARHASHKEYS)
|
||||
'\NSCHARHASHOVERFLOW)))
|
||||
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
|
||||
"added size argument for creation of \ORIGTERMTABLE during initialization.")
|
||||
(LIST 'HASHARRAY (OR (CAR ARGS)
|
||||
'\NSCHARHASHKEYS)
|
||||
'\NSCHARHASHOVERFLOW)))
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -924,8 +921,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
|
||||
)
|
||||
|
||||
(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC
|
||||
RETYPE.TC CTRLV.TC))
|
||||
(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC
|
||||
CTRLV.TC))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ NONE.TC 0)
|
||||
@@ -950,14 +947,14 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24))
|
||||
(TERMCLASS (LOGAND DATUM 7))) (* ;
|
||||
"We assume that values are appropriately shifted")
|
||||
(CREATE (LOGOR CCECHO TERMCLASS)))
|
||||
(TERMCLASS (LOGAND DATUM 7))) (* ;
|
||||
"We assume that values are appropriately shifted")
|
||||
(CREATE (LOGOR CCECHO TERMCLASS)))
|
||||
|
||||
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL
|
||||
EMPTYCHDEL (CONTROLFLG FLAG)
|
||||
(ECHOFLG FLAG))
|
||||
TERMSA _ (create CHARTABLE))
|
||||
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL
|
||||
(CONTROLFLG FLAG)
|
||||
(ECHOFLG FLAG))
|
||||
TERMSA _ (create CHARTABLE))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
|
||||
@@ -1440,9 +1437,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PACKAGEDELIM (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
|
||||
|
||||
(RPAQ READCLASSES [MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR)
|
||||
(LIST (PACK* (CAR PAIR)
|
||||
".RC")
|
||||
(CADR PAIR])
|
||||
(LIST (PACK* (CAR PAIR)
|
||||
".RC")
|
||||
(CADR PAIR])
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1452,60 +1449,60 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS CONTEXTS ((KEY (SELECTC DATUM
|
||||
(ALWAYS.RMC 'ALWAYS)
|
||||
(FIRST.RMC 'FIRST)
|
||||
(ALONE.RMC 'ALONE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
(ALWAYS ALWAYS.RMC)
|
||||
(FIRST FIRST.RMC)
|
||||
(ALONE ALONE.RMC)
|
||||
NIL))))
|
||||
(ALWAYS.RMC 'ALWAYS)
|
||||
(FIRST.RMC 'FIRST)
|
||||
(ALONE.RMC 'ALONE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
(ALWAYS ALWAYS.RMC)
|
||||
(FIRST FIRST.RMC)
|
||||
(ALONE ALONE.RMC)
|
||||
NIL))))
|
||||
|
||||
(ACCESSFNS ESCAPES ((KEY (SELECTC DATUM
|
||||
(ESC.RME 'ESCQUOTE)
|
||||
(NOESC.RME 'NOESCQUOTE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((ESCQUOTE ESC)
|
||||
ESC.RME)
|
||||
((NOESCQUOTE NOESC)
|
||||
NOESC.RME)
|
||||
NIL))))
|
||||
(ESC.RME 'ESCQUOTE)
|
||||
(NOESC.RME 'NOESCQUOTE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((ESCQUOTE ESC)
|
||||
ESC.RME)
|
||||
((NOESCQUOTE NOESC)
|
||||
NOESC.RME)
|
||||
NIL))))
|
||||
|
||||
(ACCESSFNS WAKEUPS ((KEY (SELECTC DATUM
|
||||
(IMMEDIATE.RMW 'IMMEDIATE)
|
||||
(NONIMMEDIATE.RMW
|
||||
'NONIMMEDIATE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((IMMEDIATE IMMED WAKEUP)
|
||||
IMMEDIATE.RMW)
|
||||
((NONIMMEDIATE NONIMMED NOWAKEUP)
|
||||
NONIMMEDIATE.RMW)
|
||||
NIL))))
|
||||
(IMMEDIATE.RMW 'IMMEDIATE)
|
||||
(NONIMMEDIATE.RMW
|
||||
'NONIMMEDIATE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((IMMEDIATE IMMED WAKEUP)
|
||||
IMMEDIATE.RMW)
|
||||
((NONIMMEDIATE NONIMMED NOWAKEUP)
|
||||
NONIMMEDIATE.RMW)
|
||||
NIL))))
|
||||
)
|
||||
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \GETREADMACRODEF MACRO ((C TBL)
|
||||
(GETHASH C (fetch READMACRODEFS of TBL))))
|
||||
(GETHASH C (fetch READMACRODEFS of TBL))))
|
||||
|
||||
(PUTPROPS \GTREADTABLE MACRO [ARGS (COND
|
||||
[(LITATOM (CAR ARGS))
|
||||
(SUBPAIR '(X . FLG)
|
||||
ARGS
|
||||
'(SELECTQ X
|
||||
((NIL T)
|
||||
(\DTEST *READTABLE* 'READTABLEP))
|
||||
(\GTREADTABLE1 X . FLG]
|
||||
(T 'IGNOREMACRO])
|
||||
[(LITATOM (CAR ARGS))
|
||||
(SUBPAIR '(X . FLG)
|
||||
ARGS
|
||||
'(SELECTQ X
|
||||
((NIL T)
|
||||
(\DTEST *READTABLE* 'READTABLEP))
|
||||
(\GTREADTABLE1 X . FLG]
|
||||
(T 'IGNOREMACRO])
|
||||
|
||||
(PUTPROPS \GTREADTABLE1 DMACRO [ARGS (COND
|
||||
[(NULL (CDR ARGS))
|
||||
(LIST '\DTEST (CAR ARGS)
|
||||
''READTABLEP]
|
||||
(T 'IGNOREMACRO])
|
||||
[(NULL (CDR ARGS))
|
||||
(LIST '\DTEST (CAR ARGS)
|
||||
''READTABLEP]
|
||||
(T 'IGNOREMACRO])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1524,7 +1521,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
|
||||
(WAKEUPMASK (LOGOR MACROBIT 2))))
|
||||
(WAKEUPMASK (LOGOR MACROBIT 2))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
|
||||
@@ -1537,8 +1534,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
|
||||
(FIRST.RMC (LOGOR MACROBIT 0))
|
||||
(ALONE.RMC (LOGOR MACROBIT 1))))
|
||||
(FIRST.RMC (LOGOR MACROBIT 0))
|
||||
(ALONE.RMC (LOGOR MACROBIT 1))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
|
||||
@@ -1604,7 +1601,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2))
|
||||
(NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
|
||||
(NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))
|
||||
@@ -1617,7 +1614,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT)
|
||||
(NOESC.RME 0)))
|
||||
(NOESC.RME 0)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ ESC.RME ESCAPEBIT)
|
||||
@@ -1631,46 +1628,46 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT))
|
||||
(ESCQUOTE (BITTEST DATUM ESCAPEBIT))
|
||||
(STOPATOM (BITTEST DATUM STOPATOMBIT))
|
||||
(INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT)))
|
||||
(MACROCONTEXT (LOGAND DATUM CONTEXTMASK))
|
||||
(MACROP (BITTEST DATUM MACROBIT))
|
||||
(WAKEUP (LOGAND DATUM WAKEUPMASK))
|
||||
(BREAK (BITTEST DATUM BREAKBIT))))
|
||||
(ESCQUOTE (BITTEST DATUM ESCAPEBIT))
|
||||
(STOPATOM (BITTEST DATUM STOPATOMBIT))
|
||||
(INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT)))
|
||||
(MACROCONTEXT (LOGAND DATUM CONTEXTMASK))
|
||||
(MACROP (BITTEST DATUM MACROBIT))
|
||||
(WAKEUP (LOGAND DATUM WAKEUPMASK))
|
||||
(BREAK (BITTEST DATUM BREAKBIT))))
|
||||
|
||||
(RECORD READMACRODEF (MACROTYPE . MACROFN))
|
||||
|
||||
(DATATYPE READTABLEP ((READSA POINTER) (* ;
|
||||
"A CHARTABLE defining syntax of each char")
|
||||
(READMACRODEFS POINTER) (* ;
|
||||
"A hash table associating macro chars with macro definitions")
|
||||
(READMACROFLG FLAG) (* ;
|
||||
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
|
||||
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
|
||||
(COMMONLISP FLAG) (* ;
|
||||
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
|
||||
(NUMBERBASE BITS 5) (* ; "Not used")
|
||||
(CASEINSENSITIVE FLAG) (* ;
|
||||
"If true, unescaped lowercase chars are converted to uppercase in symbols")
|
||||
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
|
||||
(USESILPACKAGE FLAG) (* ;
|
||||
"If true, IL:READ ignores *PACKAGE* and reads in the IL package")
|
||||
(NIL 5 FLAG)
|
||||
(DISPATCHMACRODEFS POINTER) (* ;
|
||||
"An a-list of dispatching macro char and its dispatch definitions")
|
||||
(HASHMACROCHAR BYTE) (* ;
|
||||
"The character code used in this read table for the # dispatch macro")
|
||||
(ESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for single escape")
|
||||
(MULTESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for multiple escape")
|
||||
(PACKAGECHAR BYTE) (* ;
|
||||
"The character code used in this read table for package delimiter")
|
||||
(READTBLNAME POINTER) (* ;
|
||||
"The canonical 'name' of this read table")
|
||||
)
|
||||
READSA _ (create CHARTABLE))
|
||||
(DATATYPE READTABLEP ((READSA POINTER) (* ;
|
||||
"A CHARTABLE defining syntax of each char")
|
||||
(READMACRODEFS POINTER) (* ;
|
||||
"A hash table associating macro chars with macro definitions")
|
||||
(READMACROFLG FLAG) (* ;
|
||||
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
|
||||
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
|
||||
(COMMONLISP FLAG) (* ;
|
||||
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
|
||||
(NUMBERBASE BITS 5) (* ; "Not used")
|
||||
(CASEINSENSITIVE FLAG) (* ;
|
||||
"If true, unescaped lowercase chars are converted to uppercase in symbols")
|
||||
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
|
||||
(USESILPACKAGE FLAG) (* ;
|
||||
"If true, IL:READ ignores *PACKAGE* and reads in the IL package")
|
||||
(NIL 5 FLAG)
|
||||
(DISPATCHMACRODEFS POINTER) (* ;
|
||||
"An a-list of dispatching macro char and its dispatch definitions")
|
||||
(HASHMACROCHAR BYTE) (* ;
|
||||
"The character code used in this read table for the # dispatch macro")
|
||||
(ESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for single escape")
|
||||
(MULTESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for multiple escape")
|
||||
(PACKAGECHAR BYTE) (* ;
|
||||
"The character code used in this read table for package delimiter")
|
||||
(READTBLNAME POINTER) (* ;
|
||||
"The canonical 'name' of this read table")
|
||||
)
|
||||
READSA _ (create CHARTABLE))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'READTABLEP
|
||||
@@ -1835,10 +1832,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(MAKE-READER-ENVIRONMENT
|
||||
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
|
||||
(* ;
|
||||
"Edited 24-Oct-2021 21:53 by rmk:")
|
||||
(* ;
|
||||
"Edited 16-Aug-2021 23:44 by rmk:")
|
||||
(* ; "Edited 26-Dec-2021 14:32 by rmk")
|
||||
(* ; "Edited 24-Oct-2021 21:53 by rmk:")
|
||||
(* ; "Edited 16-Aug-2021 23:44 by rmk:")
|
||||
|
||||
(* ;; "PACKAGE can be a prop list of keyword-values")
|
||||
|
||||
@@ -1855,12 +1851,12 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
((CL:PACKAGEP PACKAGE)
|
||||
PACKAGE)
|
||||
[PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
|
||||
(\DEST PACKAGE 'PACKAGE]
|
||||
(\DTEST PACKAGE 'PACKAGE]
|
||||
(T *PACKAGE*))
|
||||
REREADTABLE _ (COND
|
||||
((READTABLEP READTABLE))
|
||||
[READTABLE (OR (FIND-READTABLE READTABLE)
|
||||
(\DEST READTABLE 'READTABLEP]
|
||||
(\DTEST READTABLE 'READTABLEP]
|
||||
(T *READTABLE*))
|
||||
REBASE _ (COND
|
||||
(BASE (\CHECKRADIX BASE))
|
||||
@@ -1870,8 +1866,12 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
REREADTABLEFORM _ READTABLEFORM])
|
||||
|
||||
(EQUAL-READER-ENVIRONMENT
|
||||
[LAMBDA (ENV1 ENV2) (* ; "Edited 16-Aug-2021 23:43 by rmk:")
|
||||
(* ; ":XCCS is the prehistoric value")
|
||||
[LAMBDA (ENV1 ENV2)
|
||||
|
||||
(* ;; "Edited 19-Dec-2021 14:09 by rmk: Replace constant :XCCS with *DEFAULT-EXTERNALFORMAT*")
|
||||
|
||||
(* ;; "Edited 19-Dec-2021 14:01 by rmk")
|
||||
|
||||
(AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1)
|
||||
(fetch (READER-ENVIRONMENT REREADTABLE) of ENV2))
|
||||
(EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1)
|
||||
@@ -1879,9 +1879,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1)
|
||||
(fetch (READER-ENVIRONMENT REBASE) of ENV2))
|
||||
(EQ (OR (fetch (READER-ENVIRONMENT REFORMAT) of ENV1)
|
||||
:XCCS)
|
||||
*DEFAULT-EXTERNALFORMAT*)
|
||||
(OR (fetch (READER-ENVIRONMENT REFORMAT) of ENV2)
|
||||
:XCCS))
|
||||
*DEFAULT-EXTERNALFORMAT*))
|
||||
(EQUAL (fetch (READER-ENVIRONMENT REPACKAGEFORM) of ENV1)
|
||||
(fetch (READER-ENVIRONMENT REPACKAGEFORM) of ENV2))
|
||||
(EQUAL (fetch (READER-ENVIRONMENT REREADTABLEFORM) of ENV1)
|
||||
@@ -1924,22 +1924,22 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018
|
||||
2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (18046 29198 (GETSYNTAX 18056 . 22887) (SETSYNTAX 22889 . 23962) (SYNTAXP 23964 . 26461)
|
||||
(\COPYSYNTAX 26463 . 27180) (\GETCHARCODE 27182 . 27470) (\SETFATSYNCODE 27472 . 28763) (
|
||||
\MAPCHARTABLE 28765 . 29196)) (29231 44197 (CONTROL 29241 . 29493) (COPYTERMTABLE 29495 . 29862) (
|
||||
DELETECONTROL 29864 . 32505) (GETDELETECONTROL 32507 . 33469) (ECHOCHAR 33471 . 34912) (ECHOCONTROL
|
||||
34914 . 35371) (ECHOMODE 35373 . 35619) (GETECHOMODE 35621 . 35785) (GETCONTROL 35787 . 35953) (
|
||||
GETTERMTABLE 35955 . 36022) (RAISE 36024 . 36450) (GETRAISE 36452 . 36614) (RESETTERMTABLE 36616 .
|
||||
37700) (SETTERMTABLE 37702 . 37936) (TERMTABLEP 37938 . 38099) (\GETTERMSYNTAX 38101 . 38372) (
|
||||
\GTTERMTABLE 38374 . 38710) (\ORIGTERMTABLE 38712 . 42322) (\SETTERMSYNTAX 42324 . 42959) (
|
||||
\TERMCLASSTOCODE 42961 . 43390) (\TERMCODETOCLASS 43392 . 43779) (\LITCHECK 43781 . 44195)) (46727
|
||||
70551 (COPYREADTABLE 46737 . 46935) (FIND-READTABLE 46937 . 47084) (IN-READTABLE 47086 . 47246) (
|
||||
ESCAPE 47248 . 47501) (GETBRK 47503 . 47641) (GETREADTABLE 47643 . 47779) (GETSEPR 47781 . 47919) (
|
||||
READMACROS 47921 . 48184) (READTABLEP 48186 . 48349) (READTABLEPROP 48351 . 53509) (RESETREADTABLE
|
||||
53511 . 57758) (SETBRK 57760 . 59370) (SETREADTABLE 59372 . 59560) (SETSEPR 59562 . 61104) (
|
||||
\GETREADSYNTAX 61106 . 63796) (\GTREADTABLE 63798 . 64023) (\GTREADTABLE1 64025 . 64281) (
|
||||
\ORIGREADTABLE 64283 . 66191) (\READCLASSTOCODE 66193 . 66644) (\SETMACROSYNTAX 66646 . 68441) (
|
||||
\SETREADSYNTAX 68443 . 69504) (\READTABLEP.DEFPRINT 69506 . 70549)) (83643 88096 (\ATBLSET 83653 .
|
||||
88094)) (88543 91975 (MAKE-READER-ENVIRONMENT 88553 . 90231) (EQUAL-READER-ENVIRONMENT 90233 . 91377)
|
||||
(SET-READER-ENVIRONMENT 91379 . 91973)))))
|
||||
(FILEMAP (NIL (17749 28901 (GETSYNTAX 17759 . 22590) (SETSYNTAX 22592 . 23665) (SYNTAXP 23667 . 26164)
|
||||
(\COPYSYNTAX 26166 . 26883) (\GETCHARCODE 26885 . 27173) (\SETFATSYNCODE 27175 . 28466) (
|
||||
\MAPCHARTABLE 28468 . 28899)) (28934 43900 (CONTROL 28944 . 29196) (COPYTERMTABLE 29198 . 29565) (
|
||||
DELETECONTROL 29567 . 32208) (GETDELETECONTROL 32210 . 33172) (ECHOCHAR 33174 . 34615) (ECHOCONTROL
|
||||
34617 . 35074) (ECHOMODE 35076 . 35322) (GETECHOMODE 35324 . 35488) (GETCONTROL 35490 . 35656) (
|
||||
GETTERMTABLE 35658 . 35725) (RAISE 35727 . 36153) (GETRAISE 36155 . 36317) (RESETTERMTABLE 36319 .
|
||||
37403) (SETTERMTABLE 37405 . 37639) (TERMTABLEP 37641 . 37802) (\GETTERMSYNTAX 37804 . 38075) (
|
||||
\GTTERMTABLE 38077 . 38413) (\ORIGTERMTABLE 38415 . 42025) (\SETTERMSYNTAX 42027 . 42662) (
|
||||
\TERMCLASSTOCODE 42664 . 43093) (\TERMCODETOCLASS 43095 . 43482) (\LITCHECK 43484 . 43898)) (46411
|
||||
70235 (COPYREADTABLE 46421 . 46619) (FIND-READTABLE 46621 . 46768) (IN-READTABLE 46770 . 46930) (
|
||||
ESCAPE 46932 . 47185) (GETBRK 47187 . 47325) (GETREADTABLE 47327 . 47463) (GETSEPR 47465 . 47603) (
|
||||
READMACROS 47605 . 47868) (READTABLEP 47870 . 48033) (READTABLEPROP 48035 . 53193) (RESETREADTABLE
|
||||
53195 . 57442) (SETBRK 57444 . 59054) (SETREADTABLE 59056 . 59244) (SETSEPR 59246 . 60788) (
|
||||
\GETREADSYNTAX 60790 . 63480) (\GTREADTABLE 63482 . 63707) (\GTREADTABLE1 63709 . 63965) (
|
||||
\ORIGREADTABLE 63967 . 65875) (\READCLASSTOCODE 65877 . 66328) (\SETMACROSYNTAX 66330 . 68125) (
|
||||
\SETREADSYNTAX 68127 . 69188) (\READTABLEP.DEFPRINT 69190 . 70233)) (83067 87520 (\ATBLSET 83077 .
|
||||
87518)) (87967 91384 (MAKE-READER-ENVIRONMENT 87977 . 89634) (EQUAL-READER-ENVIRONMENT 89636 . 90786)
|
||||
(SET-READER-ENVIRONMENT 90788 . 91382)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,104 +1,94 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED " 3-Apr-91 15:11:53" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CLSTREAMS.;4| 54013
|
||||
|
||||
|changes| |to:| (FUNCTIONS CL:WITH-INPUT-FROM-STRING)
|
||||
(FILECREATED "20-Jan-2022 09:16:52"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;4| 53233
|
||||
|
||||
|previous| |date:| "27-Feb-91 20:05:55" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CLSTREAMS.;3|)
|
||||
:PREVIOUS-DATE "27-Nov-2021 13:30:46"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3|)
|
||||
|
||||
|
||||
; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1985-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT CLSTREAMSCOMS)
|
||||
|
||||
(RPAQQ CLSTREAMSCOMS (
|
||||
(RPAQQ CLSTREAMSCOMS
|
||||
(
|
||||
|
||||
(* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21")
|
||||
|
||||
(COMS
|
||||
(* |;;| "documented functions and macros")
|
||||
(COMS
|
||||
(* |;;| "documented functions and macros")
|
||||
|
||||
(FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT)
|
||||
(FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P
|
||||
CL:OUTPUT-STREAM-P XCL:OPEN-STREAM-P)
|
||||
(COMS (FUNCTIONS FILE-STREAM-POSITION)
|
||||
(SETFS FILE-STREAM-POSITION))
|
||||
(FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P
|
||||
XCL:SYNONYM-STREAM-SYMBOL XCL:FOLLOW-SYNONYM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P
|
||||
XCL:BROADCAST-STREAM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P
|
||||
XCL:CONCATENATED-STREAM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P
|
||||
XCL:TWO-WAY-STREAM-OUTPUT-STREAM
|
||||
XCL:TWO-WAY-STREAM-INPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P
|
||||
XCL:ECHO-STREAM-INPUT-STREAM XCL:ECHO-STREAM-OUTPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-STRING-INPUT-STREAM
|
||||
MAKE-CONCATENATED-STRING-INPUT-STREAM)
|
||||
(FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
|
||||
(FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING
|
||||
CL:WITH-OUTPUT-TO-STRING CL:WITH-OPEN-FILE)
|
||||
(FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM
|
||||
MAKE-FILL-POINTER-OUTPUT-STREAM CL:GET-OUTPUT-STREAM-STRING
|
||||
\\STRING-STREAM-OUTCHARFN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN
|
||||
))
|
||||
(COMS
|
||||
(* |;;| "helpers")
|
||||
(FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT)
|
||||
(FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P CL:OUTPUT-STREAM-P
|
||||
XCL:OPEN-STREAM-P)
|
||||
(COMS (FUNCTIONS FILE-STREAM-POSITION)
|
||||
(SETFS FILE-STREAM-POSITION))
|
||||
(FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P XCL:SYNONYM-STREAM-SYMBOL
|
||||
XCL:FOLLOW-SYNONYM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P XCL:BROADCAST-STREAM-STREAMS
|
||||
)
|
||||
(FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P
|
||||
XCL:CONCATENATED-STREAM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P XCL:TWO-WAY-STREAM-OUTPUT-STREAM
|
||||
XCL:TWO-WAY-STREAM-INPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P XCL:ECHO-STREAM-INPUT-STREAM
|
||||
XCL:ECHO-STREAM-OUTPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-STRING-INPUT-STREAM MAKE-CONCATENATED-STRING-INPUT-STREAM)
|
||||
(FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
|
||||
(FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING CL:WITH-OUTPUT-TO-STRING
|
||||
CL:WITH-OPEN-FILE)
|
||||
(FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM MAKE-FILL-POINTER-OUTPUT-STREAM
|
||||
CL:GET-OUTPUT-STREAM-STRING \\STRING-STREAM-OUTCHARFN
|
||||
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN))
|
||||
(COMS
|
||||
(* |;;| "helpers")
|
||||
|
||||
(FUNCTIONS %NEW-FILE PREDICT-NAME)
|
||||
(DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
|
||||
(COMS
|
||||
(* |;;| "methods for the special devices")
|
||||
(FUNCTIONS %NEW-FILE PREDICT-NAME)
|
||||
(DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
|
||||
(COMS
|
||||
(* |;;| "methods for the special devices")
|
||||
|
||||
(FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN
|
||||
%BROADCAST-STREAM-DEVICE-CLOSEFILE
|
||||
%BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
|
||||
(FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %CONCATENATED-STREAM-DEVICE-BIN
|
||||
%CONCATENATED-STREAM-DEVICE-CLOSEFILE
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP
|
||||
%CONCATENATED-STREAM-DEVICE-PEEKBIN
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
|
||||
(FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %ECHO-STREAM-DEVICE-BIN)
|
||||
(FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
|
||||
(FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN
|
||||
%SYNONYM-STREAM-DEVICE-CLOSEFILE %SYNONYM-STREAM-DEVICE-EOFP
|
||||
%SYNONYM-STREAM-DEVICE-FORCEOUTPUT
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO
|
||||
%SYNONYM-STREAM-DEVICE-PEEKBIN %SYNONYM-STREAM-DEVICE-READP
|
||||
%SYNONYM-STREAM-DEVICE-BACKFILEPTR
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO
|
||||
%SYNONYM-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-OUTCHARFN
|
||||
%TWO-WAY-STREAM-DEVICE-CLOSEFILE %TWO-WAY-STREAM-DEVICE-EOFP
|
||||
%TWO-WAY-STREAM-DEVICE-READP %TWO-WAY-STREAM-DEVICE-BACKFILEPTR
|
||||
%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN)
|
||||
(FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE
|
||||
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR)
|
||||
(GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE
|
||||
%CONCATENATED-STREAM-DEVICE %TWO-WAY-STREAM-DEVICE
|
||||
%ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE))
|
||||
(COMS
|
||||
(* |;;| "helper stuff")
|
||||
(FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN
|
||||
%BROADCAST-STREAM-DEVICE-CLOSEFILE %BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
|
||||
(FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %CONCATENATED-STREAM-DEVICE-BIN %CONCATENATED-STREAM-DEVICE-CLOSEFILE
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP %CONCATENATED-STREAM-DEVICE-PEEKBIN
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
|
||||
(FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %ECHO-STREAM-DEVICE-BIN)
|
||||
(FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
|
||||
(FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN %SYNONYM-STREAM-DEVICE-CLOSEFILE
|
||||
%SYNONYM-STREAM-DEVICE-EOFP %SYNONYM-STREAM-DEVICE-FORCEOUTPUT
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO %SYNONYM-STREAM-DEVICE-PEEKBIN
|
||||
%SYNONYM-STREAM-DEVICE-READP %SYNONYM-STREAM-DEVICE-BACKFILEPTR
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO %SYNONYM-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-OUTCHARFN %TWO-WAY-STREAM-DEVICE-CLOSEFILE
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP %TWO-WAY-STREAM-DEVICE-READP
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN)
|
||||
(FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE %FILL-POINTER-STREAM-DEVICE-GETFILEPTR
|
||||
)
|
||||
(GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE
|
||||
%TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE))
|
||||
(COMS
|
||||
(* |;;| "helper stuff")
|
||||
|
||||
(FNS %SYNONYM-STREAM-DEVICE-GET-STREAM))
|
||||
(COMS
|
||||
(* |;;| "module initialization")
|
||||
(FNS %SYNONYM-STREAM-DEVICE-GET-STREAM))
|
||||
(COMS
|
||||
(* |;;| "module initialization")
|
||||
|
||||
(VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT*
|
||||
*STANDARD-OUTPUT* *STANDARD-INPUT*)
|
||||
(FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
|
||||
(FNS %INITIALIZE-CLSTREAM-TYPES)
|
||||
(DECLARE\: DONTEVAL@LOAD DOCOPY
|
||||
(* \; "initialization")
|
||||
(P (%INITIALIZE-CLSTREAM-TYPES)
|
||||
(%INITIALIZE-STANDARD-STREAMS))))
|
||||
(PROP FILETYPE CLSTREAMS)))
|
||||
(VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT* *STANDARD-OUTPUT*
|
||||
*STANDARD-INPUT*)
|
||||
(FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
|
||||
(FNS %INITIALIZE-CLSTREAM-TYPES)
|
||||
(DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization")
|
||||
(P (%INITIALIZE-CLSTREAM-TYPES)
|
||||
(%INITIALIZE-STANDARD-STREAMS))))
|
||||
(PROP FILETYPE CLSTREAMS)))
|
||||
|
||||
|
||||
|
||||
@@ -111,10 +101,10 @@
|
||||
|
||||
|
||||
(CL:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT)
|
||||
(ELEMENT-TYPE 'CL:STRING-CHAR)
|
||||
(IF-EXISTS NIL EXISTS-P)
|
||||
(IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
|
||||
(EXTERNAL-FORMAT :DEFAULT))
|
||||
(ELEMENT-TYPE 'CL:STRING-CHAR)
|
||||
(IF-EXISTS NIL EXISTS-P)
|
||||
(IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
|
||||
(EXTERNAL-FORMAT :DEFAULT))
|
||||
|
||||
(* |;;;| "Return a stream which reads from or writes to Filename. Defined keywords: :direction (one of :input, :output or :probe :element-type), Type of object to read or write, default String-Char, :if-exists (one of :error, :new-version, :overwrite, :append or nil), :if-does-not-exist (one of :error, :create or nil). :external-format (one of :DEFAULT, :EUC, :JIS, :W-MS, :MS or :XCCS). The specification of :external-format is based on the JEIDA proposal. See the manual for details.")
|
||||
|
||||
@@ -134,10 +124,10 @@
|
||||
(FOR-OUTPUT (MEMQ DIRECTION '(:IO :OUTPUT)))
|
||||
(ACCESS (INTERLISP-ACCESS DIRECTION))
|
||||
(FILE-TYPE (IF (CL:MEMBER ELEMENT-TYPE '(CL:UNSIGNED-BYTE CL:SIGNED-BYTE (CL:UNSIGNED-BYTE
|
||||
8)
|
||||
(CL:SIGNED-BYTE 8))
|
||||
:TEST
|
||||
'CL:EQUAL)
|
||||
8)
|
||||
(CL:SIGNED-BYTE 8))
|
||||
:TEST
|
||||
'CL:EQUAL)
|
||||
THEN 'BINARY
|
||||
ELSE 'TEXT))
|
||||
(STREAM NIL))
|
||||
@@ -149,7 +139,7 @@
|
||||
:NEWEST)
|
||||
:NEW-VERSION
|
||||
:ERROR))) (* \;
|
||||
"If the file does not exist, it is OK to have :if-exists :overwrite. ")
|
||||
"If the file does not exist, it is OK to have :if-exists :overwrite. ")
|
||||
(CL:UNLESS DOES-NOT-EXIST-P
|
||||
(SETQ IF-DOES-NOT-EXIST (COND
|
||||
((OR (EQ IF-EXISTS :APPEND)
|
||||
@@ -159,101 +149,98 @@
|
||||
NIL)
|
||||
(T :CREATE))))
|
||||
(CL:LOOP (* \;
|
||||
"See if the file exists and handle the existential keywords.")
|
||||
"See if the file exists and handle the existential keywords.")
|
||||
(LET* ((NAME (PREDICT-NAME PATHNAME))
|
||||
(CL:NAMESTRING (MKSTRING NAME)))
|
||||
(IF NAME
|
||||
THEN (* \; "file exists")
|
||||
(IF FOR-OUTPUT
|
||||
THEN
|
||||
THEN (* \; "file exists")
|
||||
(IF FOR-OUTPUT
|
||||
THEN
|
||||
(* |;;| "open for output/both")
|
||||
|
||||
(* |;;| "open for output/both")
|
||||
(CASE IF-EXISTS
|
||||
(:ERROR
|
||||
(CL:CERROR "write it anyway." "File ~A already exists."
|
||||
CL:NAMESTRING)
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS NIL
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE)
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:OVERWRITE
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:APPEND
|
||||
(IF (EQ DIRECTION :OUTPUT)
|
||||
THEN (* \;
|
||||
"if the direction is output it is the same as interlisp append")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'APPEND
|
||||
'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))
|
||||
))
|
||||
ELSE (* \;
|
||||
"if direction is io it opens the file for both and goes to the end of the file")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'BOTH 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(SETFILEPTR STREAM -1))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-exists." IF-EXISTS)))
|
||||
|elseif| FOR-INPUT
|
||||
|then|
|
||||
|
||||
(CASE IF-EXISTS
|
||||
(:ERROR
|
||||
(CL:CERROR "write it anyway." "File ~A already exists."
|
||||
CL:NAMESTRING)
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS NIL
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE)
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:OVERWRITE
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:APPEND
|
||||
(IF (EQ DIRECTION :OUTPUT)
|
||||
THEN (* \;
|
||||
"if the direction is output it is the same as interlisp append")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'APPEND
|
||||
'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT
|
||||
,EXTERNAL-FORMAT))))
|
||||
ELSE (* \;
|
||||
"if direction is io it opens the file for both and goes to the end of the file")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'BOTH
|
||||
'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT)
|
||||
)))
|
||||
(SETFILEPTR STREAM -1))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-exists." IF-EXISTS)))
|
||||
|elseif| FOR-INPUT
|
||||
|then|
|
||||
(* |;;| "open for input/both")
|
||||
|
||||
(* |;;| "open for input/both")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL)
|
||||
|else|
|
||||
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL)
|
||||
|else|
|
||||
(* |;;| "open for probe")
|
||||
|
||||
(* |;;| "open for probe")
|
||||
|
||||
(SETQ STREAM (|create| STREAM
|
||||
FULLFILENAME _ (FULLNAME CL:NAMESTRING)))
|
||||
(RETURN NIL))
|
||||
(SETQ STREAM (|create| STREAM
|
||||
FULLFILENAME _ (FULLNAME CL:NAMESTRING)))
|
||||
(RETURN NIL))
|
||||
|else|
|
||||
|
||||
(* |;;| "file does not exist")
|
||||
|
||||
(|if| FOR-OUTPUT
|
||||
|then| (CASE IF-DOES-NOT-EXIST
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
|elseif| FOR-INPUT
|
||||
|then| (CASE IF-DOES-NOT-EXIST
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE (%NEW-FILE PATHNAME))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
|else| (* \; "Open for probe.")
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE (%NEW-FILE PATHNAME))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
|else| (* \; "Open for probe.")
|
||||
(RETURN NIL)))))
|
||||
(STREAMPROP STREAM :FILE-STREAM-P T)
|
||||
STREAM))
|
||||
@@ -264,18 +251,18 @@
|
||||
|
||||
(|if| (STREAMP STREAM)
|
||||
|then| (|if| (OPENP STREAM)
|
||||
|then|
|
||||
|then|
|
||||
|
||||
(* |;;|
|
||||
"determine 'deletability' of stream's file before closing, as that trashes the info")
|
||||
(* |;;|
|
||||
"determine 'deletability' of stream's file before closing, as that trashes the info")
|
||||
|
||||
(LET ((ABORTABLE (AND (DIRTYABLE STREAM)
|
||||
(NOT (APPENDONLY STREAM)))))
|
||||
(CLOSEF STREAM)
|
||||
(|if| (AND ABORT ABORTABLE)
|
||||
|then| (* \;
|
||||
"eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.")
|
||||
(DELFILE (CL:NAMESTRING STREAM)))))
|
||||
(LET ((ABORTABLE (AND (DIRTYABLE STREAM)
|
||||
(NOT (APPENDONLY STREAM)))))
|
||||
(CLOSEF STREAM)
|
||||
(|if| (AND ABORT ABORTABLE)
|
||||
|then| (* \;
|
||||
"eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.")
|
||||
(DELFILE (CL:NAMESTRING STREAM)))))
|
||||
|else| (ERROR "Closing a non-stream" STREAM))
|
||||
T)
|
||||
|
||||
@@ -323,15 +310,19 @@
|
||||
DEVICE _ %SYNONYM-STREAM-DEVICE
|
||||
ACCESS _ 'BOTH
|
||||
F1 _ CL:SYMBOL
|
||||
LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE
|
||||
CL:SYMBOL))
|
||||
LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE CL:SYMBOL))
|
||||
OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN))))
|
||||
(STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T)
|
||||
|
||||
(* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE")
|
||||
|
||||
(|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE
|
||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE)))
|
||||
(|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (CONS STREAM
|
||||
(|fetch| (FDEV
|
||||
OPENFILELST
|
||||
)
|
||||
|of|
|
||||
%SYNONYM-STREAM-DEVICE
|
||||
)))
|
||||
STREAM))
|
||||
|
||||
(CL:DEFUN XCL:SYNONYM-STREAM-P (STREAM)
|
||||
@@ -355,14 +346,14 @@
|
||||
|
||||
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
||||
THEN (LET ((STREAM (|create| STREAM
|
||||
DEVICE _ %BROADCAST-STREAM-DEVICE
|
||||
ACCESS _ 'OUTPUT
|
||||
F1 _ STREAMS
|
||||
OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
|
||||
(STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
|
||||
STREAM)
|
||||
DEVICE _ %BROADCAST-STREAM-DEVICE
|
||||
ACCESS _ 'OUTPUT
|
||||
F1 _ STREAMS
|
||||
OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
|
||||
(STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
|
||||
STREAM)
|
||||
ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?))
|
||||
DO (RETURN STREAM?)))))
|
||||
DO (RETURN STREAM?)))))
|
||||
|
||||
(CL:DEFUN XCL:BROADCAST-STREAM-P (STREAM)
|
||||
|
||||
@@ -383,13 +374,13 @@
|
||||
|
||||
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
||||
THEN (LET ((STREAM (|create| STREAM
|
||||
DEVICE _ %CONCATENATED-STREAM-DEVICE
|
||||
ACCESS _ 'INPUT
|
||||
F1 _ STREAMS)))
|
||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
|
||||
STREAM)
|
||||
DEVICE _ %CONCATENATED-STREAM-DEVICE
|
||||
ACCESS _ 'INPUT
|
||||
F1 _ STREAMS)))
|
||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
|
||||
STREAM)
|
||||
ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?))
|
||||
DO (RETURN STREAM?)))))
|
||||
DO (RETURN STREAM?)))))
|
||||
|
||||
(CL:DEFUN XCL:CONCATENATED-STREAM-P (STREAM)
|
||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P))
|
||||
@@ -420,8 +411,13 @@
|
||||
|
||||
(* |;;| "save STREAM in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE")
|
||||
|
||||
(|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE
|
||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE)))
|
||||
(|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE |with| (CONS STREAM
|
||||
(|fetch| (FDEV
|
||||
OPENFILELST
|
||||
)
|
||||
|of|
|
||||
%TWO-WAY-STREAM-DEVICE
|
||||
)))
|
||||
STREAM))
|
||||
|
||||
(CL:DEFUN XCL:TWO-WAY-STREAM-P (STREAM)
|
||||
@@ -457,8 +453,13 @@
|
||||
|
||||
(* |;;| "save STREAM in the OPENFILELST field of %ECHO-STREAM-DEVICE")
|
||||
|
||||
(|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE
|
||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE)))
|
||||
(|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE |with| (CONS STREAM
|
||||
(|fetch| (FDEV
|
||||
OPENFILELST
|
||||
)
|
||||
|of|
|
||||
%ECHO-STREAM-DEVICE
|
||||
)))
|
||||
STREAM))
|
||||
|
||||
(CL:DEFUN XCL:ECHO-STREAM-P (STREAM)
|
||||
@@ -476,12 +477,12 @@
|
||||
(FETCH (STREAM F2) OF STREAM)))
|
||||
|
||||
(CL:DEFUN CL:MAKE-STRING-INPUT-STREAM (STRING &OPTIONAL (CL::START 0)
|
||||
(CL::END NIL))
|
||||
(CL::END NIL))
|
||||
|
||||
(* |;;;| "A CommonLisp function for producing a stream from a string. See CLtL p. 330")
|
||||
|
||||
(OPENSTRINGSTREAM (|if| (OR (NOT (CL:ZEROP CL::START))
|
||||
(NOT (NULL CL::END)))
|
||||
(NOT (NULL CL::END)))
|
||||
|then|
|
||||
|
||||
(* |;;| "A displaced array is ok here because the stream's uses GETBASEBYTE directly and doesn't go through the array code at all. ")
|
||||
@@ -497,9 +498,9 @@
|
||||
NIL)
|
||||
((NULL (CL:REST STRINGS))
|
||||
(CL:MAKE-STRING-INPUT-STREAM (CL:FIRST STRINGS)))
|
||||
(T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS
|
||||
COLLECT (CL:MAKE-STRING-INPUT-STREAM
|
||||
STRING))))))
|
||||
(T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS COLLECT (
|
||||
CL:MAKE-STRING-INPUT-STREAM
|
||||
STRING))))))
|
||||
|
||||
(CL:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS ()
|
||||
(CL:MAKE-ARRAY '(256)
|
||||
@@ -507,8 +508,8 @@
|
||||
'CL:STRING-CHAR :EXTENDABLE T :FILL-POINTER 0))
|
||||
|
||||
(DEFMACRO CL:WITH-OPEN-STREAM ((VAR STREAM)
|
||||
&BODY
|
||||
(BODY DECLS))
|
||||
&BODY
|
||||
(BODY DECLS))
|
||||
(LET ((ABORTP (GENSYM)))
|
||||
`(LET ((,VAR ,STREAM)
|
||||
(,ABORTP T))
|
||||
@@ -519,15 +520,15 @@
|
||||
(CL:CLOSE ,VAR :ABORT ,ABORTP)))))
|
||||
|
||||
(DEFMACRO CL:WITH-INPUT-FROM-STRING ((CL::VAR STRING &KEY (CL::INDEX NIL CL::INDEXP)
|
||||
(CL::START 0 CL::STARTP)
|
||||
(CL::END NIL CL:ENDP))
|
||||
&BODY
|
||||
(CL::BODY CL::DECLS))
|
||||
(CL::START 0 CL::STARTP)
|
||||
(CL::END NIL CL:ENDP))
|
||||
&BODY
|
||||
(CL::BODY CL::DECLS))
|
||||
`(LET* ((CL::$STRING$ ,STRING)
|
||||
(CL::$START$ ,CL::START))
|
||||
(DECLARE (LOCALVARS CL::$STRING$ CL::$START$))
|
||||
(CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$
|
||||
CL::$START$ ,CL::END))
|
||||
(CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$ CL::$START$
|
||||
,CL::END))
|
||||
,@CL::DECLS
|
||||
,@(CL:IF CL::INDEXP
|
||||
|
||||
@@ -541,8 +542,8 @@
|
||||
CL::BODY))))
|
||||
|
||||
(DEFMACRO CL:WITH-OUTPUT-TO-STRING ((VAR &OPTIONAL (STRING NIL ST-P))
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
(COND
|
||||
(ST-P `(CL:WITH-OPEN-STREAM (,VAR (MAKE-FILL-POINTER-OUTPUT-STREAM ,STRING))
|
||||
,@DECLS
|
||||
@@ -552,8 +553,8 @@
|
||||
(PROGN ,@FORMS (CL:GET-OUTPUT-STREAM-STRING ,VAR))))))
|
||||
|
||||
(DEFMACRO CL:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS)
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
|
||||
(* |;;;| "The file whose name is File-Name is opened using the OPEN-ARGS and bound to the variable VAR. The Forms are executed, and when they terminate, normally or otherwise, the file is closed.")
|
||||
|
||||
@@ -572,26 +573,26 @@
|
||||
|
||||
(MAKE-FILL-POINTER-OUTPUT-STREAM))
|
||||
|
||||
(CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||
)))
|
||||
(CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (%MAKE-INITIAL-STRING-STREAM-CONTENTS)))
|
||||
(DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE))
|
||||
(|if| (NOT (CL:ARRAY-HAS-FILL-POINTER-P STRING))
|
||||
|then| (\\ILLEGAL.ARG STRING)
|
||||
|else| (LET ((STREAM (|create| STREAM
|
||||
DEVICE _ \\FILL-POINTER-STREAM-DEVICE
|
||||
F1 _ STRING
|
||||
ACCESS _ 'OUTPUT
|
||||
OTHERPROPS _ '(STRING-OUTPUT-STREAM T))))
|
||||
DEVICE _ \\FILL-POINTER-STREAM-DEVICE
|
||||
F1 _ STRING
|
||||
ACCESS _ 'OUTPUT
|
||||
OTHERPROPS _ '(STRING-OUTPUT-STREAM T))))
|
||||
(* \;
|
||||
"give it a canned property list to save some consing.")
|
||||
(|replace| (STREAM OUTCHARFN) |of| STREAM
|
||||
|with| (|if| (EXTENDABLE-ARRAY-P STRING)
|
||||
|then| (FUNCTION \\ADJUSTABLE-STRING-STREAM-OUTCHARFN)
|
||||
|else| (FUNCTION \\STRING-STREAM-OUTCHARFN)))
|
||||
(|replace| (STREAM STRMBOUTFN) |of| STREAM |with|
|
||||
(FUNCTION \\OUTCHAR))
|
||||
STREAM)))
|
||||
"give it a canned property list to save some consing.")
|
||||
(|replace| (STREAM OUTCHARFN) |of| STREAM |with| (|if| (EXTENDABLE-ARRAY-P STRING)
|
||||
|then| (FUNCTION
|
||||
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN
|
||||
)
|
||||
|else| (FUNCTION
|
||||
\\STRING-STREAM-OUTCHARFN
|
||||
)))
|
||||
(|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\OUTCHAR))
|
||||
STREAM)))
|
||||
|
||||
(CL:DEFUN CL:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM)
|
||||
|
||||
@@ -600,17 +601,17 @@
|
||||
(|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM))
|
||||
|then| (ERROR "Stream not a string-output-stream" STRING-OUTPUT-STREAM)
|
||||
|else| (PROG1 (|fetch| (STREAM F1) |of| STRING-OUTPUT-STREAM)
|
||||
(|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||
)))))
|
||||
(|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||
)))))
|
||||
|
||||
(CL:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR)
|
||||
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
1))
|
||||
1))
|
||||
(CL:VECTOR-PUSH (CL:CHARACTER CHAR)
|
||||
(FETCH (STREAM F1) OF STREAM)))
|
||||
|
||||
@@ -618,11 +619,11 @@
|
||||
(LET ((STRING (FETCH (STREAM F1) OF STREAM))
|
||||
(CH (CL:CHARACTER CHAR)))
|
||||
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
1))
|
||||
1))
|
||||
|
||||
(* |;;| "Do the equivalent of VECTOR-PUSH-EXTEND inline to save the significant! overhead of calculating the new length at each character.")
|
||||
|
||||
@@ -630,17 +631,16 @@
|
||||
(LET ((CURRENT-LENGTH (CL:ARRAY-TOTAL-SIZE STRING)))
|
||||
(IF (>= CURRENT-LENGTH (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT))
|
||||
THEN (PROCEED-CASE (CL:ERROR 'END-OF-FILE :STREAM STREAM)
|
||||
(SI::RETRY-OUTCHAR NIL :REPORT
|
||||
"VECTOR-PUSH the character anyway" :CONDITION END-OF-FILE
|
||||
(CL:VECTOR-PUSH CH (FETCH (STREAM F1) OF STREAM))
|
||||
))
|
||||
(SI::RETRY-OUTCHAR NIL :REPORT "VECTOR-PUSH the character anyway"
|
||||
:CONDITION END-OF-FILE (CL:VECTOR-PUSH CH (FETCH (STREAM
|
||||
F1)
|
||||
OF STREAM))))
|
||||
ELSE (CL:ADJUST-ARRAY STRING (MIN (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT)
|
||||
(+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH
|
||||
1)
|
||||
|
||||
(+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH 1)
|
||||
|
||||
*DEFAULT-PUSH-EXTENSION-SIZE*
|
||||
))))
|
||||
(CL:VECTOR-PUSH CH STRING))))))
|
||||
))))
|
||||
(CL:VECTOR-PUSH CH STRING))))))
|
||||
|
||||
|
||||
|
||||
@@ -691,8 +691,7 @@
|
||||
|
||||
(* |;;| "charset function for broadcast streams. Not clear what the value should be, so we arbitrarily return the value of the last stream.")
|
||||
|
||||
(FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S
|
||||
NEWVALUE))))
|
||||
(FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S NEWVALUE))))
|
||||
(DEFINEQ
|
||||
|
||||
(%concatenated-stream-device-bin
|
||||
@@ -723,7 +722,7 @@
|
||||
(LET ((STREAMS (FETCH (STREAM F1) OF STREAM)))
|
||||
(IF STREAMS
|
||||
THEN (ACCESS-CHARSET (CAR STREAMS)
|
||||
NEWVALUE)
|
||||
NEWVALUE)
|
||||
ELSE 0)))
|
||||
(DEFINEQ
|
||||
|
||||
@@ -933,7 +932,7 @@
|
||||
(CL:DEFUN %INITIALIZE-STANDARD-STREAMS ()
|
||||
|
||||
(* |;;|
|
||||
"Called when CLSTREAMS is loaded. Almost everything is same as *TERMINAL-IO* to start with.")
|
||||
"Called when CLSTREAMS is loaded. Almost everything is same as *TERMINAL-IO* to start with.")
|
||||
|
||||
(CL:SETQ *QUERY-IO* (CL:MAKE-TWO-WAY-STREAM (CL:MAKE-SYNONYM-STREAM '\\LINEBUF.OFD)
|
||||
(CL:MAKE-SYNONYM-STREAM '\\TERM.OFD)))
|
||||
@@ -953,27 +952,54 @@
|
||||
(%INITIALIZE-STANDARD-STREAMS)
|
||||
)
|
||||
|
||||
(PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (34128 35316 (%BROADCAST-STREAM-DEVICE-BOUT 34138 . 34361) (
|
||||
%BROADCAST-STREAM-DEVICE-OUTCHARFN 34363 . 34814) (%BROADCAST-STREAM-DEVICE-CLOSEFILE 34816 . 35055) (
|
||||
%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 35057 . 35314)) (35732 37791 (%CONCATENATED-STREAM-DEVICE-BIN
|
||||
35742 . 36147) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 36149 . 36462) (%CONCATENATED-STREAM-DEVICE-EOFP
|
||||
36464 . 36828) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36830 . 37305) (
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 37307 . 37789)) (38129 38348 (%ECHO-STREAM-DEVICE-BIN 38139 .
|
||||
38346)) (38576 41921 (%SYNONYM-STREAM-DEVICE-BIN 38586 . 38774) (%SYNONYM-STREAM-DEVICE-BOUT 38776 .
|
||||
38977) (%SYNONYM-STREAM-DEVICE-OUTCHARFN 38979 . 39686) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 39688 .
|
||||
40272) (%SYNONYM-STREAM-DEVICE-EOFP 40274 . 40465) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 40467 . 40705)
|
||||
(%SYNONYM-STREAM-DEVICE-GETFILEINFO 40707 . 40944) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40946 . 41169) (
|
||||
%SYNONYM-STREAM-DEVICE-READP 41171 . 41282) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 41284 . 41430) (
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO 41432 . 41681) (%SYNONYM-STREAM-DEVICE-CHARSETFN 41683 . 41919)) (
|
||||
41922 46247 (%TWO-WAY-STREAM-DEVICE-BIN 41932 . 42105) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 42107 .
|
||||
42298) (%TWO-WAY-STREAM-DEVICE-BOUT 42300 . 42472) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 42474 . 42664)
|
||||
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 42666 . 43528) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 43530 . 44953) (
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP 44955 . 45131) (%TWO-WAY-STREAM-DEVICE-READP 45133 . 45326) (
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 45328 . 45464) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 45466 . 45695) (
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN 45697 . 45910) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45912 . 46245)) (46835
|
||||
47074 (%SYNONYM-STREAM-DEVICE-GET-STREAM 46845 . 47072)) (47780 53743 (%INITIALIZE-CLSTREAM-TYPES
|
||||
47790 . 53741)))))
|
||||
(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.
556
sources/CMLEXEC
556
sources/CMLEXEC
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Oct-2021 10:51:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLEXEC.;2 92464
|
||||
(FILECREATED "19-Dec-2021 09:48:29" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLEXEC.;5 91886
|
||||
|
||||
previous date%: "21-Jan-93 11:16:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLEXEC.;1)
|
||||
:CHANGES-TO (VARS CMLEXECCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Oct-2021 10:51:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLEXEC.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -18,7 +19,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(XCL:PROFILES "EXEC")
|
||||
(STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY)
|
||||
(* ;
|
||||
"These are public except for command-entry.")
|
||||
"These are public except for command-entry.")
|
||||
(FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW
|
||||
XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE
|
||||
@@ -29,7 +30,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(FUNCTIONS CIRCLAR-COPYER)
|
||||
(FNS COPY-CIRCLE)
|
||||
(* ;
|
||||
"CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
|
||||
"CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
|
||||
(FNS EXEC-READ DIR)
|
||||
(VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:///
|
||||
*CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED*
|
||||
@@ -64,10 +65,10 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(FILESLOAD CMLUNDO PROFILE)
|
||||
|
||||
(XCL:DEFPROFILE "EXEC" (XCL:*DEBUGGER-PROMPT* "")
|
||||
(XCL:*EXEC-PROMPT* "")
|
||||
(*READTABLE* "XCL")
|
||||
(*PACKAGE* "XCL")
|
||||
(XCL:*EVAL-FUNCTION* 'CL:EVAL))
|
||||
(XCL:*EXEC-PROMPT* "")
|
||||
(*READTABLE* "XCL")
|
||||
(*PACKAGE* "XCL")
|
||||
(XCL:*EVAL-FUNCTION* 'CL:EVAL))
|
||||
|
||||
(CL:DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST))
|
||||
ARGUMENTS
|
||||
@@ -148,39 +149,37 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(T (PRINT-EVENT-PROMPT *CURRENT-EVENT*)
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CURSOR T) (* ;
|
||||
"make sure can edit (in case cursor smashed somehow?)")
|
||||
"make sure can edit (in case cursor smashed somehow?)")
|
||||
(CL:WHEN NIL (* ; "Old expression")
|
||||
(TTYIN "" NIL NIL 'LISPXREAD NIL NIL BUFFER-EXPR-FROM-BELOW *READTABLE*))
|
||||
(EXEC-READ-LINE (LET ((%#RPARS NIL)
|
||||
(FONTCHANGEFLG NIL)
|
||||
(*PRINT-ESCAPE* T)
|
||||
(*PRINT-RADIX* (NOT (= *READ-BASE* 10)))
|
||||
(*PRINT-BASE* *READ-BASE*)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(*PRINT-GENSYM* ':REREAD)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-STRUCTURE* T))
|
||||
(DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG)
|
||||
(FONTCHANGEFLG NIL)
|
||||
(*PRINT-ESCAPE* T)
|
||||
(*PRINT-RADIX* (NOT (= *READ-BASE* 10)))
|
||||
(*PRINT-BASE* *READ-BASE*)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(*PRINT-GENSYM* ':REREAD)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-STRUCTURE* T))
|
||||
(DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG)
|
||||
(* ;
|
||||
"others are already globally special ")
|
||||
)
|
||||
(CL:WITH-OUTPUT-TO-STRING
|
||||
(STR)
|
||||
(FOR X ON INPUT
|
||||
DO (IF CIRCLE-FLAG
|
||||
THEN (* ;
|
||||
"Edited by TT (31-May-1990) CL:PRIN1 can print circlar")
|
||||
(CL:PRIN1 (CAR X)
|
||||
STR)
|
||||
ELSEIF (LISTP (CAR X))
|
||||
THEN (PRINTDEF (CAR X)
|
||||
(POSITION STR)
|
||||
NIL NIL NIL STR)
|
||||
ELSE (PRIN2 (CAR X)
|
||||
STR))
|
||||
(AND (CDR X)
|
||||
(PRIN1 " " STR])
|
||||
"others are already globally special "))
|
||||
(CL:WITH-OUTPUT-TO-STRING (STR)
|
||||
(FOR X ON INPUT
|
||||
DO (IF CIRCLE-FLAG
|
||||
THEN (* ;
|
||||
"Edited by TT (31-May-1990) CL:PRIN1 can print circlar")
|
||||
(CL:PRIN1 (CAR X)
|
||||
STR)
|
||||
ELSEIF (LISTP (CAR X))
|
||||
THEN (PRINTDEF (CAR X)
|
||||
(POSITION STR)
|
||||
NIL NIL NIL STR)
|
||||
ELSE (PRIN2 (CAR X)
|
||||
STR))
|
||||
(AND (CDR X)
|
||||
(PRIN1 " " STR])
|
||||
|
||||
(CL:DEFUN XCL::GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS)))
|
||||
(PROCESSPROP XCL::PROCESS 'PROFILE))
|
||||
@@ -192,7 +191,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(XCL:SAVE-PROFILE XCL::PROFILE))))
|
||||
|
||||
(CL:DEFUN XCL::SETF-GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS))
|
||||
(XCL::PROFILE XCL:*PROFILE*))
|
||||
(XCL::PROFILE XCL:*PROFILE*))
|
||||
(CL:SETQ XCL::PROFILE (XCL::PROFILIZE XCL::PROFILE))
|
||||
(PROCESSPROP XCL::PROCESS 'PROFILE XCL::PROFILE)
|
||||
XCL::PROFILE)
|
||||
@@ -215,7 +214,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"Start up an exec function in the proper profile, setting the default window title properly."
|
||||
(XCL:WITH-PROFILE (XCL:COPY-PROFILE XCL::PROFILE)
|
||||
(XCL::EXEC-TITLE-FUNCTION T (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
XCL::ID))
|
||||
(CL:FUNCALL XCL::EXEC-FUNCTION)))
|
||||
|
||||
(CL:DEFSETF XCL::GET-PROCESS-PROFILE XCL::SETF-GET-PROCESS-PROFILE)
|
||||
@@ -226,13 +225,13 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
STR
|
||||
(RETRYFLAG NIL) (* ; "A really gross hack for RETRY to always break. It exists because: users can setq HELPFLAG anywhere (can't bind it in DO-EVENTand set it in RETRY), RETRY operates on commands (can't wrap the form with a binding of HELPFLAG).")
|
||||
)
|
||||
(DECLARE (CL:SPECIAL RETRYFLAG)) (* ;
|
||||
"RETRY command sets this variable if it wants to be sure to break.")
|
||||
(DECLARE (CL:SPECIAL RETRYFLAG)) (* ;
|
||||
"RETRY command sets this variable if it wants to be sure to break.")
|
||||
(DSPFONT PRINTOUTFONT T)
|
||||
(SETQ INPUT ORIGINAL-INPUT)
|
||||
RETRY
|
||||
(SETQ TODO (COPY-CIRCLE INPUT)) (* ;
|
||||
"Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.")
|
||||
(SETQ TODO (COPY-CIRCLE INPUT)) (* ;
|
||||
"Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.")
|
||||
[COND
|
||||
[[AND (OR (STRINGP (CAR INPUT))
|
||||
(CL:SYMBOLP (CAR INPUT)))
|
||||
@@ -260,14 +259,13 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN *CURRENT-EVENT*
|
||||
(CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
INPUT) (* ;
|
||||
" Overwrite the original input with the newly generated one.")
|
||||
" Overwrite the original input with the newly generated one.")
|
||||
(CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*)
|
||||
(LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*
|
||||
))))
|
||||
(LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*))))
|
||||
(GO RETRY) (* ; " could have generated a command")
|
||||
)
|
||||
((NIL :EVAL) (* ;
|
||||
" normal kind of command, just apply")
|
||||
" normal kind of command, just apply")
|
||||
[SETQ TODO `((CL:FUNCALL ',(COMMAND-ENTRY-FUNCTION COM)
|
||||
',INPUT
|
||||
',ENVIRONMENT]
|
||||
@@ -284,11 +282,11 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN *EXEC-MAKE-UNDOABLE-P*
|
||||
[if (CDR TODO)
|
||||
then (SETQ TODO (CONS (OR (CDR (ASSOC (CAR TODO)
|
||||
LISPXFNS))
|
||||
(CAR TODO))
|
||||
(CDR TODO)))
|
||||
LISPXFNS))
|
||||
(CAR TODO))
|
||||
(CDR TODO)))
|
||||
else (SETQ TODO (LIST (XCL::MAKE-UNDOABLE (CAR TODO)
|
||||
NIL])]
|
||||
NIL])]
|
||||
(AND ADD-TO-SPELLING-LIST (HISTORY-ADD-TO-SPELLING-LISTS TODO))
|
||||
(SETQ LISPXHIST *CURRENT-EVENT*)
|
||||
(DSPFONT PRINTOUTFONT T)
|
||||
@@ -301,8 +299,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
[SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:IF RETRYFLAG
|
||||
(LET ((HELPFLAG 'BREAK!))
|
||||
(DECLARE (CL:SPECIAL HELPFLAG
|
||||
))
|
||||
(DECLARE (CL:SPECIAL HELPFLAG))
|
||||
(CL:FUNCALL FUNCTION TODO
|
||||
ENVIRONMENT))
|
||||
(CL:FUNCALL FUNCTION TODO ENVIRONMENT))
|
||||
@@ -319,69 +316,66 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(for X in VALUES do (EXEC-PRINT X))
|
||||
VALUES))))
|
||||
|
||||
(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;
|
||||
"True of top level execs. Used for event number restarting and profile caching.")
|
||||
(XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM)))
|
||||
(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;
|
||||
"True of top level execs. Used for event number restarting and profile caching.")
|
||||
(XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM)))
|
||||
(* ; "Window for this exec, if any.")
|
||||
(XCL::TITLE NIL XCL::TITLE-SUPPLIED)(* ;
|
||||
"If given, specific title for this window.")
|
||||
((:COMMAND-TABLES *THIS-EXEC-COMMANDS*)
|
||||
(LIST *EXEC-COMMAND-TABLE*)) (* ;
|
||||
"List of hash tables to look up commands in.")
|
||||
XCL::ENVIRONMENT (* ;
|
||||
"Lexical environment to evaluate things in, default NIL.")
|
||||
XCL::PROMPT (* ;
|
||||
"Special prompt to use (optional).")
|
||||
((:FUNCTION XCL::FN)
|
||||
'EVAL-INPUT) (* ; "Function for processing input.")
|
||||
XCL::PROFILE (* ;
|
||||
"Optional profile, sets the exec's bindings.")
|
||||
XCL::ID (* ; "A handle on the exec.")
|
||||
&ALLOW-OTHER-KEYS (* ; "To catch obsolete calls")
|
||||
&AUX
|
||||
(*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
(XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))
|
||||
(XCL::TITLE NIL XCL::TITLE-SUPPLIED) (* ;
|
||||
"If given, specific title for this window.")
|
||||
((:COMMAND-TABLES *THIS-EXEC-COMMANDS*)
|
||||
(LIST *EXEC-COMMAND-TABLE*)) (* ;
|
||||
"List of hash tables to look up commands in.")
|
||||
XCL::ENVIRONMENT (* ;
|
||||
"Lexical environment to evaluate things in, default NIL.")
|
||||
XCL::PROMPT (* ; "Special prompt to use (optional).")
|
||||
((:FUNCTION XCL::FN)
|
||||
'EVAL-INPUT) (* ; "Function for processing input.")
|
||||
XCL::PROFILE (* ;
|
||||
"Optional profile, sets the exec's bindings.")
|
||||
XCL::ID (* ; "A handle on the exec.")
|
||||
&ALLOW-OTHER-KEYS (* ; "To catch obsolete calls")
|
||||
&AUX
|
||||
(*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
(XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))
|
||||
(* ;
|
||||
"The exec's cached profile (if entering from a hardreset).")
|
||||
)
|
||||
"The exec's cached profile (if entering from a hardreset).")
|
||||
)
|
||||
[CL:PROGV (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION CAR))
|
||||
[MAPCAR *PER-EXEC-VARIABLES* (FUNCTION (LAMBDA (XCL::X)
|
||||
(EVAL (CADR XCL::X]
|
||||
(CL:WHEN (OR (NULL XCL::TOP-LEVEL-P)
|
||||
(NULL XCL::PROFILE-CACHE)) (* ; "If not hardresetting...")
|
||||
(CL:WHEN XCL::PROFILE (* ;
|
||||
"then initialize the profile vars.")
|
||||
(CL:WHEN XCL::PROFILE (* ; "then initialize the profile vars.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE))
|
||||
(CL:WHEN XCL::PROMPT (* ;
|
||||
"If a special prompt was provided (as from the debugger)...")
|
||||
"If a special prompt was provided (as from the debugger)...")
|
||||
(CL:SETQ XCL:*EXEC-PROMPT* XCL::PROMPT) (* ; "...use it.")
|
||||
))
|
||||
(CL:WHEN XCL::TOP-LEVEL-P
|
||||
(CL:IF (NULL XCL::PROFILE-CACHE) (* ;
|
||||
"This was a new entry into top level exec.")
|
||||
"This was a new entry into top level exec.")
|
||||
(CL:SETF (XCL::GET-PROCESS-PROFILE (THIS.PROCESS))
|
||||
(XCL:SAVE-PROFILE (XCL:COPY-PROFILE "EXEC")))
|
||||
(* ;
|
||||
"...make a fresh cache and save bindings into it.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ;
|
||||
"...otherwise it was a HARDRESET.")
|
||||
"...make a fresh cache and save bindings into it.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ; "...otherwise it was a HARDRESET.")
|
||||
))
|
||||
(CL:WHEN XCL::WINDOW
|
||||
(COND
|
||||
((NOT XCL::TITLE-SUPPLIED) (* ;
|
||||
"If no title was supplied, set it to the default.")
|
||||
"If no title was supplied, set it to the default.")
|
||||
(XCL::EXEC-TITLE-FUNCTION XCL::WINDOW *EXEC-ID*))
|
||||
(XCL::TITLE (* ;
|
||||
"If a non-nil title was supplied, set the title to it.")
|
||||
"If a non-nil title was supplied, set the title to it.")
|
||||
(WINDOWPROP XCL::WINDOW 'TITLE XCL::TITLE)))
|
||||
(TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))
|
||||
(LET [(*CURRENT-EVENT* NIL) (* ;
|
||||
"the event being processed. Used by some commands")
|
||||
"the event being processed. Used by some commands")
|
||||
(XCL::OLD-DS (CL:IF XCL::WINDOW
|
||||
(TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))]
|
||||
(CL:LOOP (CL:FORMAT T "~&~%%") (* ;
|
||||
"newlines to notice that this is a new instance of the exec")
|
||||
"newlines to notice that this is a new instance of the exec")
|
||||
(PROG1 [ERSETQ (CL:LOOP (* ; "loop until errors out")
|
||||
(CL:SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT
|
||||
LISPXHISTORY *EXEC-ID*
|
||||
@@ -397,25 +391,24 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE (CL:SPECIAL LISPXHIST HELPCLOCK))
|
||||
(CL:UNLESS (CL:EQUAL XCL::ORIGINAL-INPUT
|
||||
'(NIL))
|
||||
(DO-EVENT XCL::ORIGINAL-INPUT
|
||||
XCL::ENVIRONMENT XCL::FN)
|
||||
(DO-EVENT XCL::ORIGINAL-INPUT XCL::ENVIRONMENT
|
||||
XCL::FN)
|
||||
(CL:WHEN XCL::TOP-LEVEL-P
|
||||
(* ; "Used to determine whether to cache the settings of the profile back into the process (for retrieval in case of hardreset).")
|
||||
(XCL::SAVE-CURRENT-EXEC-PROFILE)))]
|
||||
(CL:WHEN XCL::WINDOW (TTYDISPLAYSTREAM XCL::OLD-DS)))])
|
||||
|
||||
(CL:DEFUN EXEC-EVAL (FORM &OPTIONAL ENVIRONMENT &KEY (PROMPT ">")
|
||||
(ID "eval/")
|
||||
((:TYPE *CURRENT-EXEC-TYPE*)
|
||||
'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.")
|
||||
(ID "eval/")
|
||||
((:TYPE *CURRENT-EXEC-TYPE*)
|
||||
'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.")
|
||||
(LET ((*CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY ID PROMPT T))
|
||||
(LISPXHIST LISPXHIST)
|
||||
(HELPCLOCK 0)
|
||||
VALUES)
|
||||
(DECLARE (CL:SPECIAL *CURRENT-EVENT* LISPXHIST HELPCLOCK))
|
||||
(SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT
|
||||
*CURRENT-EVENT*)
|
||||
(LIST FORM))
|
||||
(SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
(LIST FORM))
|
||||
ENVIRONMENT)))
|
||||
(SETQ IT (CAR VALUES))
|
||||
(COND
|
||||
@@ -455,8 +448,8 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
`(EXEC-VALUE-OF ',EVENT-SPEC))
|
||||
|
||||
(CL:DEFUN ADD-EXEC (&KEY (XCL::PROFILE XCL:*PROFILE*)
|
||||
XCL::REGION XCL::TTY (EXEC 'EXEC)
|
||||
XCL::ID &ALLOW-OTHER-KEYS)
|
||||
XCL::REGION XCL::TTY (EXEC 'EXEC)
|
||||
XCL::ID &ALLOW-OTHER-KEYS)
|
||||
(LET* [(XCL::WINDOW (XCL::SETUP-EXEC-WINDOW (CREATEW XCL::REGION "Exec")))
|
||||
(XCL::HANDLE (ADD.PROCESS
|
||||
`[PROGN (TTYDISPLAYSTREAM ',XCL::WINDOW)
|
||||
@@ -465,7 +458,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
',XCL::WINDOW)
|
||||
,(CASE EXEC
|
||||
(EXEC `(EXEC :TOP-LEVEL-P T :PROFILE ',XCL::PROFILE :ID
|
||||
',XCL::ID))
|
||||
',XCL::ID))
|
||||
(T `(XCL::ENTER-EXEC-FUNCTION ',EXEC ',XCL::PROFILE
|
||||
',XCL::ID)))]
|
||||
'NAME
|
||||
@@ -483,21 +476,21 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
((AND (READP T)
|
||||
(SYNTAXP (PEEKCCODE T T)
|
||||
'EOL)) (* ;
|
||||
"Avoid picking up end of line as a NIL.")
|
||||
"Avoid picking up end of line as a NIL.")
|
||||
(READC T)))
|
||||
(SETQ LINE (LIST (EXEC-READ BUFFER-STRING)))
|
||||
TOP (COND
|
||||
((LISTP (CAR LINE)) (* ;
|
||||
"If we got a list, return right away--it's a standard EVAL form of input")
|
||||
"If we got a list, return right away--it's a standard EVAL form of input")
|
||||
(GO OUT)))
|
||||
LP (SETQ SPACEFLG NIL) (* ; "to distinguish between")
|
||||
(* ; "FOO (A B)")
|
||||
(* ; "FOO(A B)")
|
||||
(* ;
|
||||
"the latter has no space and returns right away")
|
||||
"the latter has no space and returns right away")
|
||||
LP1 (COND
|
||||
((NOT (READP T)) (* ;
|
||||
"nothing more in line buffer, so must have consumed last thing on the line")
|
||||
"nothing more in line buffer, so must have consumed last thing on the line")
|
||||
(GO OUT))
|
||||
((NULL (SETQ CHRCODE (PEEKCCODE T T))) (* ; "PEEKCCODE can return NIL when stream is at EOF. However, we already checked for READP before getting here.")
|
||||
(GO OUT))
|
||||
@@ -510,7 +503,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SHOULDNT))
|
||||
(AND (NULL (CDR LINE))
|
||||
(SETQ LINE (NCONC1 LINE NIL))) (* ;
|
||||
" A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called")
|
||||
" A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called")
|
||||
(GO OUT))
|
||||
((EQ CHRCODE (CHARCODE SPACE))
|
||||
(SETQ SPACEFLG T)
|
||||
@@ -523,7 +516,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SYNTAXP CHRCODE 'RIGHTBRACKET *READTABLE*)))
|
||||
(GO LP))
|
||||
((NOT SPACEFLG) (* ;
|
||||
"A list terminates the line if it is the second element on the line, not preceded by a space.")
|
||||
"A list terminates the line if it is the second element on the line, not preceded by a space.")
|
||||
|
||||
(* ;; "[JDS 1/12/88: This used to test (AND (NOT SPACEFLG) (READP T)), and loop if there were more input pending. This seems wrong, because when you type it should throw the carriage at once, and not depend on how fast you're typing. Further, when there's type-ahead, it's often followed by a SPACE, to prevent output pausing. With the old test here, that would hang up a final eval-quote form without executing it.]")
|
||||
|
||||
@@ -533,7 +526,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
OUT (RETURN (COND
|
||||
((AND (LISTP LINE)
|
||||
CTRLUFLG) (* ;
|
||||
"Edit interrupt during reading--forces structure editor use.")
|
||||
"Edit interrupt during reading--forces structure editor use.")
|
||||
(SETQ CTRLUFLG NIL)
|
||||
(LET ((*EDIT-INPUT-WITH-TTYIN* NIL))
|
||||
(FIX-FORM LINE)))
|
||||
@@ -553,7 +546,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ COM (GETHASH STR TABLE)))
|
||||
TABLE))))
|
||||
|
||||
(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990")
|
||||
(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990")
|
||||
(PROG (SCANBUF REST VAL NEW BODY ID AUX (CIRCLAR-FLAG NIL))
|
||||
(COND
|
||||
((NLISTP INPUT)
|
||||
@@ -580,9 +573,9 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ CIRCLAR-FLAG T)
|
||||
(RPLACD NEW (CDR ID)))
|
||||
(T [push REST (SETQ AUX (CONS (CADR NEW)
|
||||
(CDDR NEW]
|
||||
(CDDR NEW]
|
||||
(push SCANBUF (CONS (CDR NEW)
|
||||
AUX))
|
||||
AUX))
|
||||
(RPLACD NEW AUX)))
|
||||
(COND
|
||||
((NLISTP (CAR NEW)))
|
||||
@@ -591,9 +584,9 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ CIRCLAR-FLAG T)
|
||||
(RPLACA NEW (CDR ID)))
|
||||
(T [push REST (SETQ AUX (CONS (CAAR NEW)
|
||||
(CDAR NEW]
|
||||
(CDAR NEW]
|
||||
(push SCANBUF (CONS (CAR NEW)
|
||||
AUX))
|
||||
AUX))
|
||||
(RPLACA NEW AUX]
|
||||
(GO LP)))
|
||||
(DEFINEQ
|
||||
@@ -727,10 +720,10 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"List of command hash-tables for the current executive")
|
||||
|
||||
(DEFGLOBALVAR *EXEC-COMMAND-TABLE* (HASHARRAY 30 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL)
|
||||
"hash-table for top level exec commands")
|
||||
"hash-table for top level exec commands")
|
||||
|
||||
(DEFGLOBALVAR *DEBUGGER-COMMAND-TABLE* (HASHARRAY 20 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL)
|
||||
"string-equal hash-table for debugger commands")
|
||||
"string-equal hash-table for debugger commands")
|
||||
|
||||
(CL:DEFVAR *CURRENT-EXEC-TYPE* NIL
|
||||
"Rebound under Exec; if NIL, means use default")
|
||||
@@ -1337,7 +1330,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"Start an old-style LISPX window"])
|
||||
|
||||
(ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100)
|
||||
(GREETHIST))
|
||||
(GREETHIST))
|
||||
|
||||
|
||||
|
||||
@@ -1347,24 +1340,23 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEF-DEFINE-TYPE COMMANDS "Exec Commands")
|
||||
|
||||
(DEFDEFINER (DEFCOMMAND [:NAME (CL:LAMBDA (WHOLE)
|
||||
(LET ((NAME (CL:SECOND WHOLE)))
|
||||
(CL:IF (CL:CONSP NAME)
|
||||
(CAR NAME)
|
||||
NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV
|
||||
&BODY BODY)
|
||||
(LET ((NAME (CL:SECOND WHOLE)))
|
||||
(CL:IF (CL:CONSP NAME)
|
||||
(CAR NAME)
|
||||
NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV
|
||||
&BODY BODY)
|
||||
[LET ((COMMAND-LEVEL '*EXEC-COMMAND-TABLE*)
|
||||
(COMMAND-TYPE :EVAL)
|
||||
(PREFIX "exec-"))
|
||||
[if (LISTP NAME)
|
||||
then (SETQ NAME (PROG1 (CAR NAME)
|
||||
[for X in (CDR NAME)
|
||||
do (CL:ECASE X
|
||||
((:QUIET :HISTORY :INPUT :EVAL :MACRO) (SETQ
|
||||
COMMAND-TYPE
|
||||
X))
|
||||
((:DEBUGGER :BREAK)
|
||||
(SETQ COMMAND-LEVEL '*DEBUGGER-COMMAND-TABLE*)
|
||||
(SETQ PREFIX "break-")))])]
|
||||
[for X in (CDR NAME) do (CL:ECASE X
|
||||
((:QUIET :HISTORY :INPUT :EVAL :MACRO)
|
||||
(SETQ COMMAND-TYPE X))
|
||||
((:DEBUGGER :BREAK)
|
||||
(SETQ COMMAND-LEVEL
|
||||
'*DEBUGGER-COMMAND-TABLE*)
|
||||
(SETQ PREFIX "break-")))])]
|
||||
(LET* ((CMACRONAME (PACK* PREFIX NAME))
|
||||
(STRINGNAME (STRING NAME)))
|
||||
(CL:MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING)
|
||||
@@ -1397,32 +1389,32 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:FORMAT T " ~20Tto apply function to the arguments given~&~%%or one of:")
|
||||
(FOR X ON (REVERSE *THIS-EXEC-COMMANDS*)
|
||||
DO (LET (COMS)
|
||||
[MAPHASH (CAR X)
|
||||
#'(CL:LAMBDA (VAL KEY)
|
||||
(AND [NOT (SOME (CDR X)
|
||||
#'(CL:LAMBDA (TAB)
|
||||
(GETHASH KEY TAB]
|
||||
(PUSH COMS (LIST KEY VAL]
|
||||
(CL:MAPC #'[CL:LAMBDA (COM)
|
||||
(CL:FORMAT T "~&")
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CL:FORMAT T "~A " (CAR COM))
|
||||
(DSPFONT COMMENTFONT T)
|
||||
(PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM)))
|
||||
(DSPFONT DEFAULTFONT T)
|
||||
(LET [(DOC (CL:DOCUMENTATION (CAR COM)
|
||||
'COMMANDS]
|
||||
(CL:WHEN DOC
|
||||
(TAB 20 1 T)
|
||||
(CL:FORMAT T "~A" DOC))]
|
||||
(CL:SORT COMS #'CL:STRING< :KEY #'CAR])
|
||||
[MAPHASH (CAR X)
|
||||
#'(CL:LAMBDA (VAL KEY)
|
||||
(AND [NOT (SOME (CDR X)
|
||||
#'(CL:LAMBDA (TAB)
|
||||
(GETHASH KEY TAB]
|
||||
(PUSH COMS (LIST KEY VAL]
|
||||
(CL:MAPC #'[CL:LAMBDA (COM)
|
||||
(CL:FORMAT T "~&")
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CL:FORMAT T "~A " (CAR COM))
|
||||
(DSPFONT COMMENTFONT T)
|
||||
(PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM)))
|
||||
(DSPFONT DEFAULTFONT T)
|
||||
(LET [(DOC (CL:DOCUMENTATION (CAR COM)
|
||||
'COMMANDS]
|
||||
(CL:WHEN DOC
|
||||
(TAB 20 1 T)
|
||||
(CL:FORMAT T "~A" DOC))]
|
||||
(CL:SORT COMS #'CL:STRING< :KEY #'CAR])
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND ("??" :QUIET) (&REST EVENT-SPECS) "Show events specified EVENT-SPECS (or all events)"
|
||||
(IF (AND EVENT-SPECS (EQ (CAR EVENT-SPECS)
|
||||
':INPUT))
|
||||
':INPUT))
|
||||
THEN (PRINT-HISTORY LISPXHISTORY (CDR EVENT-SPECS)
|
||||
T)
|
||||
T)
|
||||
ELSE (PRINT-HISTORY LISPXHISTORY EVENT-SPECS))
|
||||
(CL:VALUES))
|
||||
|
||||
@@ -1435,21 +1427,19 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEFCOMMAND ("DIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME"
|
||||
[DODIR (CONS PATHNAME (MAPCAR KEYWORDS (FUNCTION (LAMBDA (CL:KEYWORD)
|
||||
(IF (CL:SYMBOLP CL:KEYWORD)
|
||||
THEN (CL:INTERN (CL:SYMBOL-NAME
|
||||
CL:KEYWORD)
|
||||
"INTERLISP")
|
||||
THEN (CL:INTERN (CL:SYMBOL-NAME CL:KEYWORD)
|
||||
"INTERLISP")
|
||||
ELSE CL:KEYWORD])
|
||||
|
||||
(DEFCOMMAND "DO-EVENTS" (&REST INPUTS &ENVIRONMENT ENV)
|
||||
"Execute the multiple events in INPUTS, using the environment ENV for all evaluations."
|
||||
[LET ((OUTER-EVENT (AND *CURRENT-EVENT* (COPY-EXEC-EVENT *CURRENT-EVENT*)))
|
||||
(* ;
|
||||
"DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")
|
||||
"DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")
|
||||
)
|
||||
(CL:WHEN OUTER-EVENT
|
||||
(CL:SETF (EXEC-EVENT-INPUT OUTER-EVENT)
|
||||
(CONS 'DO-EVENTS INPUTS)) (* ;
|
||||
"Each of these is fixed up below.")
|
||||
(CONS 'DO-EVENTS INPUTS)) (* ; "Each of these is fixed up below.")
|
||||
)
|
||||
(ERSETQ (CL:MAPL #'[CL:LAMBDA (INPUT)
|
||||
(LET ([TODO (CL:IF (EQ (CAR (LISTP (CAR INPUT)))
|
||||
@@ -1460,32 +1450,32 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO))
|
||||
(SETQ VALUES (DO-EVENT TODO ENV))
|
||||
(* ;
|
||||
"If it exists, *CURRENT-EVENT* gets smashed here.")
|
||||
"If it exists, *CURRENT-EVENT* gets smashed here.")
|
||||
(CL:WHEN OUTER-EVENT (* ; "If there is an outer event...")
|
||||
|
||||
(* ;;
|
||||
"Fix the outer event's list of inputs with the expanded input.")
|
||||
"Fix the outer event's list of inputs with the expanded input.")
|
||||
|
||||
(RPLACA INPUT (CAR (EXEC-EVENT-INPUT *CURRENT-EVENT*)))
|
||||
(CL:WHEN VALUES (* ;
|
||||
"If the last sub-event generated some values...")
|
||||
"If the last sub-event generated some values...")
|
||||
|
||||
(* ;;
|
||||
"Add the new values to the outer event's values.")
|
||||
"Add the new values to the outer event's values.")
|
||||
|
||||
[LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS
|
||||
OUTER-EVENT)
|
||||
[LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS
|
||||
OUTER-EVENT)
|
||||
'LISPXVALUES]
|
||||
(CL:IF OLD-VALUES
|
||||
(NCONC OLD-VALUES VALUES)
|
||||
(CL:SETF (EXEC-EVENT-PROPS OUTER-EVENT)
|
||||
(LIST* 'LISPXVALUES VALUES
|
||||
(EXEC-EVENT-PROPS
|
||||
OUTER-EVENT))))]))]
|
||||
(EXEC-EVENT-PROPS OUTER-EVENT))
|
||||
))]))]
|
||||
INPUTS))
|
||||
(CL:WHEN *CURRENT-EVENT* (* ; "If there was a current event...")
|
||||
(* ;
|
||||
"Smash saved values back from OUTER-EVENT.")
|
||||
"Smash saved values back from OUTER-EVENT.")
|
||||
(CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
(EXEC-EVENT-INPUT OUTER-EVENT))
|
||||
(CL:SETF (EXEC-EVENT-ID *CURRENT-EVENT*)
|
||||
@@ -1496,19 +1486,18 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(EXEC-EVENT-PROPS OUTER-EVENT)))]
|
||||
(SETQ *CURRENT-EVENT* NIL) (* ; "Keeps the DO-EVENT which is evaluating us from setting the event's results to (the result of evaluating) the NIL we return. This is alright since *CURRENT-EVENT* is already pointed to by the history list.")
|
||||
(CL:VALUES) (* ;
|
||||
"We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.")
|
||||
"We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.")
|
||||
)
|
||||
|
||||
(DEFCOMMAND ("FIX" :HISTORY) (&REST EVENT-SPEC) "Edit input for specified events"
|
||||
[APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT
|
||||
(FIND-HISTORY-EVENTS
|
||||
(OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY])
|
||||
[APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT (FIND-HISTORY-EVENTS
|
||||
(OR EVENT-SPEC
|
||||
'(-1))
|
||||
LISPXHISTORY])
|
||||
|
||||
(DEFCOMMAND "FORGET" (&REST EVENT-SPEC) "Erase UNDO information (for specified events)."
|
||||
(FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY) DO (UNDOLISPX2 EVENT T)
|
||||
FINALLY (CL:FORMAT T "Forgotten.~&"))
|
||||
LISPXHISTORY) DO (UNDOLISPX2 EVENT T) FINALLY (CL:FORMAT T "Forgotten.~&"))
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND "NAME" (COMMAND-NAME &OPTIONAL ARGUMENT-LIST &REST EVENT-SPEC)
|
||||
@@ -1517,8 +1506,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:PUSH ARGUMENT-LIST EVENT-SPEC)
|
||||
(SETQ ARGUMENT-LIST NIL))
|
||||
[LET [(EVENTS (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY))
|
||||
(ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST
|
||||
COLLECT (PACK* 'ARG I]
|
||||
(ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST COLLECT (PACK* 'ARG I]
|
||||
(CL:EVAL `(DEFCOMMAND (,COMMAND-NAME :HISTORY) ,ARGNAMES
|
||||
[SUBPAIR ',ARGNAMES (LIST ,@ARGNAMES)
|
||||
',(SUBPAIR ARGUMENT-LIST ARGNAMES (EVENTS-INPUT EVENTS)
|
||||
@@ -1536,7 +1524,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(DEFCOMMAND ("REDO" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified event(s)"
|
||||
(EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY)))
|
||||
LISPXHISTORY)))
|
||||
|
||||
(DEFCOMMAND ("REMEMBER" :EVAL) (&REST EVENT-SPEC)
|
||||
"Tell Manager to remember type-in from specified event(s)"
|
||||
@@ -1549,40 +1537,37 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEFCOMMAND "UNDO" (&REST EVENT-SPEC)
|
||||
"Undo side effects associated with the specified event (or last undoable one)"
|
||||
[FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT)))
|
||||
(RESULT (UNDOLISPX2 EVENT)))
|
||||
(CL:IF (LISTP INPUT)
|
||||
(SETQ INPUT (CAR INPUT)))
|
||||
(COND
|
||||
((NULL RESULT)
|
||||
(CL:FORMAT T
|
||||
"No undo info saved for ~A.~&"
|
||||
INPUT))
|
||||
((EQ RESULT 'already)
|
||||
(CL:FORMAT T "~A already undone.~&"
|
||||
INPUT))
|
||||
(T (CL:FORMAT T "~A undone.~&" INPUT]
|
||||
LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT)))
|
||||
(RESULT (UNDOLISPX2 EVENT)))
|
||||
(CL:IF (LISTP INPUT)
|
||||
(SETQ INPUT (CAR INPUT)))
|
||||
(COND
|
||||
((NULL RESULT)
|
||||
(CL:FORMAT T "No undo info saved for ~A.~&" INPUT))
|
||||
((EQ RESULT 'already)
|
||||
(CL:FORMAT T "~A already undone.~&" INPUT))
|
||||
(T (CL:FORMAT T "~A undone.~&" INPUT]
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND ("USE" :HISTORY) (&REST LINE) "USE <new> [FOR <old>] [IN <event-spec>]"
|
||||
|
||||
(* ;;
|
||||
"this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible")
|
||||
"this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible")
|
||||
|
||||
[PROG (EVENT-SPECS EXPR ARGS VARS (STATE 'VARS)
|
||||
LST TEM USE-ARGS GENLST)
|
||||
LP [COND
|
||||
([OR (NULL LST)
|
||||
(NULL (CDR LINE))
|
||||
(NULL (CASE-EQUALP (CAR LINE) (* ;
|
||||
"look for one of the special keywords")
|
||||
(NULL (CASE-EQUALP (CAR LINE) (* ;
|
||||
"look for one of the special keywords")
|
||||
(FOR (COND
|
||||
((EQ STATE 'VARS)
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'ARGS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
((EQ STATE 'VARS)
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'ARGS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
(AND (COND
|
||||
((EQ STATE 'EXPR)
|
||||
NIL)
|
||||
@@ -1590,30 +1575,30 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST)))
|
||||
((EQ STATE 'VARS)(* ;
|
||||
"E.g. user types USE A AND B following previous USE command.")
|
||||
"E.g. user types USE A AND B following previous USE command.")
|
||||
(SETQ VARS (NCONC1 VARS LST]
|
||||
(SETQ STATE 'VARS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
(IN (COND
|
||||
((AND (EQ STATE 'VARS)
|
||||
(NULL ARGS))
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T)
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T]
|
||||
((AND (EQ STATE 'VARS)
|
||||
(NULL ARGS))
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T)
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T]
|
||||
(SETQ LST (NCONC1 LST (COND
|
||||
(NIL (MEMBER (CAR LINE)
|
||||
TEM)
|
||||
|
||||
(* ;;
|
||||
"This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A")
|
||||
"This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A")
|
||||
|
||||
(LET ((TEMP (CONCAT "temp string")))
|
||||
(CL:PUSH (CONS (CAR LINE)
|
||||
@@ -1639,7 +1624,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(SETQ EXPR (MAPCAR (FIND-HISTORY-EVENTS EXPR LISPXHISTORY)
|
||||
(FUNCTION EXEC-EVENT-INPUT))) (* ;
|
||||
"EXPR is now a list of event inputs")
|
||||
"EXPR is now a list of event inputs")
|
||||
|
||||
(* ;; "at this point, VARS is a list of list of old things, the extra list corresponding to the clauses of an AND, e.g. ")
|
||||
|
||||
@@ -1651,60 +1636,68 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(IF (NULL ARGS)
|
||||
THEN [SETQ EXPR (FOR X IN EXPR
|
||||
JOIN (FOR VAR IN VARS
|
||||
COLLECT (IF (CL:CONSP (CAR X))
|
||||
THEN (CONS (CONS (CAR VAR)
|
||||
(CDAR X))
|
||||
(CDR X))
|
||||
ELSE (CONS (CAR VAR)
|
||||
(CDR X]
|
||||
JOIN (FOR VAR IN VARS
|
||||
COLLECT (IF (CL:CONSP (CAR X))
|
||||
THEN (CONS (CONS (CAR VAR)
|
||||
(CDAR X))
|
||||
(CDR X))
|
||||
ELSE (CONS (CAR VAR)
|
||||
(CDR X]
|
||||
ELSE (WHILE ARGS DO (SETQ EXPR (LISPXUSE1 (POP VARS)
|
||||
(POP ARGS)
|
||||
EXPR))
|
||||
FINALLY (COND
|
||||
(VARS (ERROR '"use what??" "" T)))
|
||||
[MAPC GENLST (FUNCTION (LAMBDA (X)
|
||||
(LISPXSUBST (CAR X)
|
||||
(CDR X)
|
||||
EXPR T]
|
||||
(POP ARGS)
|
||||
EXPR)) FINALLY (COND
|
||||
(VARS (ERROR '"use what??" "" T)))
|
||||
[MAPC GENLST (FUNCTION (LAMBDA (X)
|
||||
(LISPXSUBST
|
||||
(CAR X)
|
||||
(CDR X)
|
||||
EXPR T]
|
||||
|
||||
(* ;; "samples:")
|
||||
(* ;; "samples:")
|
||||
|
||||
(* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y")
|
||||
(* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y")
|
||||
|
||||
(* ;; " Equivalent to USE A C FOR X AND B D FOR Y")
|
||||
(* ;;
|
||||
" Equivalent to USE A C FOR X AND B D FOR Y")
|
||||
|
||||
(* ;; " USE A B C FOR D AND X Y Z FOR W means 3 operations:")
|
||||
(* ;;
|
||||
" USE A B C FOR D AND X Y Z FOR W means 3 operations:")
|
||||
|
||||
(* ;; " A for D and X for W in the first")
|
||||
(* ;;
|
||||
" A for D and X for W in the first")
|
||||
|
||||
(* ;; " B for D and Y for W in the second")
|
||||
(* ;;
|
||||
" B for D and Y for W in the second")
|
||||
|
||||
(* ;; " C for D and Z for W in the third")
|
||||
(* ;;
|
||||
" C for D and Z for W in the third")
|
||||
|
||||
(* ;; "USE A B C FOR D AND X FOR Y means 3 operations:")
|
||||
(* ;;
|
||||
"USE A B C FOR D AND X FOR Y means 3 operations:")
|
||||
|
||||
(* ;; " A for D and X for Y in first")
|
||||
(* ;; " A for D and X for Y in first")
|
||||
|
||||
(* ;; " B for D and X for Y in second, etc.")
|
||||
(* ;;
|
||||
" B for D and X for Y in second, etc.")
|
||||
|
||||
(* ;; "USE A B C FOR D AND X Y FOR Z causes error")
|
||||
(* ;;
|
||||
"USE A B C FOR D AND X Y FOR Z causes error")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.")
|
||||
(* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.")
|
||||
(* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.")
|
||||
|
||||
))
|
||||
))
|
||||
(RETURN (COND
|
||||
[(CDR EXPR)
|
||||
(CONS 'DO-EVENTS (for X in EXPR collect (COND
|
||||
((CDR X)
|
||||
(CONS 'EVENT X))
|
||||
(T (CAR X]
|
||||
((CDR X)
|
||||
(CONS 'EVENT X))
|
||||
(T (CAR X]
|
||||
(T (CAR EXPR])
|
||||
|
||||
(DEFCOMMAND "PP" (&OPTIONAL (NAME LASTWORD)
|
||||
@@ -1714,25 +1707,22 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "returned from if no definitions found")
|
||||
|
||||
(for TYPE in [OR TYPES [TYPESOF NAME NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE
|
||||
'EDITDEF)
|
||||
'NILL]
|
||||
(TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL
|
||||
[FUNCTION (LAMBDA (WORD)
|
||||
(TYPESOF
|
||||
WORD NIL
|
||||
'(FIELDS FILES)
|
||||
'CURRENT]
|
||||
NIL NIL NIL 'MUSTAPPROVE)
|
||||
(PROGN (CL:FORMAT *TERMINAL-IO*
|
||||
"No definitions found for ~S."
|
||||
NAME)
|
||||
(RETURN NIL]
|
||||
NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
(TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL
|
||||
[FUNCTION (LAMBDA (WORD)
|
||||
(TYPESOF WORD NIL
|
||||
'(FIELDS FILES)
|
||||
'CURRENT]
|
||||
NIL NIL NIL 'MUSTAPPROVE)
|
||||
(PROGN (CL:FORMAT *TERMINAL-IO*
|
||||
"No definitions found for ~S." NAME)
|
||||
(RETURN NIL]
|
||||
NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME)
|
||||
(SHOWDEF NAME TYPE)))
|
||||
(SHOWDEF NAME TYPE)))
|
||||
(CL:VALUES))
|
||||
|
||||
|
||||
@@ -1740,7 +1730,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "Arrange to use the correct compiler")
|
||||
|
||||
|
||||
(PUTPROPS CMLEXEC FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLEXEC FILETYPE :FAKE-COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA DIR)
|
||||
@@ -1751,22 +1741,22 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS CMLEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3978 4383 (XCL::EXEC-CLOSEFN 3978 . 4383)) (4385 4721 (XCL::EXEC-SHRINKFN 4385 . 4721))
|
||||
(4723 4963 (XCL::SETUP-EXEC-WINDOW 4723 . 4963)) (4965 5211 (XCL::EXEC-TITLE-FUNCTION 4965 . 5211)) (
|
||||
5213 8519 (FIX-FORM 5213 . 8519)) (8521 8641 (XCL::GET-PROCESS-PROFILE 8521 . 8641)) (8643 8924 (
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE 8643 . 8924)) (8926 9216 (XCL::SETF-GET-PROCESS-PROFILE 8926 . 9216)) (
|
||||
9218 9785 (XCL:SET-EXEC-TYPE 9218 . 9785)) (9787 9869 (XCL:SET-DEFAULT-EXEC-TYPE 9787 . 9869)) (9871
|
||||
10282 (XCL::ENTER-EXEC-FUNCTION 9871 . 10282)) (10357 16750 (DO-EVENT 10357 . 16750)) (16752 23543 (
|
||||
EXEC 16752 . 23543)) (23545 24886 (EXEC-EVAL 23545 . 24886)) (24888 25619 (PRINT-ALL-DOCUMENTATION
|
||||
24888 . 25619)) (25621 26063 (PRINT-DOCUMENTATION 25621 . 26063)) (26146 27230 (ADD-EXEC 26146 . 27230
|
||||
)) (27232 30828 (EXEC-READ-LINE 27232 . 30828)) (30899 31385 (FIND-EXEC-COMMAND 30899 . 31385)) (31387
|
||||
33285 (CIRCLAR-COPYER 31387 . 33285)) (33286 34240 (COPY-CIRCLE 33296 . 34238)) (34318 37623 (
|
||||
EXEC-READ 34328 . 37489) (DIR 37491 . 37621)) (39885 67019 (DO-APPLY-EVENT 39895 . 40457) (
|
||||
DO-HISTORY-SEARCH 40459 . 41916) (EVAL-INPUT 41918 . 47347) (EVENTS-INPUT 47349 . 48727) (EXEC-PRIN1
|
||||
48729 . 48905) (EXEC-VALUE-OF 48907 . 49246) (GET-NEXT-HISTORY-EVENT 49248 . 50743) (
|
||||
HISTORY-ADD-TO-SPELLING-LISTS 50745 . 51733) (HISTORY-NTH 51735 . 52485) (PRINT-HISTORY 52487 . 53108)
|
||||
(FIND-HISTORY-EVENTS 53110 . 58171) (PRINT-EVENT 58173 . 62394) (PRINT-EVENT-PROMPT 62396 . 63600) (
|
||||
PROCESS-EXEC-ID 63602 . 64547) (SEARCH-FOR-EVENT-NUMBER 64549 . 65177) (\PICK.EVALQT 65179 . 65690) (
|
||||
LISPXREPRINT 65692 . 67017)) (68199 68298 (EXEC-PRINT 68199 . 68298)) (68300 68565 (EXEC-FORMAT 68300
|
||||
. 68565)))))
|
||||
(FILEMAP (NIL (4002 4407 (XCL::EXEC-CLOSEFN 4002 . 4407)) (4409 4745 (XCL::EXEC-SHRINKFN 4409 . 4745))
|
||||
(4747 4987 (XCL::SETUP-EXEC-WINDOW 4747 . 4987)) (4989 5235 (XCL::EXEC-TITLE-FUNCTION 4989 . 5235)) (
|
||||
5237 8404 (FIX-FORM 5237 . 8404)) (8406 8526 (XCL::GET-PROCESS-PROFILE 8406 . 8526)) (8528 8809 (
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE 8528 . 8809)) (8811 9097 (XCL::SETF-GET-PROCESS-PROFILE 8811 . 9097)) (
|
||||
9099 9666 (XCL:SET-EXEC-TYPE 9099 . 9666)) (9668 9750 (XCL:SET-DEFAULT-EXEC-TYPE 9668 . 9750)) (9752
|
||||
10159 (XCL::ENTER-EXEC-FUNCTION 9752 . 10159)) (10234 16465 (DO-EVENT 10234 . 16465)) (16467 23064 (
|
||||
EXEC 16467 . 23064)) (23066 24317 (EXEC-EVAL 23066 . 24317)) (24319 25050 (PRINT-ALL-DOCUMENTATION
|
||||
24319 . 25050)) (25052 25494 (PRINT-DOCUMENTATION 25052 . 25494)) (25577 26652 (ADD-EXEC 25577 . 26652
|
||||
)) (26654 30264 (EXEC-READ-LINE 26654 . 30264)) (30335 30821 (FIND-EXEC-COMMAND 30335 . 30821)) (30823
|
||||
32709 (CIRCLAR-COPYER 30823 . 32709)) (32710 33664 (COPY-CIRCLE 32720 . 33662)) (33742 37047 (
|
||||
EXEC-READ 33752 . 36913) (DIR 36915 . 37045)) (39301 66435 (DO-APPLY-EVENT 39311 . 39873) (
|
||||
DO-HISTORY-SEARCH 39875 . 41332) (EVAL-INPUT 41334 . 46763) (EVENTS-INPUT 46765 . 48143) (EXEC-PRIN1
|
||||
48145 . 48321) (EXEC-VALUE-OF 48323 . 48662) (GET-NEXT-HISTORY-EVENT 48664 . 50159) (
|
||||
HISTORY-ADD-TO-SPELLING-LISTS 50161 . 51149) (HISTORY-NTH 51151 . 51901) (PRINT-HISTORY 51903 . 52524)
|
||||
(FIND-HISTORY-EVENTS 52526 . 57587) (PRINT-EVENT 57589 . 61810) (PRINT-EVENT-PROMPT 61812 . 63016) (
|
||||
PROCESS-EXEC-ID 63018 . 63963) (SEARCH-FOR-EVENT-NUMBER 63965 . 64593) (\PICK.EVALQT 64595 . 65106) (
|
||||
LISPXREPRINT 65108 . 66433)) (67615 67714 (EXEC-PRINT 67615 . 67714)) (67716 67981 (EXEC-FORMAT 67716
|
||||
. 67981)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user