Compare commits
20 Commits
medley-211
...
medley-211
| Author | SHA1 | Date | |
|---|---|---|---|
|
936bdd84b5 | ||
|
c2915bf5d3 | ||
|
40c10a7841 | ||
|
|
362fac9389 | ||
|
|
db082b37e1 | ||
|
|
c0e020f033 | ||
|
|
9af86df169 | ||
|
|
6c26fe958a | ||
|
|
339bd47107 | ||
|
|
3a04303d93 | ||
|
|
68f1e7efe1 | ||
|
|
993bdb2e00 | ||
|
7a27c26f01 | ||
|
|
75a031de39 | ||
|
|
7d656006a6 | ||
|
|
1f8c123184 | ||
|
50ce484c1b | ||
|
|
e3f043b40d | ||
|
|
945df5fbe8 | ||
|
|
3d8066b7e8 |
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}}
|
||||
13
Dockerfile
13
Dockerfile
@@ -1,19 +1,24 @@
|
||||
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
|
||||
|
||||
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.
1593
library/FILEBROWSER
1593
library/FILEBROWSER
File diff suppressed because it is too large
Load Diff
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,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.
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-Oct-2021 16:33:29" {DSK}<home>larry>medley>lispusers>WHEELSCROLL.;2 11221
|
||||
(FILECREATED "29-Nov-2021 22:06:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>WHEELSCROLL.;21 11690
|
||||
|
||||
changes to%: (VARS WHEELSCROLLCOMS)
|
||||
(FNS ENABLEWHEELSCROLL WHEELSCROLL)
|
||||
changes to%: (FNS INSTALL-WHEELSCROLL)
|
||||
|
||||
previous date%: "11-Jun-2021 12:50:16" {DSK}<home>larry>medley>lispusers>WHEELSCROLL.;1)
|
||||
previous date%: "29-Nov-2021 21:58:55"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>WHEELSCROLL.;20)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT WHEELSCROLLCOMS)
|
||||
@@ -28,6 +29,7 @@
|
||||
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
|
||||
(INITVARS (WHEELSCROLLENABLED NIL)
|
||||
(WHEELSCROLLDELTA 20)
|
||||
(HWHEELSCROLLDELTA NIL)
|
||||
(WHEELSCROLLSETTLETIME 50)
|
||||
(\WHEELSCROLLINPROGRESS NIL))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL)
|
||||
@@ -161,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:")
|
||||
@@ -224,6 +230,8 @@
|
||||
|
||||
(RPAQ? WHEELSCROLLDELTA 20)
|
||||
|
||||
(RPAQ? HWHEELSCROLLDELTA NIL)
|
||||
|
||||
(RPAQ? WHEELSCROLLSETTLETIME 50)
|
||||
|
||||
(RPAQ? \WHEELSCROLLINPROGRESS NIL)
|
||||
@@ -234,6 +242,6 @@
|
||||
(ENABLEWHEELSCROLL T)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1604 10208 (ENABLEWHEELSCROLL 1614 . 5871) (WHEELSCROLL 5873 . 8474) (WHEELSCROLL.DOIT
|
||||
8476 . 9112) (INSTALL-WHEELSCROLL 9114 . 9929) (LISPINTERRUPTS.WHEELSCROLL 9931 . 10206)))))
|
||||
(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.)
|
||||
|
||||
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Nov-2021 20:53:09" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;2 12484
|
||||
(FILECREATED "29-Nov-2021 14:05:45" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;3 12592
|
||||
|
||||
changes to%: (FNS COMPAREPRINTN)
|
||||
changes to%: (FNS COMPARE1)
|
||||
|
||||
previous date%: "16-May-90 14:59:25"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;1)
|
||||
previous date%: " 5-Nov-2021 20:53:09"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -33,9 +33,10 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation.
|
||||
(COMPARE1 X Y])
|
||||
|
||||
(COMPARE1
|
||||
[LAMBDA (X Y) (* lmm "29-AUG-78 18:35")
|
||||
|
||||
(* ;; "returns T if X and Y are similar; if LOOSEMATCH then sets DIFFERENCES to changes")
|
||||
[LAMBDA (X Y) (* ; "Edited 29-Nov-2021 13:49 by rmk:")
|
||||
(* lmm "29-AUG-78 18:35")
|
||||
|
||||
(* ;; "returns T if X and Y are similar; if LOOSEMATCH then sets DIFFERENCES to changes")
|
||||
|
||||
(AND [OR (EQ X Y)
|
||||
(COND
|
||||
@@ -49,7 +50,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation.
|
||||
(PROG NIL
|
||||
LP (RETURN (COND
|
||||
((NLISTP X)
|
||||
(OR (EQUAL X Y)
|
||||
(OR (EQUALALL X Y)
|
||||
(COMPAREFAIL X Y)))
|
||||
((NLISTP Y)
|
||||
(COMPAREFAIL X Y))
|
||||
@@ -60,7 +61,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation.
|
||||
(SETQ Y (CDR Y))
|
||||
(GO LP]
|
||||
(T (COMPAREFAIL X Y]
|
||||
(T (OR (EQUAL X Y)
|
||||
(T (OR (EQUALALL X Y)
|
||||
(COMPAREFAIL X Y]
|
||||
(OR LOOSEMATCH T])
|
||||
|
||||
@@ -305,7 +306,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS COMPARE COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (847 12109 (COMPARELST 857 . 1119) (COMPARE1 1121 . 2530) (COMPAREPRINT 2532 . 3489) (
|
||||
COMPAREPRINT1 3491 . 7755) (COMPARELISTS 7757 . 9044) (COMPAREPRINTN 9046 . 9890) (COMPARENCHARS 9892
|
||||
. 10450) (COMPAREFAIL 10452 . 11579) (COMPAREMAX 11581 . 11818) (COUNTDOWN 11820 . 12107)))))
|
||||
(FILEMAP (NIL (844 12217 (COMPARELST 854 . 1116) (COMPARE1 1118 . 2638) (COMPAREPRINT 2640 . 3597) (
|
||||
COMPAREPRINT1 3599 . 7863) (COMPARELISTS 7865 . 9152) (COMPAREPRINTN 9154 . 9998) (COMPARENCHARS 10000
|
||||
. 10558) (COMPAREFAIL 10560 . 11687) (COMPAREMAX 11689 . 11926) (COUNTDOWN 11928 . 12215)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Nov-2021 13:28:18"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;2 37858
|
||||
(FILECREATED " 8-Dec-2021 18:25:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;29 47473
|
||||
|
||||
previous date%: " 7-Nov-91 18:15:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;1)
|
||||
:CHANGES-TO (FNS EDITDATE? EDITDATE)
|
||||
|
||||
:PREVIOUS-DATE " 8-Dec-2021 16:11:23"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;27)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -34,7 +36,7 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
(FUNCTIONS ED INSTALL-PROTOTYPE-DEFN)
|
||||
(FNS EDITDEF.FNS EDITF EDITFB EDITFNS EDITLOADFNS? EDITMODE EDITP EDITV DC DF DP DV EDITPROP
|
||||
EF EP EV EDITE EDITL)
|
||||
[COMS
|
||||
(COMS
|
||||
(* ;; "Time stamp on functions when edited")
|
||||
|
||||
|
||||
@@ -44,8 +46,12 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
(INITVARS (INITIALS)
|
||||
(INITIALSLST)
|
||||
(DEFAULTINITIALS T))
|
||||
(VARIABLES *REPLACE-OLD-EDIT-DATES*)
|
||||
(P (MOVD? 'EDITDATE 'TTY/EDITDATE]
|
||||
(INITVARS (*REPLACE-OLD-EDIT-DATES* NIL))
|
||||
(P (MOVD? 'EDITDATE 'TTY/EDITDATE))
|
||||
(COMS (* ; "Moved from FILEPKG")
|
||||
[VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
|
||||
(EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
|
||||
(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)))
|
||||
[INITVARS (COMMON-SOURCE-MANAGER-TYPES '(FUNCTIONS VARIABLES STRUCTURES TYPES SETFS
|
||||
OPTIMIZERS]
|
||||
(PROP FILETYPE EDITINTERFACE)
|
||||
@@ -103,7 +109,7 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
|
||||
"used in ED to stash last call info so (ED NIL) will restart last edit")
|
||||
|
||||
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
|
||||
(CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz")
|
||||
|
||||
(* ;;; "Standard Common Lisp editor entry. CLtL say's ED does something reasonable when passed a pathname. We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit that. Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.")
|
||||
|
||||
@@ -621,61 +627,235 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
OLDATE INITLS])
|
||||
|
||||
(FIXEDITDATE
|
||||
[LAMBDA (EXPR) (* NOBIND "18-JUL-78 21:11")
|
||||
(* ;
|
||||
"Inserts or replaces previous edit date")
|
||||
(AND INITIALS (LISTP EXPR)
|
||||
(FMEMB (CAR EXPR)
|
||||
LAMBDASPLST)
|
||||
(LISTP (CDR EXPR))
|
||||
(PROG ((E (CDDR EXPR)))
|
||||
RETRY
|
||||
[COND
|
||||
((NLISTP E)
|
||||
(RETURN))
|
||||
((LISTP (CAR E))
|
||||
(SELECTQ (CAAR E)
|
||||
((CLISP%: DECLARE)
|
||||
(SETQ E (CDR E))
|
||||
(GO RETRY))
|
||||
(BREAK1 (COND
|
||||
((EQ (CAR (CADAR E))
|
||||
'PROGN)
|
||||
(SETQ E (CDR (CADAR E)))
|
||||
(GO RETRY))))
|
||||
(ADV-PROG (* ;
|
||||
"No easy way to mark cleanly the date of an advised function")
|
||||
(RETURN))
|
||||
(COND
|
||||
((AND (EQ (CAAR E)
|
||||
COMMENTFLG)
|
||||
(EQ (CADAR E)
|
||||
'DECLARATIONS%:))
|
||||
[LAMBDA (EXPR)
|
||||
|
||||
(* ;; "Edited 8-Dec-2021 16:11 by rmk: Updated to add dates to the initial undated comments that begins with current-editor initials, to provide a kind of dated change-log capability.")
|
||||
(* ; "Edited 3-Dec-2021 15:03 by rmk")
|
||||
(* ; "Edited 22-Oct-2021 16:58 by rmk:")
|
||||
(* ; "Edited 27-Sep-2018 22:04 by rmk:")
|
||||
(* ; "Edited 31-Mar-2000 17:13 by rmk:")
|
||||
(* ; "Edited 17-Jul-89 11:13 by jtm:")
|
||||
(* ; "18-JUL-78 21:11")
|
||||
|
||||
(* ;; "Inserts or replaces previous edit date. This retains multiple edits (at least one day apart or by different editor) unless *REPLACE-OLD-EDIT-DATES*. Note that the new date doesn't show up within the current SEDIT session, you have to exit and re-edit to see it. ")
|
||||
|
||||
(CL:WHEN (AND INITIALS (LISTP EXPR)
|
||||
(LISTP (CDR EXPR)))
|
||||
(PROG (E)
|
||||
|
||||
(* ;; "Normalize out the colon, add it back if needed. ")
|
||||
|
||||
(COND
|
||||
((FMEMB (CAR EXPR)
|
||||
LAMBDASPLST)
|
||||
|
||||
(* ;; "insert the edit date after the argument list")
|
||||
|
||||
(SETQ E (CDDR EXPR)))
|
||||
[(FMEMB (GETPROP (CAR EXPR)
|
||||
':DEFINER-FOR)
|
||||
EDITDATE-ARGLIST-DEFINERS)
|
||||
|
||||
(* ;; "insert the edit date after the argument list")
|
||||
|
||||
(SETQ E (CDDR EXPR))
|
||||
(while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E)) finally (SETQ E (CDR E]
|
||||
((FMEMB (GETPROP (CAR EXPR)
|
||||
':DEFINER- FOR)
|
||||
EDITDATE-NAME-DEFINERS)
|
||||
|
||||
(* ;; "insert the edit date after the name")
|
||||
|
||||
(SETQ E (CDDR EXPR)))
|
||||
(T (RETURN)))
|
||||
RETRY
|
||||
[COND
|
||||
((NLISTP E)
|
||||
(RETURN))
|
||||
((LISTP (CAR E))
|
||||
(SELECTQ (CAAR E)
|
||||
((CLISP%: DECLARE)
|
||||
(SETQ E (CDR E))
|
||||
(GO RETRY]
|
||||
(COND
|
||||
((AND (LISTP (CDR E))
|
||||
(EDITDATE? (CAR E)))
|
||||
(/RPLACA E (EDITDATE (CAR E)
|
||||
INITIALS)))
|
||||
(T (/ATTACH (EDITDATE NIL INITIALS)
|
||||
E)))
|
||||
(RETURN EXPR])
|
||||
(GO RETRY))
|
||||
(BREAK1 (COND
|
||||
((EQ (CAR (CADAR E))
|
||||
'PROGN)
|
||||
(SETQ E (CDR (CADAR E)))
|
||||
(GO RETRY))))
|
||||
(ADV-PROG (* ;
|
||||
"No easy way to mark cleanly the date of an advised function")
|
||||
(RETURN))
|
||||
(COND
|
||||
((AND (EQ (CAAR E)
|
||||
COMMENTFLG)
|
||||
(EQ (CADAR E)
|
||||
'DECLARATIONS%:))
|
||||
(SETQ E (CDR E))
|
||||
(GO RETRY]
|
||||
|
||||
(* ;; "E is now the cell that the date will attach to or whose CAR will be updated.")
|
||||
|
||||
(LET (PARSE (INITLS (CL:IF (EQ (CHARCODE %:)
|
||||
(NTHCHARCODE INITIALS -1))
|
||||
(SUBSTRING INITIALS 1 -2)
|
||||
INITIALS)))
|
||||
(IF *REPLACE-OLD-EDIT-DATES*
|
||||
THEN
|
||||
(* ;; "Strip out all previous modern-format edit dates. Since EDITDATE? only recognizes that format, hand editing is needed if prehistoric dates are really not desired. We don't strip out anything with a further comment.")
|
||||
|
||||
(BIND (TAIL _ E) WHILE (AND (LISTP TAIL)
|
||||
(EDITDATE? (CAR TAIL)))
|
||||
DO (SETQ TAIL (CDR TAIL)) FINALLY (CL:UNLESS (EQ E TAIL)
|
||||
(/RPLACD E TAIL)))
|
||||
|
||||
(* ;;
|
||||
"Now (CAR E) may or may not be a (no-REST) editdate, but there are none afterwards.")
|
||||
|
||||
(IF (SETQ PARSE (EDITDATE? (CAR E)
|
||||
T))
|
||||
THEN (* ; "Smash it")
|
||||
(EDITDATE (CAR E)
|
||||
INITLS
|
||||
(CADDR PARSE))
|
||||
ELSE (/ATTACH (EDITDATE NIL INITLS)
|
||||
E))
|
||||
ELSEIF (SETQ PARSE (EDITDATE? (CAR E)
|
||||
T))
|
||||
THEN
|
||||
(* ;; "Attach the new timestamp at the beginning of E, provided the new date is either more than a day later than the previous one or by a different editor.")
|
||||
|
||||
(* ;; "If edited by the same editor within a day, then update the previous timestamp rather than just leaving the original time. Presumably this is the next event in the same longer editing session, and it avoids stacking up uninformative dates from in-and-out editing during a session. ")
|
||||
|
||||
(IF (STRING.EQUAL INITLS (CADR PARSE))
|
||||
THEN
|
||||
|
||||
(* ;; "Another edit by the same author. If not dated but contains a rest, then upgrade the rest comment with a date Otherwise,If more than a day later, add a new date. If less than a day, assume we are in essentially the same session, and update (CAR E) to the current time.")
|
||||
|
||||
[IF (NULL (CAR PARSE))
|
||||
THEN
|
||||
(* ;; "If no date but %"INITIALS: xxx%", we definitely want to upgraded to the Edited... initials: xxx format")
|
||||
|
||||
(/RPLACA E (EDITDATE (CAR E)
|
||||
INITLS
|
||||
(CADDR PARSE)))
|
||||
ELSEIF (IGREATERP (IDIFFERENCE (IDATE)
|
||||
(IDATE (CAR PARSE)))
|
||||
(TIMES 24 3600))
|
||||
THEN
|
||||
(* ;;
|
||||
"If we aren't upgrading, then we don't want to propagate the previous REST.")
|
||||
|
||||
(/ATTACH (EDITDATE NIL INITLS)
|
||||
E)
|
||||
ELSE
|
||||
(* ;;
|
||||
"Same author, within a day. Just change the date, keep the REST.")
|
||||
|
||||
(/RPLACA E (EDITDATE (CAR E)
|
||||
INITLS
|
||||
(CADDR PARSE]
|
||||
ELSE
|
||||
|
||||
(* ;; "Not a previous date, or not one with this author. Add a new one. If rmk is editing and sees an lmm: rest, we don't want to attribute that rest to rmk in the new one.")
|
||||
|
||||
(/ATTACH (EDITDATE NIL INITLS)
|
||||
E))
|
||||
ELSE
|
||||
(* ;; "Need a new date, didn't even see %"<initials: xxx%"")
|
||||
|
||||
(/ATTACH (EDITDATE NIL INITLS)
|
||||
E)))
|
||||
(RETURN EXPR)))])
|
||||
|
||||
(EDITDATE?
|
||||
(LAMBDA (COMMENT) (* ; "Edited 29-Oct-87 16:41 by drc:") (* ;;; "Tests to see if a given common is in fact an edit date -- this has to be general enough to recognize the most comment comment forms while specific enough to not recognize things that are not edit dates. We settle for the conservative form of (* initials date-string), since only truly ancient edit dates look any different from that") (DECLARE (LOCALVARS . T)) (AND *REPLACE-OLD-EDIT-DATES* (LISTP COMMENT) (EQMEMB (CAR COMMENT) COMMENTFLG) (LISTP (CDR COMMENT)) (LISTP (CDDR COMMENT)) (NULL (CDDDR COMMENT)) (STRINGP (CADDR COMMENT)) (LET ((INITIALS? (CADR COMMENT))) (AND (NOT (EQMEMB INITIALS? COMMENTFLG)) (OR (EQ INITIALS? INITIALS) (if (LITATOM INITIALS?) then (if (for I from 1 to (NCHARS INITIALS?) always (EQ (NTHCHARCODE INITIALS? I) (CHARCODE ";"))) then (* ; " an sedit comment") (AND (EQ INITIALS? (QUOTE ;)) (STRPOS "Edited " (CADDR COMMENT) 1 NIL T) (>= (CL:LENGTH (CADDR COMMENT)) (CL:LENGTH "Edited 01-jan-86 00:00 by "))) else (* ; "an old-style comment") T) elseif (STRINGP INITIALS?) then (* ; "make sure it's not a string-body comment.") (ILESSP (NCHARS INITIALS?) 12)))))))
|
||||
)
|
||||
[LAMBDA (COMMENT RESTOK) (* ; "Edited 8-Dec-2021 18:24 by rmk")
|
||||
|
||||
(* ;; "Edited 6-Dec-2021 16:04 by rmk: Return will have date/initial, initial/rest, or date/initial/rest. Always an initial and something, or NIL.")
|
||||
(* ; "Edited 4-Dec-2021 10:39 by rmk")
|
||||
|
||||
(* ;;; "This determines whether this is a dated or initialed comment that is potentially reusable in the current context. Unless RESTOK, this only recognizes modern-format configurations of the form %"Edited <date> by <initials>%", and returns a parsed pair (DATE INITIALS).")
|
||||
|
||||
(* ;;; "If RESTOK, this also parses strings with additional stuff after the INITLS (%"Edited by <initials>: xxx%") and strings that appear to begin with initials but don't have a date (<initials>: xxx). In those cases the return is a triple (DATE INITIALS REST), where DATE may be NIL. ")
|
||||
|
||||
(* ;;; "")
|
||||
|
||||
(* ;;;
|
||||
"The caller can compare against current time and current user to decide whether to smash or add.")
|
||||
|
||||
(* ;;; "There is no harm in not recognizing prehistoric formats, new dates will always be added on.")
|
||||
|
||||
(LET ((TAIL COMMENT)
|
||||
STRING BYPOS (IPOS 1)
|
||||
DATE I IENDPOS RESTPOS)
|
||||
(CL:WHEN [AND (EQ COMMENTFLG (CAR (LISTP TAIL)))
|
||||
(MEMB [CAR (LISTP (SETQ TAIL (CDR TAIL]
|
||||
'(; ;; ;;;))
|
||||
(STRINGP (SETQ STRING (CAR (SETQ TAIL (CDR TAIL]
|
||||
(SETQ STRING (CL:STRING-TRIM `(#\Space)
|
||||
STRING))
|
||||
(CL:WHEN [AND [STREQUAL "Edited " (SUBSTRING STRING 1 7 (CONSTANT (CONCAT]
|
||||
(SETQ BYPOS (STRPOS " by " STRING 8))
|
||||
(IDATE (SETQ DATE (CL:STRING-TRIM `(#\Space)
|
||||
(SUBSTRING STRING 8 (SUB1 BYPOS]
|
||||
|
||||
(* ;; "Standard format, initials should be next. ")
|
||||
|
||||
(SETQ IPOS (IPLUS BYPOS 4)))
|
||||
|
||||
(* ;; "Chomp off the next substring--initials?")
|
||||
|
||||
(CL:WHEN (IGREATERP (NCHARS STRING)
|
||||
IPOS)
|
||||
[SETQ IENDPOS (SUB1 (OR (STRPOS " " STRING IPOS)
|
||||
(ADD1 (NCHARS STRING]
|
||||
(SETQ I (SUBSTRING STRING IPOS IENDPOS))
|
||||
(CL:WHEN (ILESSP (NCHARS I)
|
||||
12) (* ;
|
||||
"Sanity check: Initials should be short.")
|
||||
(CL:WHEN (EQ (CHARCODE %:)
|
||||
(NTHCHARCODE I -1)) (* ; "Normalize out the colon")
|
||||
(SETQ I (SUBSTRING I 1 -2)))
|
||||
(CL:WHEN (SETQ REST (SUBSTRING STRING (ADD1 IENDPOS)))
|
||||
(SETQ REST (CL:STRING-TRIM `(#\Space)
|
||||
REST)))
|
||||
(IF (IGREATERP (NCHARS REST)
|
||||
0)
|
||||
THEN
|
||||
(* ;; "Could be %"<initials>: abc%" to be upgraded with a date")
|
||||
|
||||
(CL:WHEN RESTOK (LIST DATE I REST))
|
||||
ELSEIF DATE
|
||||
THEN
|
||||
(* ;; "If we saw just initials")
|
||||
|
||||
(LIST DATE I)))))])
|
||||
|
||||
(EDITDATE
|
||||
[LAMBDA (OLDATE INITLS) (* ; "Edited 20-Nov-86 23:23 by Masinter")
|
||||
(* ;;
|
||||
"Generates a new date from an old one")
|
||||
(LET [(NEWDATE (LIST '; (CONCAT "Edited " (DATE (DATEFORMAT NO.SECONDS))
|
||||
" by " INITLS]
|
||||
[LAMBDA (OLDDATE INITLS REST)
|
||||
|
||||
(* ;; "Edited 8-Dec-2021 17:58 by rmk: Upgraded to make sure that the comment includes REST")
|
||||
(* ; " 20-Nov-86 23:23 by Masinter")
|
||||
|
||||
(* ;; "Generates a new date from an old one. Packs : onto INITLS if there is a REST. In the REST case we upgrade a singe semicolon to a double.")
|
||||
|
||||
(LET ((EDITSTRING (CONCAT "Edited " (DATE (DATEFORMAT NO.SECONDS))
|
||||
" by " INITLS))
|
||||
NEWDATE OLDSEMI)
|
||||
(CL:WHEN REST
|
||||
(SETQ EDITSTRING (CONCAT EDITSTRING ": " REST)))
|
||||
(CL:WHEN OLDDATE
|
||||
(SETQ OLDSEMI (CADR OLDDATE)))
|
||||
(SETQ NEWDATE (LIST (CL:IF REST
|
||||
(OR OLDSEMI ';;)
|
||||
';)
|
||||
EDITSTRING))
|
||||
(COND
|
||||
((EQMEMB (CAR (LISTP OLDATE))
|
||||
COMMENTFLG) (* ;; "Destructively alter old date. This is for benefit of DEDIT being able to find the old form to reprint")
|
||||
(/RPLACD OLDATE NEWDATE))
|
||||
((EQMEMB (CAR (LISTP OLDDATE))
|
||||
COMMENTFLG)
|
||||
|
||||
(* ;; "Destructively alter old date. This is for benefit of DEDIT being able to find the old form to reprint")
|
||||
|
||||
(/RPLACD OLDDATE NEWDATE))
|
||||
(T (CONS (OR (CAR (LISTP COMMENTFLG))
|
||||
COMMENTFLG)
|
||||
NEWDATE])
|
||||
@@ -718,11 +898,23 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
|
||||
(RPAQ? DEFAULTINITIALS T)
|
||||
|
||||
(CL:DEFVAR *REPLACE-OLD-EDIT-DATES* T
|
||||
"NIL or T; if NIL, old edit dates will not be replaced")
|
||||
(RPAQ? *REPLACE-OLD-EDIT-DATES* NIL)
|
||||
|
||||
(MOVD? 'EDITDATE 'TTY/EDITDATE)
|
||||
|
||||
|
||||
|
||||
(* ; "Moved from FILEPKG")
|
||||
|
||||
|
||||
(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))
|
||||
|
||||
(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
|
||||
)
|
||||
|
||||
(RPAQ? COMMON-SOURCE-MANAGER-TYPES '(FUNCTIONS VARIABLES STRUCTURES TYPES SETFS OPTIMIZERS))
|
||||
|
||||
(PUTPROPS EDITINTERFACE FILETYPE CL:COMPILE-FILE)
|
||||
@@ -736,11 +928,11 @@ Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3710 10009 (ED 3710 . 10009)) (10011 13987 (INSTALL-PROTOTYPE-DEFN 10011 . 13987)) (
|
||||
13988 30771 (EDITDEF.FNS 13998 . 15334) (EDITF 15336 . 16216) (EDITFB 16218 . 17066) (EDITFNS 17068 .
|
||||
18388) (EDITLOADFNS? 18390 . 22190) (EDITMODE 22192 . 24202) (EDITP 24204 . 24715) (EDITV 24717 .
|
||||
25356) (DC 25358 . 26039) (DF 26041 . 27083) (DP 27085 . 28169) (DV 28171 . 28743) (EDITPROP 28745 .
|
||||
28964) (EF 28966 . 29295) (EP 29297 . 29480) (EV 29482 . 29661) (EDITE 29663 . 30541) (EDITL 30543 .
|
||||
30769)) (31121 37193 (NEW/EDITDATE 31131 . 31353) (FIXEDITDATE 31355 . 33197) (EDITDATE? 33199 . 34377
|
||||
) (EDITDATE 34379 . 35196) (SETINITIALS 35198 . 37191)))))
|
||||
(FILEMAP (NIL (4086 10381 (ED 4086 . 10381)) (10383 14359 (INSTALL-PROTOTYPE-DEFN 10383 . 14359)) (
|
||||
14360 31143 (EDITDEF.FNS 14370 . 15706) (EDITF 15708 . 16588) (EDITFB 16590 . 17438) (EDITFNS 17440 .
|
||||
18760) (EDITLOADFNS? 18762 . 22562) (EDITMODE 22564 . 24574) (EDITP 24576 . 25087) (EDITV 25089 .
|
||||
25728) (DC 25730 . 26411) (DF 26413 . 27455) (DP 27457 . 28541) (DV 28543 . 29115) (EDITPROP 29117 .
|
||||
29336) (EF 29338 . 29667) (EP 29669 . 29852) (EV 29854 . 30033) (EDITE 30035 . 30913) (EDITL 30915 .
|
||||
31141)) (31493 46618 (NEW/EDITDATE 31503 . 31725) (FIXEDITDATE 31727 . 39874) (EDITDATE? 39876 . 43363
|
||||
) (EDITDATE 43365 . 44621) (SETINITIALS 44623 . 46616)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
225
sources/FILEPKG
225
sources/FILEPKG
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Nov-2021 10:52:49" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;15 284792
|
||||
(FILECREATED " 2-Dec-2021 23:35:54" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;17 278911
|
||||
|
||||
changes to%: (FNS COMPAREDEFS)
|
||||
changes to%: (VARS FILEPKGCOMS)
|
||||
|
||||
previous date%: "30-Oct-2021 20:03:07"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;14)
|
||||
previous date%: " 1-Dec-2021 17:05:26"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;16)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -116,13 +116,6 @@ with the terms of said license.
|
||||
GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF
|
||||
DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
|
||||
(INITVARS (WHEREIS.HASH)))
|
||||
(* ; "Must come after PUTDEF")
|
||||
(FNS FIXEDITDATE EDITDATE?)
|
||||
(* ;
|
||||
"Edit date support for all kinds of definers (from PARC 6/10/92)")
|
||||
[VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
|
||||
(EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
|
||||
(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
|
||||
(COMS
|
||||
(* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")
|
||||
|
||||
@@ -4094,132 +4087,6 @@ compiling " T)
|
||||
|
||||
|
||||
|
||||
(* ; "Must come after PUTDEF")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(FIXEDITDATE
|
||||
[LAMBDA (EXPR) (* ; "Edited 17-Jul-89 11:13 by jtm:")
|
||||
(* NOBIND "18-JUL-78 21:11")
|
||||
(* Inserts or replaces previous edit
|
||||
date)
|
||||
(AND INITIALS (LISTP EXPR)
|
||||
(LISTP (CDR EXPR))
|
||||
(PROG (E)
|
||||
(COND
|
||||
((FMEMB (CAR EXPR)
|
||||
LAMBDASPLST)
|
||||
|
||||
(* ;; "insert the edit date after the argument list")
|
||||
|
||||
(SETQ E (CDDR EXPR)))
|
||||
[(FMEMB (GETPROP (CAR EXPR)
|
||||
':DEFINER-FOR)
|
||||
EDITDATE-ARGLIST-DEFINERS)
|
||||
|
||||
(* ;; "insert the edit date after the argument list")
|
||||
|
||||
(SETQ E (CDDR EXPR))
|
||||
(while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
|
||||
finally (SETQ E (CDR E]
|
||||
((FMEMB (GETPROP (CAR EXPR)
|
||||
':DEFINER-FOR)
|
||||
EDITDATE-NAME-DEFINERS)
|
||||
|
||||
(* ;; "insert the edit date after the name")
|
||||
|
||||
(SETQ E (CDDR EXPR)))
|
||||
(T (RETURN)))
|
||||
RETRY
|
||||
[COND
|
||||
((NLISTP E)
|
||||
(RETURN))
|
||||
((LISTP (CAR E))
|
||||
(SELECTQ (CAAR E)
|
||||
((CLISP%: DECLARE)
|
||||
(SETQ E (CDR E))
|
||||
(GO RETRY))
|
||||
(BREAK1 (COND
|
||||
((EQ (CAR (CADAR E))
|
||||
'PROGN)
|
||||
(SETQ E (CDR (CADAR E)))
|
||||
(GO RETRY))))
|
||||
(ADV-PROG (* No easy way to mark cleanly the
|
||||
date of an advised function)
|
||||
(RETURN))
|
||||
(COND
|
||||
((AND (EQ (CAAR E)
|
||||
COMMENTFLG)
|
||||
(EQ (CADAR E)
|
||||
'DECLARATIONS%:))
|
||||
(SETQ E (CDR E))
|
||||
(GO RETRY]
|
||||
(COND
|
||||
([for TAIL on E while (AND (LISTP (CAR TAIL))
|
||||
(EQ (CAAR TAIL)
|
||||
COMMENTFLG))
|
||||
do (COND
|
||||
((AND (LISTP (CDR TAIL))
|
||||
(EDITDATE? (CAR TAIL)))
|
||||
(/RPLACA TAIL (EDITDATE (CAR TAIL)
|
||||
INITIALS))
|
||||
(RETURN T] (* scans the comments for a
|
||||
timestamp for this user.)
|
||||
NIL)
|
||||
(T (* attach the new timestamp at the
|
||||
beginning of the comments.)
|
||||
(/ATTACH (EDITDATE NIL INITIALS)
|
||||
E)))
|
||||
(RETURN EXPR])
|
||||
|
||||
(EDITDATE?
|
||||
[LAMBDA (COMMENT) (* ; "Edited 11-Jun-92 16:44 by cat")
|
||||
(* ; "Edited 13-Jul-89 09:30 by jtm:")
|
||||
(* lmm "21-Mar-85 08:45")
|
||||
|
||||
(* Tests to see if a given common is in fact an edit date --
|
||||
this has to be general enough to recognize the most comment comment forms while
|
||||
specific enough to not recognize things that are not edit dates)
|
||||
|
||||
(DECLARE (LOCALVARS . T)) (* jtm%: changed test so that it
|
||||
creates one timestamp per user.)
|
||||
(COND
|
||||
[(LISTP COMMENT)
|
||||
(COND
|
||||
((EQ (CAR COMMENT)
|
||||
COMMENTFLG)
|
||||
[COND
|
||||
(NIL (NULL NORMALCOMMENTSFLG)
|
||||
(SETQ COMMENT (GETCOMMENT COMMENT]
|
||||
(COND
|
||||
([OR (NOT (LISTP (CDR COMMENT)))
|
||||
(NOT (LISTP (CDDR COMMENT]
|
||||
NIL)
|
||||
[(EQ (CADR COMMENT)
|
||||
';) (* ; "CL style comment")
|
||||
(STRPOS INITIALS (CADDR COMMENT)
|
||||
(IMINUS (NCHARS INITIALS]
|
||||
(T (* ; "IL style comment")
|
||||
(EQ (CADR COMMENT)
|
||||
INITIALS]
|
||||
((STRINGP COMMENT])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")
|
||||
|
||||
|
||||
(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))
|
||||
|
||||
(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
|
||||
)
|
||||
@@ -5041,46 +4908,46 @@ compiling " T)
|
||||
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1992 1993 1995 2018 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (19760 21465 (SEARCHPRETTYTYPELST 19770 . 20749) (PRETTYDEFMACROS 20751 . 21209) (
|
||||
FILEPKGCOMPROPS 21211 . 21463)) (22267 57085 (CLEANUP 22277 . 23665) (COMPILEFILES 23667 . 23943) (
|
||||
COMPILEFILES0 23945 . 24665) (CONTINUEDIT 24667 . 26087) (MAKEFILE 26089 . 38426) (FILECHANGES 38428
|
||||
. 40763) (FILEPKG.MERGECHANGES 40765 . 41588) (FILEPKG.CHANGEDFNS 41590 . 41902) (MAKEFILE1 41904 .
|
||||
46131) (COMPILE-FILE? 46133 . 47690) (MAKEFILES 47692 . 49385) (ADDFILE 49387 . 51908) (ADDFILE0 51910
|
||||
. 56046) (LISTFILES 56048 . 57083)) (57757 92997 (FILEPKGCHANGES 57767 . 59117) (GETFILEPKGTYPE 59119
|
||||
. 62192) (MARKASCHANGED 62194 . 63831) (FILECOMS 63833 . 64217) (WHEREIS 64219 . 65639) (
|
||||
SMASHFILECOMS 65641 . 65876) (FILEFNSLST 65878 . 66040) (FILECOMSLST 66042 . 66526) (UPDATEFILES 66528
|
||||
. 71828) (INFILECOMS? 71830 . 73733) (INFILECOMTAIL 73735 . 74875) (INFILECOMS 74877 . 75038) (
|
||||
INFILECOM 75040 . 85249) (INFILECOMSVALS 85251 . 85578) (INFILECOMSVAL 85580 . 86582) (INFILECOMSPROP
|
||||
86584 . 87413) (IFCPROPS 87415 . 88676) (IFCEXPRTYPE 88678 . 89189) (IFCPROPSCAN 89191 . 90244) (
|
||||
IFCDECLARE 90246 . 91557) (INFILEPAIRS 91559 . 91891) (INFILECOMSMACRO 91893 . 92995)) (93032 124452 (
|
||||
FILES? 93042 . 95235) (FILES?1 95237 . 95935) (FILES?PRINTLST 95937 . 96719) (ADDTOFILES? 96721 .
|
||||
107767) (ADDTOFILE 107769 . 108685) (WHATIS 108687 . 110663) (ADDTOCOMS 110665 . 112309) (ADDTOCOM
|
||||
112311 . 118858) (ADDTOCOM1 118860 . 120031) (ADDNEWCOM 120033 . 121083) (MAKENEWCOM 121085 . 122928)
|
||||
(DEFAULTMAKENEWCOM 122930 . 124450)) (124522 127339 (MERGEINSERT 124532 . 126875) (MERGEINSERT1 126877
|
||||
. 127337)) (127493 128850 (ADDTOFILEKEYLST 127503 . 128848)) (128967 139879 (DELFROMFILES 128977 .
|
||||
129827) (DELFROMCOMS 129829 . 131508) (DELFROMCOM 131510 . 137378) (DELFROMCOM1 137380 . 138177) (
|
||||
REMOVEITEM 138179 . 139053) (MOVETOFILE 139055 . 139877)) (140093 142462 (SAVEPUT 140103 . 142460)) (
|
||||
142587 150911 (UNMARKASCHANGED 142597 . 144305) (PREEDITFN 144307 . 146818) (POSTEDITPROPS 146820 .
|
||||
149321) (POSTEDITALISTS 149323 . 150909)) (151056 171610 (ALISTS.GETDEF 151066 . 151445) (
|
||||
ALISTS.WHENCHANGED 151447 . 152091) (CLEARCLISPARRAY 152093 . 153267) (EXPRESSIONS.WHENCHANGED 153269
|
||||
. 153643) (MAKEALISTCOMS 153645 . 154718) (MAKEFILESCOMS 154720 . 156157) (MAKELISPXMACROSCOMS 156159
|
||||
. 158177) (MAKEPROPSCOMS 158179 . 158877) (MAKEUSERMACROSCOMS 158879 . 160679) (PROPS.WHENCHANGED
|
||||
160681 . 161302) (FILEGETDEF.LISPXMACROS 161304 . 162746) (FILEGETDEF.ALISTS 162748 . 163367) (
|
||||
FILEGETDEF.RECORDS 163369 . 164300) (FILEGETDEF.PROPS 164302 . 165094) (FILEGETDEF.MACROS 165096 .
|
||||
166156) (FILEGETDEF.VARS 166158 . 166574) (FILEGETDEF.FNS 166576 . 167940) (FILEPKGCOMS.PUTDEF 167942
|
||||
. 170382) (FILES.PUTDEF 170384 . 171341) (VARS.PUTDEF 171343 . 171486) (FILES.WHENCHANGED 171488 .
|
||||
171608)) (173632 181065 (RENAME 173642 . 175043) (CHANGECALLERS 175045 . 181063)) (181066 229922 (
|
||||
SHOWDEF 181076 . 182269) (COPYDEF 182271 . 184745) (GETDEF 184747 . 187023) (GETDEFCOM 187025 . 187991
|
||||
) (GETDEFCOM0 187993 . 189339) (GETDEFCURRENT 189341 . 195761) (GETDEFERR 195763 . 197064) (
|
||||
GETDEFFROMFILE 197066 . 201346) (GETDEFSAVED 201348 . 202452) (PUTDEF 202454 . 203157) (EDITDEF 203159
|
||||
. 204136) (DEFAULT.EDITDEF 204138 . 206974) (EDITDEF.FILES 206976 . 207177) (LOADDEF 207179 . 207355)
|
||||
(DWIMDEF 207357 . 208211) (DELDEF 208213 . 211227) (DELFROMLIST 211229 . 211733) (HASDEF 211735 .
|
||||
218057) (GETFILEDEF 218059 . 218581) (SAVEDEF 218583 . 220242) (UNSAVEDEF 220244 . 221140) (
|
||||
COMPAREDEFS 221142 . 224952) (COMPARE 224954 . 225658) (TYPESOF 225660 . 229920)) (229989 235032 (
|
||||
FIXEDITDATE 229999 . 233502) (EDITDATE? 233504 . 235030)) (235451 244222 (FILEPKGCOM 235461 . 240394)
|
||||
(FILEPKGTYPE 240396 . 244220)) (256255 271187 (FINDCALLERS 256265 . 256780) (EDITCALLERS 256782 .
|
||||
264692) (EDITFROMFILE 264694 . 270502) (FINDATS 270504 . 270776) (LOOKIN 270778 . 271185)) (271188
|
||||
272915 (SEPRCASE 271198 . 272913)) (273432 278989 (IMPORTFILE 273442 . 274416) (IMPORTEVAL 274418 .
|
||||
275298) (IMPORTFILESCAN 275300 . 275721) (CHECKIMPORTS 275723 . 277059) (GATHEREXPORTS 277061 . 278399
|
||||
) (\DUMPEXPORTS 278401 . 278987)) (279327 281535 (CLEARFILEPKG 279337 . 281533)))))
|
||||
(FILEMAP (NIL (19258 20963 (SEARCHPRETTYTYPELST 19268 . 20247) (PRETTYDEFMACROS 20249 . 20707) (
|
||||
FILEPKGCOMPROPS 20709 . 20961)) (21765 56583 (CLEANUP 21775 . 23163) (COMPILEFILES 23165 . 23441) (
|
||||
COMPILEFILES0 23443 . 24163) (CONTINUEDIT 24165 . 25585) (MAKEFILE 25587 . 37924) (FILECHANGES 37926
|
||||
. 40261) (FILEPKG.MERGECHANGES 40263 . 41086) (FILEPKG.CHANGEDFNS 41088 . 41400) (MAKEFILE1 41402 .
|
||||
45629) (COMPILE-FILE? 45631 . 47188) (MAKEFILES 47190 . 48883) (ADDFILE 48885 . 51406) (ADDFILE0 51408
|
||||
. 55544) (LISTFILES 55546 . 56581)) (57255 92495 (FILEPKGCHANGES 57265 . 58615) (GETFILEPKGTYPE 58617
|
||||
. 61690) (MARKASCHANGED 61692 . 63329) (FILECOMS 63331 . 63715) (WHEREIS 63717 . 65137) (
|
||||
SMASHFILECOMS 65139 . 65374) (FILEFNSLST 65376 . 65538) (FILECOMSLST 65540 . 66024) (UPDATEFILES 66026
|
||||
. 71326) (INFILECOMS? 71328 . 73231) (INFILECOMTAIL 73233 . 74373) (INFILECOMS 74375 . 74536) (
|
||||
INFILECOM 74538 . 84747) (INFILECOMSVALS 84749 . 85076) (INFILECOMSVAL 85078 . 86080) (INFILECOMSPROP
|
||||
86082 . 86911) (IFCPROPS 86913 . 88174) (IFCEXPRTYPE 88176 . 88687) (IFCPROPSCAN 88689 . 89742) (
|
||||
IFCDECLARE 89744 . 91055) (INFILEPAIRS 91057 . 91389) (INFILECOMSMACRO 91391 . 92493)) (92530 123950 (
|
||||
FILES? 92540 . 94733) (FILES?1 94735 . 95433) (FILES?PRINTLST 95435 . 96217) (ADDTOFILES? 96219 .
|
||||
107265) (ADDTOFILE 107267 . 108183) (WHATIS 108185 . 110161) (ADDTOCOMS 110163 . 111807) (ADDTOCOM
|
||||
111809 . 118356) (ADDTOCOM1 118358 . 119529) (ADDNEWCOM 119531 . 120581) (MAKENEWCOM 120583 . 122426)
|
||||
(DEFAULTMAKENEWCOM 122428 . 123948)) (124020 126837 (MERGEINSERT 124030 . 126373) (MERGEINSERT1 126375
|
||||
. 126835)) (126991 128348 (ADDTOFILEKEYLST 127001 . 128346)) (128465 139377 (DELFROMFILES 128475 .
|
||||
129325) (DELFROMCOMS 129327 . 131006) (DELFROMCOM 131008 . 136876) (DELFROMCOM1 136878 . 137675) (
|
||||
REMOVEITEM 137677 . 138551) (MOVETOFILE 138553 . 139375)) (139591 141960 (SAVEPUT 139601 . 141958)) (
|
||||
142085 150409 (UNMARKASCHANGED 142095 . 143803) (PREEDITFN 143805 . 146316) (POSTEDITPROPS 146318 .
|
||||
148819) (POSTEDITALISTS 148821 . 150407)) (150554 171108 (ALISTS.GETDEF 150564 . 150943) (
|
||||
ALISTS.WHENCHANGED 150945 . 151589) (CLEARCLISPARRAY 151591 . 152765) (EXPRESSIONS.WHENCHANGED 152767
|
||||
. 153141) (MAKEALISTCOMS 153143 . 154216) (MAKEFILESCOMS 154218 . 155655) (MAKELISPXMACROSCOMS 155657
|
||||
. 157675) (MAKEPROPSCOMS 157677 . 158375) (MAKEUSERMACROSCOMS 158377 . 160177) (PROPS.WHENCHANGED
|
||||
160179 . 160800) (FILEGETDEF.LISPXMACROS 160802 . 162244) (FILEGETDEF.ALISTS 162246 . 162865) (
|
||||
FILEGETDEF.RECORDS 162867 . 163798) (FILEGETDEF.PROPS 163800 . 164592) (FILEGETDEF.MACROS 164594 .
|
||||
165654) (FILEGETDEF.VARS 165656 . 166072) (FILEGETDEF.FNS 166074 . 167438) (FILEPKGCOMS.PUTDEF 167440
|
||||
. 169880) (FILES.PUTDEF 169882 . 170839) (VARS.PUTDEF 170841 . 170984) (FILES.WHENCHANGED 170986 .
|
||||
171106)) (173130 180563 (RENAME 173140 . 174541) (CHANGECALLERS 174543 . 180561)) (180564 229420 (
|
||||
SHOWDEF 180574 . 181767) (COPYDEF 181769 . 184243) (GETDEF 184245 . 186521) (GETDEFCOM 186523 . 187489
|
||||
) (GETDEFCOM0 187491 . 188837) (GETDEFCURRENT 188839 . 195259) (GETDEFERR 195261 . 196562) (
|
||||
GETDEFFROMFILE 196564 . 200844) (GETDEFSAVED 200846 . 201950) (PUTDEF 201952 . 202655) (EDITDEF 202657
|
||||
. 203634) (DEFAULT.EDITDEF 203636 . 206472) (EDITDEF.FILES 206474 . 206675) (LOADDEF 206677 . 206853)
|
||||
(DWIMDEF 206855 . 207709) (DELDEF 207711 . 210725) (DELFROMLIST 210727 . 211231) (HASDEF 211233 .
|
||||
217555) (GETFILEDEF 217557 . 218079) (SAVEDEF 218081 . 219740) (UNSAVEDEF 219742 . 220638) (
|
||||
COMPAREDEFS 220640 . 224450) (COMPARE 224452 . 225156) (TYPESOF 225158 . 229418)) (229570 238341 (
|
||||
FILEPKGCOM 229580 . 234513) (FILEPKGTYPE 234515 . 238339)) (250374 265306 (FINDCALLERS 250384 . 250899
|
||||
) (EDITCALLERS 250901 . 258811) (EDITFROMFILE 258813 . 264621) (FINDATS 264623 . 264895) (LOOKIN
|
||||
264897 . 265304)) (265307 267034 (SEPRCASE 265317 . 267032)) (267551 273108 (IMPORTFILE 267561 .
|
||||
268535) (IMPORTEVAL 268537 . 269417) (IMPORTFILESCAN 269419 . 269840) (CHECKIMPORTS 269842 . 271178) (
|
||||
GATHEREXPORTS 271180 . 272518) (\DUMPEXPORTS 272520 . 273106)) (273446 275654 (CLEARFILEPKG 273456 .
|
||||
275652)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,26 +1,26 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "24-Aug-2021 08:30:09" {DSK}<home>larry>medley>sources>MEDLEYDIR.;10 6764
|
||||
|
||||
changes to%: (VARS MEDLEYDIRCOMS MEDLEY-INIT-VARS)
|
||||
(FNS MEDLEYDIR)
|
||||
(FILECREATED " 2-Dec-2021 20:43:35" {DSK}<home>larry>medley>sources>MEDLEYDIR.;14 6103
|
||||
|
||||
previous date%: "24-Aug-2021 07:57:05" {DSK}<home>larry>medley>sources>MEDLEYDIR.;5)
|
||||
changes to%: (FNS MEDLEYDIR)
|
||||
|
||||
previous date%: " 2-Dec-2021 20:32:45" {DSK}<home>larry>medley>sources>MEDLEYDIR.;12)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEYDIRCOMS)
|
||||
|
||||
(RPAQQ MEDLEYDIRCOMS [
|
||||
(* ;; "set up initialization for file paths relative to where Medley is installed. This assumes that the environment variable MEDLEYDIR is set (usually by the ./run-medley script) to the (unix path) and all of the other directories variables are set relative to that (by MEDLEY-INIT-VARS)")
|
||||
(RPAQQ MEDLEYDIRCOMS
|
||||
[
|
||||
(* ;; "set up initialization for file paths relative to where Medley is installed. This assumes that the environment variable MEDLEYDIR is set (usually by the ./run-medley script) to the (unix path) and all of the other directories variables are set relative to that (by MEDLEY-INIT-VARS)")
|
||||
|
||||
(FNS MEDLEY-INIT-VARS MEDLEYDIR)
|
||||
(INITVARS (MEDLEYDIR))
|
||||
(ADDVARS (BEFORESYSOUTFORMS (SETQ MEDLEYDIR))
|
||||
(BEFOREMAKESYSFORMS (SETQ MEDLEYDIR))
|
||||
(AFTERSYSOUTFORMS (MEDLEY-INIT-VARS))
|
||||
(AFTERMAKESYSFORMS (MEDLEY-INIT-VARS)))
|
||||
(VARS MEDLEY-INIT-VARS)
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY (ADDVARS (GLOBALVARS MEDLEYDIR
|
||||
MEDLEY-INIT-VARS])
|
||||
(FNS MEDLEY-INIT-VARS MEDLEYDIR)
|
||||
(INITVARS (MEDLEYDIR))
|
||||
(ADDVARS (BEFORESYSOUTFORMS (SETQ MEDLEYDIR))
|
||||
(BEFOREMAKESYSFORMS (SETQ MEDLEYDIR))
|
||||
(AFTERSYSOUTFORMS (MEDLEY-INIT-VARS))
|
||||
(AFTERMAKESYSFORMS (MEDLEY-INIT-VARS)))
|
||||
(VARS MEDLEY-INIT-VARS)
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY (ADDVARS (GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS])
|
||||
|
||||
|
||||
|
||||
@@ -31,7 +31,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEY-INIT-VARS
|
||||
[LAMBDA (CLEAR) (* ; "Edited 21-Aug-2021 18:23 by larry")
|
||||
[LAMBDA (CLEAR) (* ;
|
||||
"Edited 21-Aug-2021 18:23 by larry")
|
||||
|
||||
(* ;; "MEDLEY-INIT-VARS has variables that might need to get reset. ")
|
||||
|
||||
@@ -61,7 +62,8 @@
|
||||
NIL])
|
||||
|
||||
(MEDLEYDIR
|
||||
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 14-Dec-2020 17:12 by larry")
|
||||
[LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ;
|
||||
"Edited 2-Dec-2021 20:23 by kaplan")
|
||||
(DECLARE (GLOBALVARS MEDLEYDIR))
|
||||
(if (NULL DIRNAME)
|
||||
then (if (OR (NOT (BOUNDP 'MEDLEYDIR))
|
||||
@@ -83,10 +85,10 @@
|
||||
else (OR NOERROR (INFILEP FILENAME)
|
||||
(ERROR "No such medley file" FILENAME)))
|
||||
else (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
|
||||
DIRNAME))
|
||||
(IF NOERROR
|
||||
THEN NIL
|
||||
ELSE (ERROR "No such medley directory" DIRNAME])
|
||||
DIRNAME ">"))
|
||||
(if NOERROR
|
||||
then NIL
|
||||
else (ERROR "No such medley directory" DIRNAME])
|
||||
)
|
||||
|
||||
(RPAQ? MEDLEYDIR )
|
||||
@@ -99,31 +101,30 @@
|
||||
|
||||
(ADDTOVAR AFTERMAKESYSFORMS (MEDLEY-INIT-VARS))
|
||||
|
||||
(RPAQQ MEDLEY-INIT-VARS ([LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers"
|
||||
"internal/library" "greetfiles"
|
||||
"docs/documentation tools"]
|
||||
[LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources"]
|
||||
(LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
|
||||
(IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
|
||||
(IRM.DINFOGRAPH)
|
||||
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
|
||||
[LOGINHOST/DIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
|
||||
(UNIX-GETENV "HOME"]
|
||||
[USERGREETFILES `((,LOGINHOST/DIR "INIT" COM)
|
||||
(,LOGINHOST/DIR "INIT"]
|
||||
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/displayfonts"
|
||||
"fonts/altofonts" "fonts/big"
|
||||
"fonts/other")
|
||||
NIL NIL T))
|
||||
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")
|
||||
NIL NIL T))
|
||||
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
|
||||
NIL NIL T))
|
||||
(XCL::*WHERE-IS-CASH-FILES*)))
|
||||
(RPAQQ MEDLEY-INIT-VARS
|
||||
([LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers" "internal/library" "greetfiles"
|
||||
"docs/documentation tools"]
|
||||
[LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources"]
|
||||
(LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
|
||||
(IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
|
||||
(IRM.DINFOGRAPH)
|
||||
(DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
|
||||
[LOGINHOST/DIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
|
||||
(UNIX-GETENV "HOME"]
|
||||
[USERGREETFILES `((,LOGINHOST/DIR "INIT" COM)
|
||||
(,LOGINHOST/DIR "INIT"]
|
||||
(DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/displayfonts" "fonts/altofonts" "fonts/big"
|
||||
"fonts/other")
|
||||
NIL NIL T))
|
||||
(POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")
|
||||
NIL NIL T))
|
||||
(INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")
|
||||
NIL NIL T))
|
||||
(XCL::*WHERE-IS-CASH-FILES*)))
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY
|
||||
|
||||
(ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1665 4710 (MEDLEY-INIT-VARS 1675 . 3223) (MEDLEYDIR 3225 . 4708)))))
|
||||
(FILEMAP (NIL (1380 4562 (MEDLEY-INIT-VARS 1390 . 3004) (MEDLEYDIR 3006 . 4560)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "11-Sep-2021 09:14:19" {DSK}<home>larry>medley>sources>PRETTY.;5 65019
|
||||
|
||||
changes to%: (VARS PRETTYCOMS)
|
||||
(FNS PRINTCOPYRIGHT)
|
||||
(FILECREATED "30-Nov-2021 22:18:04" {DSK}<home>larry>medley>sources>PRETTY.;2 65400
|
||||
|
||||
previous date%: " 9-Jul-2021 14:12:19" {DSK}<home>larry>medley>sources>PRETTY.;1)
|
||||
:CHANGES-TO (FNS PRINTDATE1)
|
||||
|
||||
:PREVIOUS-DATE "11-Sep-2021 09:14:19" {DSK}<home>larry>medley>sources>PRETTY.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -326,10 +326,37 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
)
|
||||
|
||||
(PRINTDATE1
|
||||
(LAMBDA (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING) (* bvm%: "18-Sep-86 19:08") (* ;;; "does the printing for PRINTDATE") (printout OUTSTREAM .FONT DEFAULTFONT "(" |.P2| (QUOTE FILECREATED) %, |.P2| DAT %, .FONT LAMBDAFONT |.P2| (FULLNAME OUTSTREAM) .FONT DEFAULTFONT) (* ;; "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL") (if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM))) then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM))) (PRIN3 " " OUTSTREAM) (* ;; "The address of where the map begins will be stored in this slot. 8 spaces left because when radix is 8, can overflow seven spaces by a file of 300000 characters (Alice did it). The push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")) (if FILEPKGFLG then (if CHANGES then (printout OUTSTREAM T T 6 |.P2| (QUOTE changes) %, |.P2| (QUOTE to%:) %,, .PPVTL CHANGES)) (if PREVDATE then (printout OUTSTREAM T T 6 |.P2| (QUOTE previous) %, |.P2| (QUOTE date%:) %, |.P2| PREVDATE) (if PREVERS then (printout OUTSTREAM %, |.P2| PREVERS)))) (PRIN1 (OR TERMINATING.STRING ")
|
||||
[LAMBDA (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING)
|
||||
(* ;
|
||||
"Edited 30-Nov-2021 21:31 by larry")
|
||||
(* bvm%: "18-Sep-86 19:08")
|
||||
|
||||
(* ;;; "does the printing for PRINTDATE")
|
||||
|
||||
(printout OUTSTREAM .FONT DEFAULTFONT "(" .P2 'FILECREATED %, .P2 DAT %, .FONT LAMBDAFONT .P2
|
||||
(FULLNAME OUTSTREAM)
|
||||
.FONT DEFAULTFONT)
|
||||
|
||||
(* ;; "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL")
|
||||
|
||||
(if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM)))
|
||||
then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM)))
|
||||
(PRIN3 " " OUTSTREAM)
|
||||
|
||||
(* ;; "The address of where the map begins will be stored in this slot. 8 spaces left because when radix is 8, can overflow seven spaces by a file of 300000 characters (Alice did it). The push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")
|
||||
)
|
||||
[if FILEPKGFLG
|
||||
then (if CHANGES
|
||||
then (printout OUTSTREAM T T 6 .P2 :CHANGES-TO %, .PPVTL CHANGES))
|
||||
(if PREVDATE
|
||||
then (printout OUTSTREAM T T 6 .P2 :PREVIOUS-DATE %, .P2 PREVDATE)
|
||||
(if PREVERS
|
||||
then (printout OUTSTREAM %, .P2 PREVERS]
|
||||
(PRIN1 (OR TERMINATING.STRING ")
|
||||
|
||||
|
||||
") OUTSTREAM)))
|
||||
")
|
||||
OUTSTREAM])
|
||||
|
||||
(PRINTFNS
|
||||
(LAMBDA (X PRETTYDEFLG) (* lmm "13-OCT-82 16:44") (* ; "prettydeflg=T when called from prettydef.") (AND X (PROG (FNADRLST) (COND ((AND PRETTYDEFLG NEWFILEMAP) (SETQ FNADRLST (TCONC NIL (GETFILEPTR PRTTYFILE))) (TCONC FNADRLST NIL) (NCONC1 NEWFILEMAP (CAR FNADRLST)))) (PRIN1 (QUOTE %()) (PRINT (QUOTE DEFINEQ)) (PRETTYPRINT X (AND PRETTYDEFLG (OR FNADRLST T)) FNSLST) (* ; "FNSLST bound in prettydef to list of functions on this file. used for font stuff.") (PRIN1 (QUOTE %))) (AND FNADRLST (RPLACA (CDAR FNADRLST) (GETFILEPTR PRTTYFILE))) (TERPRI))))
|
||||
@@ -695,14 +722,14 @@ must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NL
|
||||
(PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018
|
||||
))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5925 48076 (PRETTYDEF 5935 . 21608) (PRETTYDEFCOMS 21610 . 22292) (PRETTYDEF0 22294 .
|
||||
22485) (PRETTYDEF1 22487 . 24250) (PRINTDATE 24252 . 25488) (PRINTDATE1 25490 . 26695) (PRINTFNS 26697
|
||||
. 27266) (PRETTYCOM 27268 . 33609) (PRETTYVAR 33611 . 34649) (PRETTYVAR1 34651 . 36869) (PRETTYCOM1
|
||||
36871 . 37575) (ENDFILE 37577 . 37673) (MAKEDEFLIST 37675 . 38079) (PP 38081 . 38357) (PP* 38359 .
|
||||
38672) (PPT 38674 . 38993) (PRETTYPRINT 38995 . 42147) (PRETTYPRINT1 42149 . 44035) (PRETTYPRINT2
|
||||
44037 . 45353) (PRETTYPRINT3 45355 . 46310) (PRINTDEF1 46312 . 47320) (SUPERPRINTEQ 47322 . 47416) (
|
||||
SUPERPRINTGETPROP 47418 . 47562) (CHANGEFONT 47564 . 48074)) (48077 53423 (READARRAY 48087 . 49013) (
|
||||
PRINTARRAY 49015 . 50755) (READARRAY-FROM-LIST 50757 . 51862) (PRINTARRAY-TO-LIST 51864 . 53421)) (
|
||||
53550 61068 (PRINTCOPYRIGHT 53560 . 57637) (PRINTCOPYRIGHT1 57639 . 60763) (SAVECOPYRIGHT 60765 .
|
||||
61066)))))
|
||||
(FILEMAP (NIL (5881 48457 (PRETTYDEF 5891 . 21564) (PRETTYDEFCOMS 21566 . 22248) (PRETTYDEF0 22250 .
|
||||
22441) (PRETTYDEF1 22443 . 24206) (PRINTDATE 24208 . 25444) (PRINTDATE1 25446 . 27076) (PRINTFNS 27078
|
||||
. 27647) (PRETTYCOM 27649 . 33990) (PRETTYVAR 33992 . 35030) (PRETTYVAR1 35032 . 37250) (PRETTYCOM1
|
||||
37252 . 37956) (ENDFILE 37958 . 38054) (MAKEDEFLIST 38056 . 38460) (PP 38462 . 38738) (PP* 38740 .
|
||||
39053) (PPT 39055 . 39374) (PRETTYPRINT 39376 . 42528) (PRETTYPRINT1 42530 . 44416) (PRETTYPRINT2
|
||||
44418 . 45734) (PRETTYPRINT3 45736 . 46691) (PRINTDEF1 46693 . 47701) (SUPERPRINTEQ 47703 . 47797) (
|
||||
SUPERPRINTGETPROP 47799 . 47943) (CHANGEFONT 47945 . 48455)) (48458 53804 (READARRAY 48468 . 49394) (
|
||||
PRINTARRAY 49396 . 51136) (READARRAY-FROM-LIST 51138 . 52243) (PRINTARRAY-TO-LIST 52245 . 53802)) (
|
||||
53931 61449 (PRINTCOPYRIGHT 53941 . 58018) (PRINTCOPYRIGHT1 58020 . 61144) (SAVECOPYRIGHT 61146 .
|
||||
61447)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "17-Oct-2021 18:00:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;29 13073
|
||||
(FILECREATED " 2-Dec-2021 13:28:13" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>PRINTFN.;31 13158
|
||||
|
||||
changes to%: (VARS PRINTFNCOMS)
|
||||
(FNS PRINTFN)
|
||||
changes to%: (FNS PFCOPYBYTES)
|
||||
|
||||
previous date%: " 8-Oct-2021 00:20:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PRINTFN.;28)
|
||||
previous date%: "17-Oct-2021 18:00:43"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>PRINTFN.;29)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -152,9 +150,12 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(T FULL])
|
||||
|
||||
(PFCOPYBYTES
|
||||
[LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 8-Oct-2021 00:17 by rmk:")
|
||||
(* ; "Edited 24-Mar-93 14:16 by rmk:")
|
||||
(* lmm "28-Sep-86 14:38")
|
||||
[LAMBDA (SRCFIL DSTFIL START END NOTERPRI) (* ; "Edited 2-Dec-2021 13:27 by rmk:")
|
||||
(* ; "Edited 8-Oct-2021 00:17 by rmk:")
|
||||
(* ; "Edited 24-Mar-93 14:16 by rmk:")
|
||||
|
||||
(* ;; "RMK: Added NOTERPRI to at least give caller control over whether a TERPRI is done just in the case of copying the whole file. ")
|
||||
(* lmm "28-Sep-86 14:38")
|
||||
|
||||
(* ;; "RMK: What does FLG do? It isn't referenced. It seems to be passed as the value of PFDEFAULT from PRINTFNDEF, and that variable is initialized to NIL. I'm removing it.")
|
||||
|
||||
@@ -167,8 +168,8 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PROG ((SSTRM (\INSTREAMARG SRCFIL))
|
||||
(DSTRM (\OUTSTREAMARG DSTFIL))
|
||||
FONTARRAY CHARCODE %#CHARS MAXFONT)
|
||||
(DECLARE (SPECVARS . T)) (* ;
|
||||
"In particular, #CHARS must be a specvar for \INCCODE")
|
||||
(DECLARE (SPECVARS . T)) (* ;
|
||||
"In particular, #CHARS must be a specvar for \INCCODE")
|
||||
(COND
|
||||
((IMAGESTREAMP DSTRM)
|
||||
(SETQ FONTARRAY (FONTMAPARRAY))
|
||||
@@ -190,7 +191,7 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
START))
|
||||
(START)
|
||||
(T (* ;
|
||||
"Copy everything from here to the end-of-file")
|
||||
"Copy everything from here to the end-of-file")
|
||||
(SETQ START (GETFILEPTR SSTRM))
|
||||
(IDIFFERENCE (GETEOFPTR SSTRM)
|
||||
(GETFILEPTR SSTRM]
|
||||
@@ -200,21 +201,21 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
LP (COND
|
||||
((ILEQ %#CHARS 0)
|
||||
(CL:WHEN (AND (EQ START 0)
|
||||
(EOFP SSTRM)) (* ; "We copied the whole file")
|
||||
(TERPRI DSTRM))
|
||||
(EOFP SSTRM)) (* ;
|
||||
"RMK: We copied the whole file, why should we do a TERPRI")
|
||||
(OR NOTERPRI (TERPRI DSTRM)))
|
||||
(RETURN T)))
|
||||
(SETQ CHARCODE (\INCCODE.EOLC SSTRM ANY.EOLC '%#CHARS %#CHARS))
|
||||
(IF (EQ CHARCODE (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
|
||||
THEN
|
||||
(* ;;
|
||||
"No EOL check on font character, otherwise we would be limited to 9 fonts")
|
||||
|
||||
(* ;;
|
||||
"No EOL check on font character, otherwise we would be limited to 9 fonts")
|
||||
|
||||
(SETQ CHARCODE (\INCCODE SSTRM '%#CHARS %#CHARS))
|
||||
(CL:WHEN (AND (IGEQ MAXFONT CHARCODE)
|
||||
(NEQ CHARCODE 0))
|
||||
(DSPFONT (ELT FONTARRAY CHARCODE)
|
||||
DSTRM))
|
||||
(SETQ CHARCODE (\INCCODE SSTRM '%#CHARS %#CHARS))
|
||||
(CL:WHEN (AND (IGEQ MAXFONT CHARCODE)
|
||||
(NEQ CHARCODE 0))
|
||||
(DSPFONT (ELT FONTARRAY CHARCODE)
|
||||
DSTRM))
|
||||
ELSE (\OUTCHAR DSTRM CHARCODE))
|
||||
(GO LP)))])
|
||||
|
||||
@@ -230,37 +231,36 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PFPRINCHAR MACRO ((CC)
|
||||
(COND
|
||||
(EOLFLG (TERPRI DSTRM)
|
||||
(SETQ EOLFLG NIL)
|
||||
(SETQ HPOS LMAR)))
|
||||
(COND
|
||||
((NOT (ZEROP %#SPACES))
|
||||
(FRPTQ (COND
|
||||
((OR FLG STRFLG)
|
||||
%#SPACES)
|
||||
(T (FOLDHI %#SPACES 2)))
|
||||
(PFOUTCHAR (CHARCODE SPACE)))
|
||||
(SETQ %#SPACES 0)))
|
||||
(PFOUTCHAR CC)))
|
||||
(COND
|
||||
(EOLFLG (TERPRI DSTRM)
|
||||
(SETQ EOLFLG NIL)
|
||||
(SETQ HPOS LMAR)))
|
||||
(COND
|
||||
((NOT (ZEROP %#SPACES))
|
||||
(FRPTQ (COND
|
||||
((OR FLG STRFLG)
|
||||
%#SPACES)
|
||||
(T (FOLDHI %#SPACES 2)))
|
||||
(PFOUTCHAR (CHARCODE SPACE)))
|
||||
(SETQ %#SPACES 0)))
|
||||
(PFOUTCHAR CC)))
|
||||
|
||||
(PUTPROPS PFOUTCHAR MACRO ((CC)
|
||||
([LAMBDA (WIDTH)
|
||||
(COND
|
||||
((AND WIDTH (IGREATERP (add HPOS WIDTH)
|
||||
RMAR))
|
||||
(* past RIGHT margin, force eol)
|
||||
(TERPRI DSTRM)
|
||||
(SETQ HPOS WIDTH)))
|
||||
(\OUTCHAR DSTRM CC]
|
||||
(\STREAMCHARWIDTH CC DSTRM \PRIMTERMTABLE))))
|
||||
([LAMBDA (WIDTH)
|
||||
(COND
|
||||
((AND WIDTH (IGREATERP (add HPOS WIDTH)
|
||||
RMAR)) (* past RIGHT margin, force eol)
|
||||
(TERPRI DSTRM)
|
||||
(SETQ HPOS WIDTH)))
|
||||
(\OUTCHAR DSTRM CC]
|
||||
(\STREAMCHARWIDTH CC DSTRM \PRIMTERMTABLE))))
|
||||
)
|
||||
)
|
||||
|
||||
(MOVD? 'COPYBYTES 'PFCOPYBYTES)
|
||||
|
||||
(ADDTOVAR EDITMACROS [PF NIL (ORR [(E (APPLY* 'PF (FIRSTATOM (%##]
|
||||
((E 'PF?])
|
||||
((E 'PF?])
|
||||
|
||||
(ADDTOVAR EDITCOMSA PF)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -277,6 +277,6 @@ Copyright (c) 1986-1987, 1990, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS PRINTFN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1999 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1145 10976 (PF 1155 . 3850) (PF* 3852 . 4146) (PRINTFN 4148 . 4718) (PRINTFNDEF 4720 .
|
||||
5903) (FINDFNDEF 5905 . 6929) (PFCOPYBYTES 6931 . 10726) (DISPLAYP 10728 . 10974)))))
|
||||
(FILEMAP (NIL (1107 11292 (PF 1117 . 3812) (PF* 3814 . 4108) (PRINTFN 4110 . 4680) (PRINTFNDEF 4682 .
|
||||
5865) (FINDFNDEF 5867 . 6891) (PFCOPYBYTES 6893 . 11042) (DISPLAYP 11044 . 11290)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,15 +1,17 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "SEDIT" ( USE "LISP" "XCL")))
|
||||
(IL:FILECREATED "19-Jan-93 11:17:23" IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;3| 16340
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "SEDIT" ( USE "LISP" "XCL")) READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|previous| IL:|date:| " 5-Jan-93 02:16:37"
|
||||
IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
(IL:FILECREATED " 2-Dec-2021 23:29:30"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-ACCESS.;2| 16200
|
||||
|
||||
IL:|previous| IL:|date:| "19-Jan-93 11:17:23"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-ACCESS.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988, 1990, 1993 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:SEDIT-ACCESSCOMS)
|
||||
|
||||
(IL:RPAQQ IL:SEDIT-ACCESSCOMS
|
||||
(IL:RPAQQ IL:SEDIT-ACCESSCOMS
|
||||
((IL:PROP IL:FILETYPE IL:SEDIT-ACCESS)
|
||||
(IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-ACCESS)
|
||||
(IL:LOCALVARS . T)
|
||||
@@ -21,11 +23,10 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM
|
||||
WEAK-LINK)))
|
||||
|
||||
(IL:PUTPROPS IL:SEDIT-ACCESS IL:FILETYPE :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:SEDIT-ACCESS IL:FILETYPE :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:SEDIT-ACCESS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE "SEDIT" (:USE "LISP"
|
||||
"XCL"))))
|
||||
(IL:PUTPROPS IL:SEDIT-ACCESS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE "SEDIT" (:USE "LISP" "XCL"))))
|
||||
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
|
||||
(IL:LOCALVARS . T)
|
||||
@@ -48,7 +49,7 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
IL:FULLXPOINTER IL:WORD IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER
|
||||
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
|
||||
IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER
|
||||
IL:POINTER IL:POINTER IL:POINTER)
|
||||
IL:POINTER IL:POINTER IL:POINTER IL:POINTER)
|
||||
'((EDIT-CONTEXT 0 IL:POINTER)
|
||||
(EDIT-CONTEXT 2 IL:POINTER)
|
||||
(EDIT-CONTEXT 4 IL:POINTER)
|
||||
@@ -108,8 +109,9 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
(EDIT-CONTEXT 110 IL:POINTER)
|
||||
(EDIT-CONTEXT 112 IL:POINTER)
|
||||
(EDIT-CONTEXT 114 IL:POINTER)
|
||||
(EDIT-CONTEXT 116 IL:POINTER))
|
||||
'118)
|
||||
(EDIT-CONTEXT 116 IL:POINTER)
|
||||
(EDIT-CONTEXT 118 IL:POINTER))
|
||||
'120)
|
||||
|
||||
(IL:/DECLAREDATATYPE 'EDIT-ENV
|
||||
'(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
|
||||
@@ -295,7 +297,7 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
LAST-MOUSE-X LAST-MOUSE-Y LAST-MOUSE-TYPE \\X \\Y \\Z \\T FIRST-BLOCK
|
||||
CURRENT-BLOCK MATCHING? BELOW? VISIBLE? (REPAINT-START IL:FULLXPOINTER)
|
||||
(REPAINT-LINE IL:FULLXPOINTER)
|
||||
REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT))
|
||||
REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT PROPS))
|
||||
|
||||
(IL:DATATYPE EDIT-ENV
|
||||
(PARSE-INFO PARSE-INFO-UNKNOWN USER-DATA DEFAULT-FONT ITALIC-FONT KEYWORD-FONT
|
||||
@@ -305,17 +307,17 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
DEFAULT-CHAR-HANDLER HELP-MENU))
|
||||
|
||||
(IL:DATATYPE EDIT-NODE ((NODE-TYPE IL:FULLXPOINTER)
|
||||
FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER)
|
||||
(DEPTH IL:WORD)
|
||||
(SUB-NODE-INDEX IL:WORD)
|
||||
STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER)
|
||||
LINEAR-FORM
|
||||
(START-X IL:WORD)
|
||||
(RIGHT-MARGIN IL:WORD)
|
||||
(PREFERRED-WIDTH IL:WORD)
|
||||
(ACTUAL-WIDTH IL:WORD)
|
||||
(CHANGED? IL:FLAG)
|
||||
INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE))
|
||||
FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER)
|
||||
(DEPTH IL:WORD)
|
||||
(SUB-NODE-INDEX IL:WORD)
|
||||
STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER)
|
||||
LINEAR-FORM
|
||||
(START-X IL:WORD)
|
||||
(RIGHT-MARGIN IL:WORD)
|
||||
(PREFERRED-WIDTH IL:WORD)
|
||||
(ACTUAL-WIDTH IL:WORD)
|
||||
(CHANGED? IL:FLAG)
|
||||
INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE))
|
||||
|
||||
(IL:DATATYPE EDIT-NODE-TYPE
|
||||
(NAME ASSIGN-FORMAT COMPUTE-FORMAT-VALUES LINEARIZE SUB-NODE-CHANGED SET-POINT
|
||||
@@ -324,43 +326,43 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-ACCESS.;2|)
|
||||
CLOSE-NODE))
|
||||
|
||||
(IL:DATATYPE EDIT-POINT ((POINT-NODE IL:FULLXPOINTER)
|
||||
POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER)
|
||||
POINT-STRING POINT-OFFSET))
|
||||
POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER)
|
||||
POINT-STRING POINT-OFFSET))
|
||||
|
||||
(IL:DATATYPE EDIT-SELECTION ((SELECT-NODE IL:FULLXPOINTER)
|
||||
SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE?
|
||||
SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER)
|
||||
SELECT-END-X
|
||||
(SELECT-END-LINE IL:FULLXPOINTER)
|
||||
SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET))
|
||||
SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE?
|
||||
SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER)
|
||||
SELECT-END-X
|
||||
(SELECT-END-LINE IL:FULLXPOINTER)
|
||||
SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET))
|
||||
|
||||
(IL:DATATYPE GAP (LINEAR-ITEM))
|
||||
|
||||
(IL:DATATYPE LINE-BLOCK ((BLOCK-START IL:FULLXPOINTER)
|
||||
BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE
|
||||
BLOCK-ASCENT BLOCK-DESCENT))
|
||||
BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE
|
||||
BLOCK-ASCENT BLOCK-DESCENT))
|
||||
|
||||
(IL:DATATYPE LINE-START ((NEXT-LINE IL:FULLXPOINTER)
|
||||
(PREV-LINE IL:FULLXPOINTER)
|
||||
(NODE IL:FULLXPOINTER)
|
||||
(LINE-ASCENT IL:WORD)
|
||||
(LINE-DESCENT IL:WORD)
|
||||
(LINE-SKIP IL:WORD)
|
||||
(LINE-LENGTH IL:WORD)
|
||||
(INDENT IL:WORD)
|
||||
YCOORD
|
||||
(CACHE-TIME IL:WORD)
|
||||
CACHED-Y
|
||||
(CACHED-ASCENT IL:WORD)
|
||||
(CACHED-DESCENT IL:WORD)))
|
||||
(PREV-LINE IL:FULLXPOINTER)
|
||||
(NODE IL:FULLXPOINTER)
|
||||
(LINE-ASCENT IL:WORD)
|
||||
(LINE-DESCENT IL:WORD)
|
||||
(LINE-SKIP IL:WORD)
|
||||
(LINE-LENGTH IL:WORD)
|
||||
(INDENT IL:WORD)
|
||||
YCOORD
|
||||
(CACHE-TIME IL:WORD)
|
||||
CACHED-Y
|
||||
(CACHED-ASCENT IL:WORD)
|
||||
(CACHED-DESCENT IL:WORD)))
|
||||
|
||||
(IL:DATATYPE LIST-FORMAT (LIST-FORMATS LIST-INLINE? LIST-PFORMAT LIST-MFORMAT LIST-SUBLISTS))
|
||||
|
||||
(IL:RECORD OPEN-STRING (REAL-LENGTH SUBSTRING . BUFFER-STRING))
|
||||
|
||||
(IL:DATATYPE STRING-ITEM (STRING (WIDTH IL:WORD)
|
||||
(FONT IL:FULLXPOINTER)
|
||||
(PRIN-2? IL:FLAG)))
|
||||
(FONT IL:FULLXPOINTER)
|
||||
(PRIN-2? IL:FLAG)))
|
||||
|
||||
(IL:DATATYPE WEAK-LINK ((DESTINATION IL:FULLXPOINTER)))
|
||||
)
|
||||
|
||||
Binary file not shown.
@@ -1,19 +1,19 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT ( USE LISP XCL)))
|
||||
(IL:FILECREATED "19-Jan-93 11:18:34" IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;3| 50314
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE SEDIT ( USE LISP XCL)) READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:RECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE
|
||||
EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT
|
||||
OPEN-STRING STRING-ITEM WEAK-LINK)
|
||||
(IL:FILECREATED " 1-Dec-2021 20:02:36"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-DECLS.;2| 48072
|
||||
|
||||
IL:|previous| IL:|date:| " 5-Jan-93 02:19:37"
|
||||
IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
IL:|changes| IL:|to:| (IL:RECORDS EDIT-CONTEXT)
|
||||
|
||||
IL:|previous| IL:|date:| "19-Jan-93 11:18:34"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-DECLS.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988, 1990, 1993 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:SEDIT-DECLSCOMS)
|
||||
|
||||
(IL:RPAQQ IL:SEDIT-DECLSCOMS
|
||||
(IL:RPAQQ IL:SEDIT-DECLSCOMS
|
||||
((IL:PROP IL:FILETYPE IL:SEDIT-DECLS)
|
||||
(IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-DECLS)
|
||||
|
||||
@@ -79,11 +79,11 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
(IL:P (IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T)
|
||||
(IL:|printout| T T "SEDIT-ACCESS must be REMADE NEW if you change a record" T))))
|
||||
|
||||
(IL:PUTPROPS IL:SEDIT-DECLS IL:FILETYPE :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:SEDIT-DECLS IL:FILETYPE :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:SEDIT-DECLS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE IL:SEDIT (:USE IL:LISP
|
||||
IL:XCL))))
|
||||
(IL:PUTPROPS IL:SEDIT-DECLS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)
|
||||
)))
|
||||
|
||||
|
||||
|
||||
@@ -113,7 +113,7 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
LAST-MOUSE-X LAST-MOUSE-Y LAST-MOUSE-TYPE \\X \\Y \\Z \\T FIRST-BLOCK
|
||||
CURRENT-BLOCK MATCHING? BELOW? VISIBLE? (REPAINT-START IL:FULLXPOINTER)
|
||||
(REPAINT-LINE IL:FULLXPOINTER)
|
||||
REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT)
|
||||
REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT PROPS)
|
||||
CHANGED-NODES IL:_ (CONS))
|
||||
|
||||
(IL:DATATYPE EDIT-ENV
|
||||
@@ -124,22 +124,20 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
DEFAULT-CHAR-HANDLER HELP-MENU))
|
||||
|
||||
(IL:DATATYPE EDIT-NODE ((NODE-TYPE IL:FULLXPOINTER)
|
||||
FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER)
|
||||
(DEPTH IL:WORD)
|
||||
(SUB-NODE-INDEX IL:WORD)
|
||||
STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER)
|
||||
LINEAR-FORM
|
||||
(START-X IL:WORD)
|
||||
(RIGHT-MARGIN IL:WORD)
|
||||
(PREFERRED-WIDTH IL:WORD)
|
||||
(ACTUAL-WIDTH IL:WORD)
|
||||
(CHANGED? IL:FLAG)
|
||||
INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE)
|
||||
(IL:ACCESSFNS (INLINE? (EQ (IL:|fetch| FIRST-LINE IL:|of| IL:DATUM
|
||||
)
|
||||
(IL:|fetch| LAST-LINE IL:|of| IL:DATUM)
|
||||
)))
|
||||
FORMAT IL:_ 'NOT-YET-ASSIGNED)
|
||||
FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER)
|
||||
(DEPTH IL:WORD)
|
||||
(SUB-NODE-INDEX IL:WORD)
|
||||
STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER)
|
||||
LINEAR-FORM
|
||||
(START-X IL:WORD)
|
||||
(RIGHT-MARGIN IL:WORD)
|
||||
(PREFERRED-WIDTH IL:WORD)
|
||||
(ACTUAL-WIDTH IL:WORD)
|
||||
(CHANGED? IL:FLAG)
|
||||
INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE)
|
||||
(IL:ACCESSFNS (INLINE? (EQ (IL:|fetch| FIRST-LINE IL:|of| IL:DATUM)
|
||||
(IL:|fetch| LAST-LINE IL:|of| IL:DATUM))))
|
||||
FORMAT IL:_ 'NOT-YET-ASSIGNED)
|
||||
|
||||
(IL:DATATYPE EDIT-NODE-TYPE
|
||||
(NAME ASSIGN-FORMAT COMPUTE-FORMAT-VALUES LINEARIZE SUB-NODE-CHANGED SET-POINT
|
||||
@@ -148,89 +146,80 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
CLOSE-NODE))
|
||||
|
||||
(IL:DATATYPE EDIT-POINT ((POINT-NODE IL:FULLXPOINTER)
|
||||
POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER)
|
||||
POINT-STRING POINT-OFFSET))
|
||||
POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER)
|
||||
POINT-STRING POINT-OFFSET))
|
||||
|
||||
(IL:DATATYPE EDIT-SELECTION ((SELECT-NODE IL:FULLXPOINTER)
|
||||
SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE?
|
||||
SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER)
|
||||
SELECT-END-X
|
||||
(SELECT-END-LINE IL:FULLXPOINTER)
|
||||
SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET))
|
||||
SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE?
|
||||
SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER)
|
||||
SELECT-END-X
|
||||
(SELECT-END-LINE IL:FULLXPOINTER)
|
||||
SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET))
|
||||
|
||||
(IL:DATATYPE GAP (LINEAR-ITEM))
|
||||
|
||||
(IL:DATATYPE LINE-BLOCK ((BLOCK-START IL:FULLXPOINTER)
|
||||
BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE
|
||||
BLOCK-ASCENT BLOCK-DESCENT))
|
||||
BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE
|
||||
BLOCK-ASCENT BLOCK-DESCENT))
|
||||
|
||||
(IL:DATATYPE LINE-START ((NEXT-LINE IL:FULLXPOINTER)
|
||||
(PREV-LINE IL:FULLXPOINTER)
|
||||
(NODE IL:FULLXPOINTER)
|
||||
(LINE-ASCENT IL:WORD)
|
||||
(LINE-DESCENT IL:WORD)
|
||||
(LINE-SKIP IL:WORD)
|
||||
(LINE-LENGTH IL:WORD)
|
||||
(INDENT IL:WORD)
|
||||
YCOORD
|
||||
(CACHE-TIME IL:WORD)
|
||||
CACHED-Y
|
||||
(CACHED-ASCENT IL:WORD)
|
||||
(CACHED-DESCENT IL:WORD))
|
||||
(IL:ACCESSFNS (LINE-HEIGHT (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF
|
||||
IL:DATUM)
|
||||
(IL:FETCH LINE-ASCENT IL:OF
|
||||
IL:DATUM)
|
||||
(IL:FETCH LINE-DESCENT IL:OF
|
||||
IL:DATUM))))
|
||||
(IL:ACCESSFNS (BASE-LINE-Y (IL:IDIFFERENCE (IL:ADD1 (IL:FETCH YCOORD
|
||||
IL:OF IL:DATUM
|
||||
))
|
||||
(IL:IPLUS (IL:FETCH LINE-SKIP
|
||||
IL:OF IL:DATUM)
|
||||
(IL:FETCH LINE-ASCENT
|
||||
IL:OF IL:DATUM)))))
|
||||
(IL:ACCESSFNS (NEXT-LINE-Y (IL:IDIFFERENCE (IL:FETCH YCOORD
|
||||
IL:OF IL:DATUM)
|
||||
(IL:FETCH LINE-HEIGHT IL:OF
|
||||
IL:DATUM))))
|
||||
(IL:ACCESSFNS (OLD-TOP (IF (EQ (IL:FETCH CACHE-TIME IL:OF
|
||||
IL:DATUM)
|
||||
(IL:|fetch| RELINEARIZATION-TIME-STAMP
|
||||
IL:|of| CONTEXT))
|
||||
(IL:SUB1 (IL:IPLUS (IL:FETCH CACHED-Y
|
||||
IL:OF IL:DATUM)
|
||||
(IL:FETCH CACHED-ASCENT
|
||||
IL:OF IL:DATUM)))
|
||||
(IL:FETCH YCOORD IL:OF IL:DATUM))))
|
||||
(IL:ACCESSFNS (OLD-BOTTOM (IF (EQ (IL:FETCH CACHE-TIME IL:OF
|
||||
IL:DATUM)
|
||||
(IL:|fetch|
|
||||
RELINEARIZATION-TIME-STAMP
|
||||
IL:|of| CONTEXT))
|
||||
(IL:IDIFFERENCE (IL:FETCH CACHED-Y
|
||||
IL:OF IL:DATUM)
|
||||
(IL:FETCH CACHED-DESCENT
|
||||
IL:OF IL:DATUM))
|
||||
(IL:ADD1 (IL:FETCH NEXT-LINE-Y
|
||||
IL:OF IL:DATUM))))))
|
||||
(PREV-LINE IL:FULLXPOINTER)
|
||||
(NODE IL:FULLXPOINTER)
|
||||
(LINE-ASCENT IL:WORD)
|
||||
(LINE-DESCENT IL:WORD)
|
||||
(LINE-SKIP IL:WORD)
|
||||
(LINE-LENGTH IL:WORD)
|
||||
(INDENT IL:WORD)
|
||||
YCOORD
|
||||
(CACHE-TIME IL:WORD)
|
||||
CACHED-Y
|
||||
(CACHED-ASCENT IL:WORD)
|
||||
(CACHED-DESCENT IL:WORD))
|
||||
(IL:ACCESSFNS (LINE-HEIGHT (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM)
|
||||
(IL:FETCH LINE-ASCENT IL:OF IL:DATUM)
|
||||
(IL:FETCH LINE-DESCENT IL:OF IL:DATUM))))
|
||||
(IL:ACCESSFNS (BASE-LINE-Y (IL:IDIFFERENCE (IL:ADD1 (IL:FETCH YCOORD
|
||||
IL:OF IL:DATUM))
|
||||
(IL:IPLUS (IL:FETCH LINE-SKIP IL:OF
|
||||
IL:DATUM
|
||||
)
|
||||
(IL:FETCH LINE-ASCENT IL:OF IL:DATUM
|
||||
)))))
|
||||
(IL:ACCESSFNS (NEXT-LINE-Y (IL:IDIFFERENCE (IL:FETCH YCOORD IL:OF IL:DATUM)
|
||||
(IL:FETCH LINE-HEIGHT IL:OF IL:DATUM))))
|
||||
(IL:ACCESSFNS (OLD-TOP (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM)
|
||||
(IL:|fetch| RELINEARIZATION-TIME-STAMP
|
||||
IL:|of| CONTEXT))
|
||||
(IL:SUB1 (IL:IPLUS (IL:FETCH CACHED-Y IL:OF
|
||||
IL:DATUM
|
||||
)
|
||||
(IL:FETCH CACHED-ASCENT
|
||||
IL:OF IL:DATUM)))
|
||||
(IL:FETCH YCOORD IL:OF IL:DATUM))))
|
||||
(IL:ACCESSFNS (OLD-BOTTOM (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM)
|
||||
(IL:|fetch| RELINEARIZATION-TIME-STAMP
|
||||
IL:|of| CONTEXT))
|
||||
(IL:IDIFFERENCE (IL:FETCH CACHED-Y IL:OF
|
||||
IL:DATUM
|
||||
)
|
||||
(IL:FETCH CACHED-DESCENT IL:OF IL:DATUM)
|
||||
)
|
||||
(IL:ADD1 (IL:FETCH NEXT-LINE-Y IL:OF IL:DATUM)))
|
||||
)))
|
||||
|
||||
(IL:DATATYPE LIST-FORMAT (LIST-FORMATS LIST-INLINE? LIST-PFORMAT LIST-MFORMAT LIST-SUBLISTS)
|
||||
(IL:ACCESSFNS (NON-STANDARD? (NULL (IL:|fetch| LIST-FORMATS
|
||||
IL:|of| IL:DATUM))))
|
||||
(IL:ACCESSFNS (SET-FORMAT-LIST (IL:|fetch| LIST-INLINE? IL:|of|
|
||||
IL:DATUM)))
|
||||
(IL:ACCESSFNS (CFVLIST (IL:|fetch| LIST-PFORMAT IL:|of| IL:DATUM
|
||||
)))
|
||||
(IL:ACCESSFNS (LINEARIZE-LIST (IL:|fetch| LIST-MFORMAT IL:|of|
|
||||
IL:DATUM)))
|
||||
LIST-SUBLISTS IL:_ NIL)
|
||||
(IL:ACCESSFNS (NON-STANDARD? (NULL (IL:|fetch| LIST-FORMATS IL:|of| IL:DATUM
|
||||
))))
|
||||
(IL:ACCESSFNS (SET-FORMAT-LIST (IL:|fetch| LIST-INLINE? IL:|of| IL:DATUM)))
|
||||
(IL:ACCESSFNS (CFVLIST (IL:|fetch| LIST-PFORMAT IL:|of| IL:DATUM)))
|
||||
(IL:ACCESSFNS (LINEARIZE-LIST (IL:|fetch| LIST-MFORMAT IL:|of| IL:DATUM)))
|
||||
LIST-SUBLISTS IL:_ NIL)
|
||||
|
||||
(IL:RECORD OPEN-STRING (REAL-LENGTH SUBSTRING . BUFFER-STRING))
|
||||
|
||||
(IL:DATATYPE STRING-ITEM (STRING (WIDTH IL:WORD)
|
||||
(FONT IL:FULLXPOINTER)
|
||||
(PRIN-2? IL:FLAG)))
|
||||
(FONT IL:FULLXPOINTER)
|
||||
(PRIN-2? IL:FLAG)))
|
||||
|
||||
(IL:DATATYPE WEAK-LINK ((DESTINATION IL:FULLXPOINTER)))
|
||||
)
|
||||
@@ -248,7 +237,7 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
IL:FULLXPOINTER IL:WORD IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER
|
||||
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
|
||||
IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER
|
||||
IL:POINTER IL:POINTER IL:POINTER)
|
||||
IL:POINTER IL:POINTER IL:POINTER IL:POINTER)
|
||||
'((EDIT-CONTEXT 0 IL:POINTER)
|
||||
(EDIT-CONTEXT 2 IL:POINTER)
|
||||
(EDIT-CONTEXT 4 IL:POINTER)
|
||||
@@ -308,8 +297,9 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
(EDIT-CONTEXT 110 IL:POINTER)
|
||||
(EDIT-CONTEXT 112 IL:POINTER)
|
||||
(EDIT-CONTEXT 114 IL:POINTER)
|
||||
(EDIT-CONTEXT 116 IL:POINTER))
|
||||
'118)
|
||||
(EDIT-CONTEXT 116 IL:POINTER)
|
||||
(EDIT-CONTEXT 118 IL:POINTER))
|
||||
'120)
|
||||
|
||||
(IL:/DECLAREDATATYPE 'EDIT-ENV
|
||||
'(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
|
||||
@@ -529,8 +519,8 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
|
||||
(IL:RPAQQ IL:MICASPERPT 35.27778)
|
||||
|
||||
(IL:RPAQQ QUOTE-WRAPPER-LIST (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@
|
||||
COMMA-DOT IL:\\\,. FUNCTION FUNCTION))
|
||||
(IL:RPAQQ QUOTE-WRAPPER-LIST (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@
|
||||
COMMA-DOT IL:\\\,. FUNCTION FUNCTION))
|
||||
|
||||
|
||||
(IL:CONSTANTS (EDITOR-NAME "SEdit")
|
||||
@@ -545,11 +535,11 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE
|
||||
|
||||
(IL:PUTPROPS GET-PROMPT-WINDOW IL:MACRO ((CONTEXT)
|
||||
(IL:GETPROMPTWINDOW (IL:|fetch| DISPLAY-WINDOW
|
||||
IL:|of| CONTEXT))))
|
||||
(IL:PUTPROPS GET-PROMPT-WINDOW IL:MACRO ((CONTEXT)
|
||||
(IL:GETPROMPTWINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of|
|
||||
CONTEXT))))
|
||||
|
||||
(IL:PUTPROPS EVAL-IN-PROCESS IL:MACRO (NIL (LET* ((PROCESS (IF (EQ (IL:PROCESSPROP (IL:THIS.PROCESS)
|
||||
(IL:PUTPROPS EVAL-IN-PROCESS IL:MACRO (NIL (LET* ((PROCESS (IF (EQ (IL:PROCESSPROP (IL:THIS.PROCESS)
|
||||
'IL:NAME)
|
||||
'IL:MOUSE)
|
||||
(IL:TTY.PROCESS)
|
||||
@@ -562,10 +552,10 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
IL:|of| (CADADR PROCFORM)))
|
||||
(T PROCESS)))))
|
||||
|
||||
(IL:PUTPROPS LOOKUP-COMMAND IL:MACRO ((CHAR TABLE)
|
||||
(IL:PUTPROPS LOOKUP-COMMAND IL:MACRO ((CHAR TABLE)
|
||||
(GETHASH CHAR TABLE)))
|
||||
|
||||
(IL:PUTPROPS QUOTE-WRAPPER IL:MACRO (TYPE (COND
|
||||
(IL:PUTPROPS QUOTE-WRAPPER IL:MACRO (TYPE (COND
|
||||
((AND (IL:LISTP (CAR TYPE))
|
||||
(EQ (CAAR TYPE)
|
||||
'QUOTE))
|
||||
@@ -573,38 +563,33 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
(IL:KWOTE (IL:|for| W IL:|in| (CADAR TYPE)
|
||||
IL:|collect| (IL:LISTGET
|
||||
QUOTE-WRAPPER-LIST
|
||||
W)))
|
||||
W)))
|
||||
(IL:KWOTE (IL:LISTGET QUOTE-WRAPPER-LIST
|
||||
(CADAR TYPE)))))
|
||||
(T `(IL:LISTGET QUOTE-WRAPPER-LIST ,(CAR TYPE))))))
|
||||
|
||||
(IL:PUTPROPS QUOTE-WRAPPER-NAME IL:MACRO ((TYPE)
|
||||
(IL:PUTPROPS QUOTE-WRAPPER-NAME IL:MACRO ((TYPE)
|
||||
(IL:LISTGET (IL:CONSTANT (IL:REVERSE QUOTE-WRAPPER-LIST))
|
||||
TYPE)))
|
||||
|
||||
(IL:PUTPROPS REPAINT-NEW-LINE IL:MACRO (IL:OPENLAMBDA (LINE)
|
||||
(WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y
|
||||
IL:|of| (CAR LINE))
|
||||
(IL:|fetch| WINDOW-TOP IL:|of|
|
||||
CONTEXT))
|
||||
(REPAINT CONTEXT (IL:|fetch| INDENT
|
||||
IL:|of| (CAR LINE))
|
||||
(IL:|fetch| BASE-LINE-Y
|
||||
IL:|of| (CAR LINE))
|
||||
(CDR LINE)
|
||||
(IL:|fetch| LINEAR-POINTER IL:|of|
|
||||
CONTEXT))
|
||||
(WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y
|
||||
IL:|of| (CAR LINE))
|
||||
(IL:|fetch| WINDOW-BOTTOM
|
||||
IL:|of| CONTEXT))
|
||||
(IL:|replace| BELOW? IL:|of| CONTEXT
|
||||
IL:|with| T)))))
|
||||
(IL:PUTPROPS REPAINT-NEW-LINE IL:MACRO (IL:OPENLAMBDA (LINE)
|
||||
(WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y IL:|of|
|
||||
(CAR LINE))
|
||||
(IL:|fetch| WINDOW-TOP IL:|of| CONTEXT))
|
||||
(REPAINT CONTEXT (IL:|fetch| INDENT IL:|of| (CAR LINE))
|
||||
(IL:|fetch| BASE-LINE-Y IL:|of| (CAR LINE))
|
||||
(CDR LINE)
|
||||
(IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT))
|
||||
(WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y
|
||||
IL:|of| (CAR LINE))
|
||||
(IL:|fetch| WINDOW-BOTTOM IL:|of| CONTEXT))
|
||||
(IL:|replace| BELOW? IL:|of| CONTEXT IL:|with|
|
||||
T)))))
|
||||
|
||||
(IL:PUTPROPS RESET-CONTROL-VARIABLES IL:MACRO ((CONTEXT)
|
||||
(IL:PUTPROPS RESET-CONTROL-VARIABLES IL:MACRO ((CONTEXT)
|
||||
(WHEN (COMPILING-POST-KOTO)
|
||||
(IL:SETQ *PACKAGE* (IL:FETCH PACKAGE
|
||||
IL:OF CONTEXT))
|
||||
(IL:SETQ *PACKAGE* (IL:FETCH PACKAGE IL:OF CONTEXT
|
||||
))
|
||||
(IL:SETQ *PRINT-ARRAY* NIL)
|
||||
(IL:SETQ *PRINT-BASE* (IL:FETCH PRINT-BASE
|
||||
IL:OF CONTEXT))
|
||||
@@ -614,7 +599,7 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
(IL:SETQ *PRINT-GENSYM* T)
|
||||
(IL:SETQ *PRINT-RADIX* NIL))))
|
||||
|
||||
(IL:PUTPROPS SELECT-COMMENT-INDENT IL:MACRO ((KEY LEVEL-1-INDENT LEVEL-2-INDENT LEVEL-3-INDENT)
|
||||
(IL:PUTPROPS SELECT-COMMENT-INDENT IL:MACRO ((KEY LEVEL-1-INDENT LEVEL-2-INDENT LEVEL-3-INDENT)
|
||||
(IL:SELECTQ KEY
|
||||
(1 LEVEL-1-INDENT)
|
||||
(2 LEVEL-2-INDENT)
|
||||
@@ -622,34 +607,31 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
LEVEL-3-INDENT)
|
||||
(IL:SHOULDNT "unexpected comment level"))))
|
||||
|
||||
(IL:PUTPROPS SET-COMMENT-POSITIONS IL:MACRO ((COMMENT-START-X COMMENT-INDENT FORM-INDENT PAREN-WIDTH
|
||||
(IL:PUTPROPS SET-COMMENT-POSITIONS IL:MACRO ((COMMENT-START-X COMMENT-INDENT FORM-INDENT PAREN-WIDTH
|
||||
NODE CONTEXT)
|
||||
(COND
|
||||
((IL:IGEQ (IL:IPLUS FORM-INDENT (IL:|fetch|
|
||||
COMMENT-WIDTH
|
||||
IL:|of|
|
||||
CONTEXT))
|
||||
(IL:|fetch| RIGHT-MARGIN IL:|of|
|
||||
NODE))
|
||||
((IL:IGEQ (IL:IPLUS FORM-INDENT (IL:|fetch|
|
||||
COMMENT-WIDTH
|
||||
IL:|of| CONTEXT))
|
||||
(IL:|fetch| RIGHT-MARGIN IL:|of| NODE))
|
||||
(IL:SETQ COMMENT-START-X
|
||||
(IL:IPLUS (IL:|fetch| START-X IL:|of|
|
||||
NODE)
|
||||
(IL:IPLUS (IL:|fetch| START-X IL:|of| NODE)
|
||||
PAREN-WIDTH))
|
||||
(IL:SETQ COMMENT-INDENT COMMENT-START-X))
|
||||
(T (IL:SETQ COMMENT-START-X
|
||||
(IL:IDIFFERENCE (IL:|fetch| RIGHT-MARGIN
|
||||
IL:|of| NODE)
|
||||
(IL:|fetch| COMMENT-WIDTH IL:|of|
|
||||
CONTEXT)))
|
||||
(IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT)
|
||||
))
|
||||
(IL:SETQ COMMENT-INDENT
|
||||
(IL:IPLUS COMMENT-START-X (IL:|fetch|
|
||||
COMMENT-SEPARATION
|
||||
IL:|of| CONTEXT)
|
||||
))))))
|
||||
IL:|of| CONTEXT)))))
|
||||
))
|
||||
|
||||
(IL:PUTPROPS SET-SELECTION-NOWHERE IL:MACRO ((SELECTION)
|
||||
(IL:|replace| SELECT-NODE IL:|of| SELECTION
|
||||
IL:|with| NIL)))
|
||||
(IL:PUTPROPS SET-SELECTION-NOWHERE IL:MACRO ((SELECTION)
|
||||
(IL:|replace| SELECT-NODE IL:|of| SELECTION IL:|with|
|
||||
NIL)))
|
||||
)
|
||||
|
||||
|
||||
@@ -662,108 +644,99 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
DESTINATION IL:_ ,DEST))
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE
|
||||
|
||||
(IL:PUTPROPS ADVANCE IL:MACRO ((WIDTH)
|
||||
(IL:PUTPROPS ADVANCE IL:MACRO ((WIDTH)
|
||||
(IL:|add| (IL:|fetch| CURRENT-X IL:|of| CONTEXT)
|
||||
WIDTH)))
|
||||
|
||||
(IL:PUTPROPS CLOSE-OPEN-NODE IL:MACRO ((CONTEXT)
|
||||
(IL:PUTPROPS CLOSE-OPEN-NODE IL:MACRO ((CONTEXT)
|
||||
(WHEN (IL:|fetch| OPEN-NODE-CHANGED? IL:|of| CONTEXT)
|
||||
(CLOSE-NODE CONTEXT))))
|
||||
|
||||
(IL:PUTPROPS DEAD-NODE? IL:MACRO ((NODE)
|
||||
(IL:PUTPROPS DEAD-NODE? IL:MACRO ((NODE)
|
||||
(EQ 0 (IL:|fetch| DEPTH IL:|of| NODE))))
|
||||
|
||||
(IL:PUTPROPS END-UNDO-BLOCK IL:MACRO (NIL (COLLECT-UNDO-BLOCK CONTEXT)))
|
||||
(IL:PUTPROPS END-UNDO-BLOCK IL:MACRO (NIL (COLLECT-UNDO-BLOCK CONTEXT)))
|
||||
|
||||
(IL:PUTPROPS ESCAPE-CHAR IL:MACRO ((READ-TABLE)
|
||||
(IL:|fetch| (READTABLEP IL:ESCAPECHAR) IL:|of|
|
||||
(OR READ-TABLE
|
||||
*READTABLE*))))
|
||||
(IL:PUTPROPS ESCAPE-CHAR IL:MACRO ((READ-TABLE)
|
||||
(IL:|fetch| (READTABLEP IL:ESCAPECHAR) IL:|of| (OR READ-TABLE
|
||||
*READTABLE*))))
|
||||
|
||||
(IL:PUTPROPS EQ-POINT-TYPE IL:MACRO ((POINT TYPE)
|
||||
(IL:PUTPROPS EQ-POINT-TYPE IL:MACRO ((POINT TYPE)
|
||||
(LET ((POINTNODE (IL:|fetch| POINT-NODE IL:|of| POINT)))
|
||||
(IF (IL:|type?| EDIT-SELECTION POINTNODE)
|
||||
(EQ (IL:|fetch| NODE-TYPE
|
||||
IL:|of| (IL:|fetch| SELECT-NODE
|
||||
IL:|of| POINTNODE))
|
||||
(EQ (IL:|fetch| NODE-TYPE IL:|of| (IL:|fetch|
|
||||
SELECT-NODE
|
||||
IL:|of| POINTNODE)
|
||||
)
|
||||
TYPE)
|
||||
(EQ (IL:|fetch| NODE-TYPE IL:|of| POINTNODE)
|
||||
TYPE)))))
|
||||
|
||||
(IL:PUTPROPS NEXT-LINEAR IL:MACRO ((CONTEXT ITEM)
|
||||
(AND (IL:LISTP (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)
|
||||
)
|
||||
(IL:PUTPROPS NEXT-LINEAR IL:MACRO ((CONTEXT ITEM)
|
||||
(AND (IL:LISTP (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT))
|
||||
(EQ (CAR (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT))
|
||||
ITEM))))
|
||||
|
||||
(IL:PUTPROPS SET-LINEAR IL:MACRO (IL:OPENLAMBDA (CONTEXT NEW-LPTR)
|
||||
(IL:|replace| LINEAR-POINTER IL:|of| CONTEXT
|
||||
IL:|with| NEW-LPTR)
|
||||
(IF (IL:LISTP (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT
|
||||
))
|
||||
(RPLACD (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT)
|
||||
NEW-LPTR)
|
||||
(IL:|replace| LINEAR-FORM
|
||||
IL:|of| (IL:|fetch| LINEAR-PREV IL:|of|
|
||||
CONTEXT)
|
||||
IL:|with| NEW-LPTR))))
|
||||
(IL:PUTPROPS SET-LINEAR IL:MACRO (IL:OPENLAMBDA (CONTEXT NEW-LPTR)
|
||||
(IL:|replace| LINEAR-POINTER IL:|of| CONTEXT IL:|with| NEW-LPTR)
|
||||
(IF (IL:LISTP (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT))
|
||||
(RPLACD (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT)
|
||||
NEW-LPTR)
|
||||
(IL:|replace| LINEAR-FORM IL:|of| (IL:|fetch| LINEAR-PREV
|
||||
IL:|of| CONTEXT)
|
||||
IL:|with| NEW-LPTR))))
|
||||
|
||||
(IL:PUTPROPS START-UNDO-BLOCK IL:MACRO (NIL (IL:|push| (IL:|fetch| UNDO-LIST IL:|of|
|
||||
CONTEXT)
|
||||
(IL:PUTPROPS START-UNDO-BLOCK IL:MACRO (NIL (IL:|push| (IL:|fetch| UNDO-LIST IL:|of| CONTEXT)
|
||||
NIL)))
|
||||
|
||||
(IL:PUTPROPS STEP-LINEAR IL:MACRO ((CONTEXT)
|
||||
(IL:PUTPROPS STEP-LINEAR IL:MACRO ((CONTEXT)
|
||||
(IL:|replace| LINEAR-POINTER IL:|of| CONTEXT
|
||||
IL:|with| (CDR (IL:|replace| LINEAR-PREV IL:|of|
|
||||
CONTEXT
|
||||
IL:|with| (IL:|fetch|
|
||||
LINEAR-POINTER
|
||||
IL:|of| CONTEXT)))))
|
||||
)
|
||||
IL:|with| (CDR (IL:|replace| LINEAR-PREV IL:|of| CONTEXT
|
||||
IL:|with| (IL:|fetch| LINEAR-POINTER
|
||||
IL:|of| CONTEXT))))))
|
||||
|
||||
(IL:PUTPROPS SUBNODE IL:MACRO (X (IF (EQ (CAR X)
|
||||
(IL:PUTPROPS SUBNODE IL:MACRO (X (IF (EQ (CAR X)
|
||||
1)
|
||||
(LIST 'CADR (LIST 'IL:FETCH 'SUB-NODES (CADR X)))
|
||||
(LIST 'CADR (LIST 'IL:NTH (LIST 'IL:FETCH 'SUB-NODES
|
||||
(CADR X))
|
||||
(CAR X))))))
|
||||
|
||||
(IL:PUTPROPS UNDO-BY IL:MACRO (INFO (LIST 'IL:PUSH '(IL:|fetch| UNDO-LIST IL:|of| CONTEXT)
|
||||
(IL:PUTPROPS UNDO-BY IL:MACRO (INFO (LIST 'IL:PUSH '(IL:|fetch| UNDO-LIST IL:|of| CONTEXT)
|
||||
(LIST* 'LIST (IL:KWOTE (CAR INFO))
|
||||
(CDR INFO)))))
|
||||
|
||||
(IL:PUTPROPS ZAP-CLISP-TRANSLATION IL:MACRO ((X)
|
||||
(IL:PUTPROPS ZAP-CLISP-TRANSLATION IL:MACRO ((X)
|
||||
(AND IL:CLISPARRAY (IL:PUTHASH X NIL IL:CLISPARRAY))))
|
||||
|
||||
(IL:PUTPROPS SMASH-USING IL:MACRO (X (IL:|bind| (SRC IL:_ (IF (IL:ATOM (CADDR X))
|
||||
(CADDR X)
|
||||
'$$SOURCE))
|
||||
(IL:PUTPROPS SMASH-USING IL:MACRO (X (IL:|bind| (SRC IL:_ (IF (IL:ATOM (CADDR X))
|
||||
(CADDR X)
|
||||
'$$SOURCE))
|
||||
DEST
|
||||
(DESCR IL:_ (IL:GETDESCRIPTORS (CAR X)))
|
||||
IL:|first| (IL:SETQ DEST
|
||||
(LIST 'IL:REPLACEFIELDVAL (LIST 'QUOTE
|
||||
(CAR DESCR))
|
||||
(CADR X)
|
||||
(LIST 'IL:FETCHFIELD
|
||||
(LIST 'QUOTE (CAR DESCR))
|
||||
SRC)))
|
||||
IL:|first| (IL:SETQ DEST (LIST 'IL:REPLACEFIELDVAL
|
||||
(LIST 'QUOTE (CAR DESCR))
|
||||
(CADR X)
|
||||
(LIST 'IL:FETCHFIELD
|
||||
(LIST 'QUOTE
|
||||
(CAR DESCR))
|
||||
SRC)))
|
||||
(IL:SETQ DESCR (CDR DESCR)) IL:|while| DESCR
|
||||
IL:|do| (IL:SETQ DEST (LIST 'IL:FREPLACEFIELDVAL
|
||||
(LIST 'QUOTE (CAR DESCR))
|
||||
DEST
|
||||
(LIST 'IL:FETCHFIELD
|
||||
(LIST 'QUOTE
|
||||
(CAR DESCR))
|
||||
SRC)))
|
||||
(LIST 'QUOTE (CAR DESCR))
|
||||
DEST
|
||||
(LIST 'IL:FETCHFIELD
|
||||
(LIST 'QUOTE (CAR DESCR))
|
||||
SRC)))
|
||||
(IL:SETQ DESCR (CDR DESCR))
|
||||
IL:|finally| (WHEN (NOT (IL:ATOM (CADDR X)))
|
||||
(IL:SETQ DEST
|
||||
(LIST 'LET (LIST (LIST '$$SOURCE
|
||||
(CADDR X)))
|
||||
DEST)))
|
||||
(IL:SETQ DEST
|
||||
(LIST 'LET (LIST (LIST '$$SOURCE
|
||||
(CADDR X)))
|
||||
DEST)))
|
||||
(RETURN DEST))))
|
||||
|
||||
(IL:PUTPROPS IL:HALF IL:MACRO ((IL:X)
|
||||
(IL:PUTPROPS IL:HALF IL:MACRO ((IL:X)
|
||||
(IL:LRSH IL:X 1)))
|
||||
)
|
||||
|
||||
@@ -775,10 +748,10 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
|
||||
|
||||
(DEFPARAMETER *IL-CL-CONFLICTS*
|
||||
'(IL:*PRINT-STRUCTURE* IL:* IL:APPEND IL:APPLY IL:ASSOC IL:ATOM IL:BLOCK IL:CHARACTER
|
||||
IL:EQUAL IL:ERROR IL:FLOATP IL:FORMAT IL:FUNCTION IL:GETHASH IL:IF IL:LAMBDA IL:LENGTH
|
||||
IL:LISTP IL:MAPCAR IL:NTH IL:NUMBER IL:NUMBERP IL:PRIN1 IL:READ IL:REVERSE IL:SETQ
|
||||
IL:SPACE IL:STRINGP IL:TERPRI))
|
||||
'(IL:*PRINT-STRUCTURE* IL:* IL:APPEND IL:APPLY IL:ASSOC IL:ATOM IL:BLOCK IL:CHARACTER IL:EQUAL
|
||||
IL:ERROR IL:FLOATP IL:FORMAT IL:FUNCTION IL:GETHASH IL:IF IL:LAMBDA IL:LENGTH IL:LISTP
|
||||
IL:MAPCAR IL:NTH IL:NUMBER IL:NUMBERP IL:PRIN1 IL:READ IL:REVERSE IL:SETQ IL:SPACE
|
||||
IL:STRINGP IL:TERPRI))
|
||||
|
||||
(DEFPARAMETER *IL-IMPORTS*
|
||||
'(IL:\" IL:$$ITERATE IL:$$LST1 IL:$$OUT IL:\( IL:*DISPLAY-EDITOR* IL:\, IL:\. IL:.P2
|
||||
@@ -804,12 +777,12 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
IL:EXPR IL:EXTENT IL:FCHARACTER IL:FETCHFIELD IL:FILECREATED IL:FILEMAP IL:FILEPKGFLG
|
||||
IL:FILES IL:FILESLOAD IL:FILETYPE IL:FIND.PROCESS IL:FIXEDITDATE IL:FIXP IL:FIXR IL:FLAG
|
||||
IL:FLAGBITS IL:FLASHWINDOW IL:FLENGTH IL:FM.CHANGELABEL IL:FM.CHANGESTATE
|
||||
IL:FM.DONTRESHAPE IL:FM.EDITITEM IL:FM.GETITEM IL:FM.ITEMPROP IL:FM.RESETMENU IL:FMEMB
|
||||
IL:FM.DONTRESHAPE IL:FM.EDITITEM IL:FM.GETITEM IL:FM.ITEMPROP IL:FM.RESETMENU IL:FMEMB
|
||||
IL:FN IL:FNS IL:FONT IL:FONTCREATE IL:FONTPROP IL:FORM IL:FORWORD IL:FREEMENU
|
||||
IL:FREPLACEFIELDVAL IL:FULLXPOINTER IL:FUNCTIONS IL:GACHA IL:GETD IL:GETDEF
|
||||
IL:GETDESCRIPTORS IL:GETPROMPTWINDOW IL:GETPROP IL:GETPROPLIST IL:GETREGION IL:GETSYNTAX
|
||||
IL:GLOBALVARS IL:GROUP IL:HALF IL:HEIGHT IL:HEIGHTIFWINDOW IL:HELVETICA IL:ICON
|
||||
IL:ICONWINDOW IL:ID IL:IDIFFERENCE IL:IFWORD IL:IGEQ IL:IGREATERP IL:ILEQ IL:ILESSP
|
||||
IL:ICONWINDOW IL:ID IL:IDIFFERENCE IL:IFWORD IL:IGEQ IL:IGREATERP IL:ILEQ IL:ILESSP
|
||||
IL:IMAX IL:IMIN IL:IMINUS IL:IN/SCROLL/BAR? IL:INNERESCQUOTE IL:INFOHOOK IL:INITRECORDS
|
||||
IL:INITVARS IL:INPUT IL:INSIDEP IL:INTERPRESS IL:INVERT IL:IPLUS IL:IQUOTIENT
|
||||
IL:ITALICFONT IL:ITEM IL:ITEMS IL:ITEMWIDTH IL:ITIMES IL:KEYACTION IL:KEYACTIONTABLE
|
||||
@@ -817,10 +790,10 @@ IL:|{DSK}<python>lde>lispcore>sources>SEDIT-DECLS.;2|)
|
||||
IL:LASTMOUSEX IL:LASTMOUSEY IL:LCONC IL:LEFT IL:LEFTBRACKET IL:LEFTPAREN IL:LEQ
|
||||
IL:LINEDELETE IL:LINKS IL:LISTGET IL:LISTPUT IL:LITATOM IL:LOCALCLOSE IL:LOCALVARS IL:LRSH
|
||||
IL:MACRO IL:MACROS IL:MAINWINDOW IL:MAKEFILE-ENVIRONMENT IL:MARKASCHANGED
|
||||
IL:MARKASCHANGEDFNS IL:MASK IL:MAXWIDTH IL:MEMB IL:MENU IL:MENUFONT IL:MENUOFFSET
|
||||
IL:MESS IL:MICASPERPT IL:MIDDLE IL:MKSTRING IL:MOUSE IL:MOUSECONFIRM IL:MOUSESTATE IL:MOVE
|
||||
IL:MOVETO IL:MULTESCAPECHAR IL:MULTIPLE-ESCAPE IL:NAME IL:NCHARS IL:NCONC1 IL:NEQ
|
||||
IL:NILL IL:NLAMBDA IL:NLISTP IL:NLSETQ IL:NOBIND IL:NONE IL:NOTIFY.EVENT IL:NTHCHARCODE
|
||||
IL:MARKASCHANGEDFNS IL:MASK IL:MAXWIDTH IL:MEMB IL:MENU IL:MENUFONT IL:MENUOFFSET IL:MESS
|
||||
IL:MICASPERPT IL:MIDDLE IL:MKSTRING IL:MOUSE IL:MOUSECONFIRM IL:MOUSESTATE IL:MOVE
|
||||
IL:MOVETO IL:MULTESCAPECHAR IL:MULTIPLE-ESCAPE IL:NAME IL:NCHARS IL:NCONC1 IL:NEQ IL:NILL
|
||||
IL:NLAMBDA IL:NLISTP IL:NLSETQ IL:NOBIND IL:NONE IL:NOTIFY.EVENT IL:NTHCHARCODE
|
||||
IL:OBTAIN.MONITORLOCK IL:OFFST IL:OPENLAMBDA IL:OPENSTRINGSTREAM IL:OPENWP IL:P
|
||||
IL:PACKAGEDELIM IL:PAINT IL:POINTER IL:PRETTYCOMPRINT IL:PRIN2 IL:PROCESS IL:PROCESS.APPLY
|
||||
IL:PROCESS.EVAL IL:PROCESS.EVALV IL:PROCESSP IL:PROCESSPROP IL:PROCTYPEAHEAD
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -1,13 +1,15 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT ( USE LISP XCL)))
|
||||
(IL:FILECREATED "17-May-90 11:01:36" IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;2| 2834
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE SEDIT ( USE LISP XCL)) READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED " 1-Dec-2021 20:41:41"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-EXPORTS.;3| 2921
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-EXPORTSCOMS)
|
||||
|
||||
IL:|previous| IL:|date:| " 5-Feb-88 11:38:07"
|
||||
IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;1|)
|
||||
IL:|previous| IL:|date:| " 1-Dec-2021 17:38:50"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-EXPORTS.;2|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988, 1990 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:SEDIT-EXPORTSCOMS)
|
||||
|
||||
@@ -18,7 +20,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;1|)
|
||||
|
||||
(IL:* IL:|;;| "REGION MANAGER")
|
||||
|
||||
(IL:P (EXPORT '(GET-WINDOW-REGION SAVE-WINDOW-REGION))
|
||||
(IL:P (EXPORT '(GET-WINDOW-REGION SAVE-WINDOW-REGION GET-WINDOW GET-PROP PUT-PROP))
|
||||
(EXPORT '(KEEP-WINDOW-REGION)))
|
||||
|
||||
(IL:* IL:|;;| "PROGRAMMERS INTERFACE")
|
||||
@@ -41,8 +43,8 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;1|)
|
||||
(IL:PUTPROPS IL:SEDIT-EXPORTS IL:FILETYPE :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:SEDIT-EXPORTS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE IL:SEDIT
|
||||
(:USE IL:LISP IL:XCL))))
|
||||
(DEFPACKAGE IL:SEDIT (:USE IL:LISP
|
||||
IL:XCL))))
|
||||
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE
|
||||
|
||||
(IL:FILESLOAD IL:SEDIT-DECLS)
|
||||
@@ -53,7 +55,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>SEDIT-EXPORTS.;1|)
|
||||
(IL:* IL:|;;| "REGION MANAGER")
|
||||
|
||||
|
||||
(EXPORT '(GET-WINDOW-REGION SAVE-WINDOW-REGION))
|
||||
(EXPORT '(GET-WINDOW-REGION SAVE-WINDOW-REGION GET-WINDOW GET-PROP PUT-PROP))
|
||||
|
||||
(EXPORT '(KEEP-WINDOW-REGION))
|
||||
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,15 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "SEDIT" ( USE "LISP" "XCL")))
|
||||
(IL:FILECREATED "10-Jul-91 19:11:12" IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;5| 36139
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "SEDIT" ( USE "LISP" "XCL")) READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-TOPLEVELCOMS)
|
||||
(IL:FNS SEDITE)
|
||||
(IL:FILECREATED " 8-Dec-2021 14:01:58"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-TOPLEVEL.;19| 37986
|
||||
|
||||
IL:|previous| IL:|date:| " 3-Apr-91 15:43:40"
|
||||
IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
:CHANGES-TO (IL:FNS GET-WINDOW-REGION)
|
||||
|
||||
:PREVIOUS-DATE " 8-Dec-2021 11:50:57"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>SEDIT-TOPLEVEL.;18|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:SEDIT-TOPLEVELCOMS)
|
||||
|
||||
@@ -19,14 +20,14 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS))
|
||||
(IL:INITVARS CONTEXTS REGIONS)
|
||||
(IL:VARS (IL:*DISPLAY-EDITOR* 'SEDIT))
|
||||
(IL:FNS SEDIT RESET GET-WINDOW-REGION SAVE-WINDOW-REGION)
|
||||
(IL:FNS SEDIT RESET GET-WINDOW-REGION SAVE-WINDOW-REGION GET-WINDOW GET-PROP PUT-PROP)
|
||||
(IL:FNS GET-CONTEXT DISINTEGRATE-CONTEXT AWAKE-COMMAND-PROCESS AWAKE-ME MARKASCHANGEDFN
|
||||
NEW-FUNCTION-BODY)
|
||||
(IL:FUNCTIONS QUERY-THROW-AWAY-CHANGES SET-OPTIONS SET-PROPS START-PROCESS)
|
||||
(IL:COMS
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"THESE CAN ALL BE NUKED WITH THE NEW EDIT INTERFACE AND A DETACHED TTY/EDITOR (WOZ 1/25/91)")
|
||||
"THESE CAN ALL BE NUKED WITH THE NEW EDIT INTERFACE AND A DETACHED TTY/EDITOR (WOZ 1/25/91)")
|
||||
|
||||
(IL:PROP (IL:|Definition-for-EDITL| IL:|Definition-for-EDITE|
|
||||
IL:|Definition-for-EDITDATE|)
|
||||
@@ -52,8 +53,8 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
(IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:FILETYPE :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE
|
||||
(DEFPACKAGE "SEDIT"
|
||||
(:USE "LISP" "XCL"))))
|
||||
(DEFPACKAGE "SEDIT" (:USE "LISP" "XCL")
|
||||
)))
|
||||
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
|
||||
(IL:LOCALVARS . T)
|
||||
@@ -85,7 +86,7 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
|
||||
(IL:* IL:|;;| "this is a new context, needs to be setup from scratch")
|
||||
|
||||
(START-PROCESS CONTEXT NAME)
|
||||
(START-PROCESS CONTEXT )
|
||||
CONTEXT)
|
||||
((AND (IL:OPENWP WINDOW)
|
||||
(IL:PROCESSP (IL:WINDOWPROP WINDOW 'IL:PROCESS)))
|
||||
@@ -120,20 +121,60 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
(il:lambda nil (il:* il:\; "Edited 10-Jul-87 08:35 by DCB") (cond (contexts (il:error "Can't reset SEdit while there are open SEdit windows")) (t (create-environments) (reset-formats) t)))
|
||||
)
|
||||
|
||||
(get-window-region
|
||||
(il:lambda (context reason name type) (il:* il:\; "Edited 19-Nov-87 10:18 by DCB") (il:* il:|;;;| "called to get a region for this sedit window. should return the region for the sedit including the prompt window. context is being built and needs a window. the context will have at least the name (IconTitle) and type (EditType) of the object being edited, and can be used as desired to map between contexts and windows. If reason is :CREATE, then this function must return a region. If :EXPAND, then this algorithm returns a region from the stack only if SEDIT.KEEP.WINDOW.REGION is nil, otherwise it returns NIL, telling the window system not to reshape on expansion.") (when (or (eq reason :create) (not keep-window-region)) (or (il:pop regions) (progn (il:|printout| il:promptwindow t "Select region for SEdit window.") (il:getregion 30 20)))))
|
||||
)
|
||||
(GET-WINDOW-REGION
|
||||
(IL:LAMBDA (CONTEXT REASON NAME TYPE)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Edited 8-Dec-2021 14:01 by rmk: The :REGION property gives the user directe control")
|
||||
(IL:* IL:\; "Edited 1-Dec-2021 22:51 by rmk:")
|
||||
(IL:* IL:\; "Edited 19-Nov-87 10:18 by DCB")
|
||||
|
||||
(IL:* IL:|;;;| "called to get a region for this sedit window. should return the region for the sedit including the prompt window. context is being built and needs a window. the context will have at least the name (IconTitle) and type (EditType) of the object being edited, and can be used as desired to map between contexts and windows. If reason is :CREATE, then this function must return a region. If :EXPAND, then this algorithm returns a region from the stack only if SEDIT.KEEP.WINDOW.REGION is nil, otherwise it returns NIL, telling the window system not to reshape on expansion.")
|
||||
|
||||
(OR (GET-PROP CONTEXT :REGION)
|
||||
(WHEN (OR (EQ REASON :CREATE)
|
||||
(NOT KEEP-WINDOW-REGION))
|
||||
(OR (IL:POP REGIONS)
|
||||
(PROGN (IL:|printout| IL:PROMPTWINDOW T "Select region for SEdit window.")
|
||||
(IL:GETREGION 30 20)))))))
|
||||
|
||||
(SAVE-WINDOW-REGION
|
||||
(IL:LAMBDA (CONTEXT REASON NAME TYPE REGION) (IL:* IL:\; "Edited 23-Nov-87 17:46 by DCB")
|
||||
(IL:LAMBDA (CONTEXT REASON NAME TYPE REGION) (IL:* IL:\; "Edited 1-Dec-2021 21:13 by rmk:")
|
||||
(IL:* IL:\; "Edited 23-Nov-87 17:46 by DCB")
|
||||
|
||||
(IL:* IL:|;;;| "Release this sedit windows region to be used again. If we're shrinking, KEEP-WINDOW-REGION determines whether to release the region or not. If an icon is being closed, don't release the region because it was handled appropriately when the window as shrunk. remember, we're maintaining regions including the prompt window height, so use WINDOWREGION to get the whole region.")
|
||||
|
||||
(WHEN (OR (EQ REASON :CLOSE)
|
||||
(AND (EQ REASON :SHRINK)
|
||||
(NOT KEEP-WINDOW-REGION)))
|
||||
(IL:|push| REGIONS (OR REGION (IL:WINDOWREGION (IL:|fetch| DISPLAY-WINDOW
|
||||
IL:|of| CONTEXT)))))))
|
||||
(UNLESS (GET-PROP CONTEXT :DONT-KEEP-WINDOW-REGION)
|
||||
(IL:|push| REGIONS (OR REGION (IL:WINDOWREGION (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT
|
||||
))))))))
|
||||
|
||||
(GET-WINDOW
|
||||
(IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 25-Nov-2021 23:13 by rmk:")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Returns the current window of CONTEXT, for clients that don't have SEDIT declarations")
|
||||
|
||||
(IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)))
|
||||
|
||||
(GET-PROP
|
||||
(IL:LAMBDA (CONTEXT PROP) (IL:* IL:\; "Edited 1-Dec-2021 21:40 by rmk:")
|
||||
(WHEN (IL:WINDOWP CONTEXT)
|
||||
(SETQ CONTEXT (IL:WINDOWPROP CONTEXT 'EDIT-CONTEXT)))
|
||||
(IL:LISTGET (IL:FETCH (EDIT-CONTEXT PROPS) IL:OF CONTEXT)
|
||||
PROP)))
|
||||
|
||||
(PUT-PROP
|
||||
(IL:LAMBDA (CONTEXT PROP VALUE) (IL:* IL:\; "Edited 1-Dec-2021 21:44 by rmk:")
|
||||
(WHEN (IL:WINDOWP CONTEXT)
|
||||
(SETQ CONTEXT (IL:WINDOWPROP CONTEXT 'EDIT-CONTEXT)))
|
||||
(LET ((PROPS (IL:FETCH (EDIT-CONTEXT PROPS) IL:OF CONTEXT)))
|
||||
(IF PROPS
|
||||
(IL:LISTPUT PROPS PROP VALUE)
|
||||
(IL:REPLACE (EDIT-CONTEXT PROPS) IL:OF CONTEXT IL:WITH (LIST PROP VALUE)))
|
||||
VALUE)))
|
||||
)
|
||||
(IL:DEFINEQ
|
||||
|
||||
@@ -199,7 +240,9 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
)
|
||||
|
||||
(MARKASCHANGEDFN
|
||||
(IL:LAMBDA (NAME TYPE REASON) (IL:* IL:\; "Edited 3-Apr-91 15:42 by jds")
|
||||
(IL:LAMBDA (NAME TYPE REASON) (IL:* IL:\; "Edited 8-Dec-2021 11:49 by rmk")
|
||||
(IL:* IL:\; "Edited 2-Dec-2021 22:57 by larry")
|
||||
(IL:* IL:\; "Edited 3-Apr-91 15:42 by jds")
|
||||
|
||||
(IL:* IL:|;;;| "When a managed object is changed, we must check if we have an open edit on it. If so, calling SEdit again, with the fresh definition, will force the update. This is fairly tricky, though. Markaschanged is called as a result of editing a managed definition, so this markaschangedfn could be running in the sedit process under the completion-fn half way through completion. IDEALLY in this case we could say \"i know it changed, i just changed it!\" and ignore this call. BUT FOR NOW (1/14/91) since the manager can change the definition on completion (editdates, for one), we have to notify SEdit. Since calling editdef will restart the sedit process, the completion-fn will not finish, so do the verify-structure here.")
|
||||
|
||||
@@ -221,7 +264,8 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
|
||||
(IL:* IL:|;;| "found a matching context elsewhere")
|
||||
|
||||
(IL:EDITDEF NAME TYPE NIL NIL '(:DONTWAIT)))))))
|
||||
(IL:RESETFORM (IL:EDITMODE 'SEDIT)
|
||||
(IL:EDITDEF NAME TYPE NIL NIL '(:DONTWAIT))))))))
|
||||
|
||||
(new-function-body
|
||||
(il:lambda (dummy-body) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (if (il:neq (il:editmode) (quote sedit)) (il:copy dummy-body) (list (quote il:lambda) args-gap body-gap)))
|
||||
@@ -247,46 +291,41 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
(IL:* IL:|;;;| "set up the OPTIONS provided in the call to SEDIT for this context. Most of these options do not require immediate action. Rather, they control how some command or interaction will work later, so we just store the option list in the context. Most of these options are really edit-interface options, not sedit options. We stash them so that when the *edit-fn* is called under M-O, it will be handed the same options that this edit was started with")
|
||||
|
||||
(IL:REPLACE (EDIT-CONTEXT EDIT-OPTIONS) IL:OF CONTEXT IL:WITH (IF (LISTP OPTIONS)
|
||||
OPTIONS
|
||||
(LIST OPTIONS))))
|
||||
OPTIONS
|
||||
(LIST OPTIONS))))
|
||||
|
||||
(DEFUN SET-PROPS (CONTEXT PROPS)
|
||||
(DEFUN SET-PROPS (CONTEXT PROPS) (IL:* IL:\; "Edited 1-Dec-2021 20:10 by rmk:")
|
||||
|
||||
(IL:* IL:|;;;| "go through the PROPS list supplied in the call to SEDIT and store the info in the context. The :NAME and :TYPE props are already handled, because get-context uses this information to find an appropriate context. Grab the current values of the variables that determine reading and printing, and save them in a profile in the context, so that later changes to the globals don't affect existing contexts. ")
|
||||
|
||||
(IL:* IL:|;;;| "RMK: Added ability to store arbitrary properties, in a new PROPS field. Perhaps should filter out the ones that are built-in and interpreted separately, but presumably doesn't matter. The point of this is to allow clients to provide additional information in the call to SEDIT that can be retrieved later (SEDITPROP, like STREAMPROP, WINDOWPROP, etc.) ")
|
||||
|
||||
(IL:REPLACE (EDIT-CONTEXT COMPLETION-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS
|
||||
:COMPLETION-FN
|
||||
)
|
||||
#'NULL))
|
||||
(IL:REPLACE (EDIT-CONTEXT ROOT-CHANGED-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET
|
||||
PROPS
|
||||
:ROOT-CHANGED-FN
|
||||
)
|
||||
#'NULL))
|
||||
(IL:REPLACE (EDIT-CONTEXT ENVIRONMENT) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS
|
||||
:ENVIRONMENT)
|
||||
LISP-EDIT-ENVIRONMENT
|
||||
))
|
||||
(IL:REPLACE (EDIT-CONTEXT PROFILE) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS
|
||||
:PROFILE)
|
||||
(SAVE-PROFILE
|
||||
(COPY-PROFILE
|
||||
"READ-PRINT"))))
|
||||
(IL:REPLACE (EDIT-CONTEXT EVAL-IN-PROCESS) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET
|
||||
PROPS
|
||||
:EVAL-IN-PROCESS
|
||||
)
|
||||
(EVAL-IN-PROCESS)
|
||||
))
|
||||
(IL:REPLACE (EDIT-CONTEXT EVAL-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS
|
||||
:EVAL-FN)
|
||||
(XCL::PROFILE-ENTRY-VALUE
|
||||
'*EVAL-FUNCTION*)))
|
||||
:COMPLETION-FN)
|
||||
#'NULL))
|
||||
(IL:REPLACE (EDIT-CONTEXT ROOT-CHANGED-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS
|
||||
:ROOT-CHANGED-FN)
|
||||
#'NULL))
|
||||
(IL:REPLACE (EDIT-CONTEXT ENVIRONMENT) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :ENVIRONMENT)
|
||||
LISP-EDIT-ENVIRONMENT))
|
||||
(IL:REPLACE (EDIT-CONTEXT PROFILE) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :PROFILE)
|
||||
(SAVE-PROFILE (COPY-PROFILE
|
||||
"READ-PRINT"))))
|
||||
(IL:REPLACE (EDIT-CONTEXT EVAL-IN-PROCESS) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS
|
||||
:EVAL-IN-PROCESS)
|
||||
(EVAL-IN-PROCESS)))
|
||||
(IL:REPLACE (EDIT-CONTEXT EVAL-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :EVAL-FN)
|
||||
(XCL::PROFILE-ENTRY-VALUE
|
||||
'*EVAL-FUNCTION*)))
|
||||
(WHEN (IL:LISTGET PROPS :SELECT-STRUCTURE)
|
||||
(IL:REPLACE (EDIT-CONTEXT FIND-CANDIDATE) IL:OF CONTEXT
|
||||
IL:WITH (CONS (IL:LISTGET PROPS :SELECT-STRUCTURE)
|
||||
(OR (IL:LISTGET PROPS :SELECT-INSTANCE)
|
||||
1)))))
|
||||
(IL:REPLACE (EDIT-CONTEXT FIND-CANDIDATE) IL:OF CONTEXT IL:WITH (CONS (IL:LISTGET PROPS
|
||||
:SELECT-STRUCTURE
|
||||
)
|
||||
(OR (IL:LISTGET PROPS
|
||||
:SELECT-INSTANCE
|
||||
)
|
||||
1))))
|
||||
(IL:REPLACE (EDIT-CONTEXT PROPS) IL:OF CONTEXT IL:WITH PROPS))
|
||||
|
||||
(DEFUN START-PROCESS (CONTEXT)
|
||||
|
||||
@@ -535,12 +574,17 @@ IL:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>SEDIT-TOPLEVEL.;4|)
|
||||
(IL:DEFPRINT 'GAP 'PRINT-GAP)
|
||||
(IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (3202 7114 (SEDIT 3215 . 5201) (RESET 5203 . 5404) (GET-WINDOW-REGION 5406 . 6283) (
|
||||
SAVE-WINDOW-REGION 6285 . 7112)) (7115 13776 (GET-CONTEXT 7128 . 9148) (DISINTEGRATE-CONTEXT 9150 .
|
||||
9876) (AWAKE-COMMAND-PROCESS 9878 . 11471) (AWAKE-ME 11473 . 11856) (MARKASCHANGEDFN 11858 . 13572) (
|
||||
NEW-FUNCTION-BODY 13574 . 13774)) (19971 32948 (SEDITE 19984 . 25751) (SEDITL 25753 . 26898) (
|
||||
FN-CHANGED 26900 . 27195) (PROP-CHANGED 27197 . 27334) (PROPLST-CHANGED 27336 . 27464) (VAR-CHANGED
|
||||
27466 . 27578) (ALIST-COMPLETION 27580 . 28391) (COMPLETION 28393 . 29773) (PROPS-COMPLETION 29775 .
|
||||
30600) (TTYFN 30602 . 32440) (LOCATE-NODE-FROM-EDITCHAIN 32442 . 32946)) (33586 35271 (PRETTY-PRINT
|
||||
33599 . 34642) (MAP-FONT 34644 . 35269)))))
|
||||
(IL:FILEMAP (NIL (3174 8776 (SEDIT 3187 . 5173) (RESET 5175 . 5376) (GET-WINDOW-REGION 5378 . 6676) (
|
||||
SAVE-WINDOW-REGION 6678 . 7692) (GET-WINDOW 7694 . 7998) (GET-PROP 8000 . 8304) (PUT-PROP 8306 . 8774)
|
||||
) (8777 15717 (GET-CONTEXT 8790 . 10810) (DISINTEGRATE-CONTEXT 10812 . 11538) (AWAKE-COMMAND-PROCESS
|
||||
11540 . 13133) (AWAKE-ME 13135 . 13518) (MARKASCHANGEDFN 13520 . 15513) (NEW-FUNCTION-BODY 15515 .
|
||||
15715)) (15719 16702 (QUERY-THROW-AWAY-CHANGES 15719 . 16702)) (16704 17479 (SET-OPTIONS 16704 . 17479
|
||||
)) (17481 20829 (SET-PROPS 17481 . 20829)) (20831 21502 (START-PROCESS 20831 . 21502)) (21818 34795 (
|
||||
SEDITE 21831 . 27598) (SEDITL 27600 . 28745) (FN-CHANGED 28747 . 29042) (PROP-CHANGED 29044 . 29181) (
|
||||
PROPLST-CHANGED 29183 . 29311) (VAR-CHANGED 29313 . 29425) (ALIST-COMPLETION 29427 . 30238) (
|
||||
COMPLETION 30240 . 31620) (PROPS-COMPLETION 31622 . 32447) (TTYFN 32449 . 34287) (
|
||||
LOCATE-NODE-FROM-EDITCHAIN 34289 . 34793)) (34941 35310 (SMART-TTYFN 34941 . 35310)) (35433 37118 (
|
||||
PRETTY-PRINT 35446 . 36489) (MAP-FONT 36491 . 37116)) (37300 37403 (MAKE-BROKEN-ATOM 37300 . 37403)) (
|
||||
37405 37563 (PRINT-BROKEN-ATOM 37405 . 37563)) (37565 37649 (MAKE-GAP 37565 . 37649)) (37651 37779 (
|
||||
PRINT-GAP 37651 . 37779)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user