Compare commits
40 Commits
medley-211
...
medley-211
| Author | SHA1 | Date | |
|---|---|---|---|
|
5fadc6c083 | ||
|
2dcfac5350 | ||
|
|
dcd83c3753 | ||
|
cde5c9018d | ||
|
|
1108a00b90 | ||
|
|
d9e445ad8c | ||
|
|
5b690d39d1 | ||
|
2573e4351f | ||
|
|
936bdd84b5 | ||
|
|
c2915bf5d3 | ||
|
|
40c10a7841 | ||
|
|
362fac9389 | ||
|
|
db082b37e1 | ||
|
|
c0e020f033 | ||
|
|
9af86df169 | ||
|
|
6c26fe958a | ||
|
|
339bd47107 | ||
|
|
3a04303d93 | ||
|
|
68f1e7efe1 | ||
|
|
993bdb2e00 | ||
|
7a27c26f01 | ||
|
|
75a031de39 | ||
|
|
7d656006a6 | ||
|
|
1f8c123184 | ||
|
|
50ce484c1b | ||
|
|
e3f043b40d | ||
|
|
945df5fbe8 | ||
|
|
3d8066b7e8 | ||
|
|
b303e0affa | ||
|
|
869b3a2e32 | ||
|
|
f19d9cc5e2 | ||
|
|
237f3aa6bf | ||
|
|
89a8fe183d | ||
|
|
8266980c22 | ||
|
|
c385039c42 | ||
|
|
1ff0018772 | ||
|
|
6611f96702 | ||
|
|
824e0f20b2 | ||
|
|
d479ef2ef9 | ||
|
|
98aa15455e |
8
.github/workflows/buildDocker.yml
vendored
8
.github/workflows/buildDocker.yml
vendored
@@ -50,6 +50,8 @@ jobs:
|
||||
echo ::set-output name=docker_image::${DOCKER_IMAGE}
|
||||
echo ::set-output name=build_time::$(date -u +'%Y-%m-%dT%H:%M:%SZ')
|
||||
echo ::set-output name=version::${VERSION}
|
||||
echo ::set-output name=maiko_release::${MAIKO_RELEASE}
|
||||
echo ::set-output name=medley_release::${MEDLEY_RELEASE}
|
||||
|
||||
# Download Medley Release Assets
|
||||
- name: Download Release Assets
|
||||
@@ -103,4 +105,8 @@ jobs:
|
||||
# Push the created image
|
||||
push: true
|
||||
# tags to assign to the Docker image
|
||||
tags: ${{ steps.prep.outputs.tags }}
|
||||
tags: ${{ steps.prep.outputs.tags }}
|
||||
build-args: |
|
||||
medley_release=${{steps.prep.outputs.medley_release}}
|
||||
maiko_release=${{steps.prep.outputs.maiko_release}}
|
||||
build_date=${{steps.prep.outputs.build_time}}
|
||||
|
||||
2
.github/workflows/buildLoadup.yml
vendored
2
.github/workflows/buildLoadup.yml
vendored
@@ -103,4 +103,4 @@ jobs:
|
||||
tag: ${{ env.tag }}
|
||||
draft: true
|
||||
bodyfile: tmp/release-notes.md
|
||||
token: ${{ secrets.GITHUB_TOKEN }}
|
||||
token: ${{ secrets.GITHUB_TOKEN }}
|
||||
|
||||
15
Dockerfile
15
Dockerfile
@@ -1,20 +1,25 @@
|
||||
FROM ubuntu:focal
|
||||
ARG BUILD_DATE
|
||||
ARG build_date
|
||||
ARG medley_release
|
||||
ARG maiko_release
|
||||
LABEL name="Medley"
|
||||
# LABEL tags=${tags}
|
||||
LABEL description="The Medley Interlisp environment"
|
||||
LABEL url="https://github.com/Interlisp/medley"
|
||||
LABEL build-time=$BUILD_DATE
|
||||
LABEL build-time=$build_date
|
||||
ENV BUILD_DATE=$build_date
|
||||
ENV MEDLEY_RELEASE=$medley_release
|
||||
ENV MAIKO_RELEASE=$maiko_release
|
||||
|
||||
RUN apt-get update && apt-get install -y tightvncserver
|
||||
|
||||
EXPOSE 5900
|
||||
|
||||
# Copy and uncompress loadup and required source files.
|
||||
ADD *.tgz /app
|
||||
ADD *.tgz /home
|
||||
|
||||
WORKDIR /app/medley
|
||||
WORKDIR /home/medley
|
||||
|
||||
RUN adduser --disabled-password --gecos "" medley
|
||||
USER medley
|
||||
ENTRYPOINT USER=medley Xvnc -geometry 1280x720 :0 & DISPLAY=:0 PATH="/app/maiko:$PATH" ./run-medley -full -g 1280x720 -sc 1280x720
|
||||
ENTRYPOINT USER=medley Xvnc -geometry 1280x720 :0 & DISPLAY=:0 PATH="/app/maiko:$PATH" ./run-medley -full -g 1280x720 -sc 1280x720
|
||||
|
||||
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.
1193
library/FILEBROWSER
1193
library/FILEBROWSER
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "13-Oct-2021 10:00:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;19 142287
|
||||
(FILECREATED "16-Dec-2021 12:34:26" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;21 142324
|
||||
|
||||
changes to%: (FNS TEDIT-SEE)
|
||||
:CHANGES-TO (FNS TEDIT-SEE)
|
||||
|
||||
previous date%: "11-Oct-2021 14:03:12"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;18)
|
||||
:PREVIOUS-DATE "13-Oct-2021 10:00:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;20)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -27,9 +26,9 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP))
|
||||
(TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU))
|
||||
(* ;
|
||||
"Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")
|
||||
"Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")
|
||||
(* ;
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Changed by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
)
|
||||
(GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
|
||||
(FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT-SEE TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE
|
||||
@@ -40,10 +39,10 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
\TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1)
|
||||
(P (MOVD? 'NILL 'OBJECTOUTOFTEDIT))
|
||||
(* ;
|
||||
"HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
|
||||
"HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
|
||||
(COMS (FNS \CREATE.TEDIT.RESTART.MENU))
|
||||
(* ;
|
||||
"Added by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
"Added by yabu.fx, for SUNLOADUP without DWIM.")
|
||||
(COMS (* ; "Debugging functions")
|
||||
(FNS PLCHAIN PRINTLINE SEEFILE))
|
||||
(COMS (* ; "Object-oriented editing")
|
||||
@@ -56,10 +55,10 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(VARS TEDITSYSTEMDATE (TEDITSUPPORT "TEditSupport.PA"))
|
||||
(FNS MAKETEDITFORM)
|
||||
(P (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM
|
||||
"Report a problem with TEdit"))
|
||||
"Report a problem with TEdit"))
|
||||
(SETQ LAFITEFORMSMENU NIL)))
|
||||
(COMS (* ;
|
||||
"LISTFILES Interface, so the system can decide if a file is a TEdit file.")
|
||||
"LISTFILES Interface, so the system can decide if a file is a TEdit file.")
|
||||
(ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
|
||||
(EXTENSION (TEDIT])
|
||||
|
||||
@@ -330,8 +329,9 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(RETURN PROC])
|
||||
|
||||
(TEDIT-SEE
|
||||
[LAMBDA (FILE WINDOW FORMAT) (* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
[LAMBDA (FILE WINDOW FORMAT TITLE) (* ; "Edited 16-Dec-2021 12:33 by rmk")
|
||||
(* ; "Edited 13-Oct-2021 10:00 by rmk:")
|
||||
(* ; "Edited 27-Feb-2021 20:07 by rmk:")
|
||||
(* ; "Edited 1-Feb-88 19:00 by bvm:")
|
||||
|
||||
(* ;; "See FILE in a scrollable READONLY TEDIT window. If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.")
|
||||
@@ -347,28 +347,25 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(IF (\TEDIT.FORMATTEDP1 STREAM)
|
||||
ELSEIF (LISPSOURCEFILEP STREAM)
|
||||
THEN
|
||||
(* ;; "Lisp source file")
|
||||
|
||||
(* ;; "Lisp source file")
|
||||
|
||||
(SETQ SEESTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT SEESTREAM)
|
||||
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
|
||||
(SETQ SEESTREAM (OPENTEXTSTREAM))
|
||||
(DSPFONT DEFAULTFONT SEESTREAM)
|
||||
(COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
|
||||
ELSE
|
||||
(* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.")
|
||||
|
||||
(* ;; "Not a Lisp source file and not a Tedit file. If it is not random access, we copy it so we can scroll around.")
|
||||
(* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")
|
||||
|
||||
(* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")
|
||||
|
||||
(SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
|
||||
:DEFAULT))
|
||||
(CL:UNLESS (RANDACCESSP STREAM)
|
||||
(SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
|
||||
(COPYCHARS STREAM SEESTREAM)))
|
||||
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL
|
||||
`(READONLY T FONT ,DEFAULTFONT]
|
||||
(WINDOWPROP (WFROMDS TSTREAM)
|
||||
(SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
|
||||
:DEFAULT))
|
||||
(CL:UNLESS (RANDACCESSP STREAM)
|
||||
(SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
|
||||
(COPYCHARS STREAM SEESTREAM)))
|
||||
[SETQ TSTREAM (TEXTSTREAM (TEDIT SEESTREAM WINDOW NIL `(READONLY T FONT ,DEFAULTFONT]
|
||||
[WINDOWPROP (WFROMDS TSTREAM)
|
||||
'TITLE
|
||||
(CONCAT "SEE window for " (FULLNAME STREAM)))
|
||||
(OR TITLE (CONCAT "SEE window for " (FULLNAME STREAM]
|
||||
(FULLNAME STREAM])
|
||||
|
||||
(TEDIT.CHARWIDTH
|
||||
@@ -2236,7 +2233,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* ; "TEDIT Support information")
|
||||
|
||||
|
||||
(RPAQQ TEDITSYSTEMDATE "13-Oct-2021 10:00:40")
|
||||
(RPAQQ TEDITSYSTEMDATE "16-Dec-2021 12:34:26")
|
||||
|
||||
(RPAQ TEDITSUPPORT "TEditSupport.PA")
|
||||
(DEFINEQ
|
||||
@@ -2258,23 +2255,23 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
|
||||
(EXTENSION (TEDIT))))
|
||||
(EXTENSION (TEDIT))))
|
||||
(PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1992 1993 1995 1999 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4330 117453 (\TEDIT2 4340 . 7091) (COERCETEXTOBJ 7093 . 15869) (TEDIT 15871 . 20840) (
|
||||
TEDIT-SEE 20842 . 23129) (TEDIT.CHARWIDTH 23131 . 25155) (TEDIT.COPY 25157 . 33593) (TEDIT.DELETE
|
||||
33595 . 34285) (TEDIT.DO.BLUEPENDINGDELETE 34287 . 37354) (TEDIT.INSERT 37356 . 42886) (TEDIT.KILL
|
||||
42888 . 44445) (TEDIT.MAPLINES 44447 . 45846) (TEDIT.MAPPIECES 45848 . 46804) (TEDIT.MOVE 46806 .
|
||||
56590) (TEDIT.QUIT 56592 . 58592) (TEDIT.STRINGWIDTH 58594 . 59265) (TEDIT.\INSERT 59267 . 61292) (
|
||||
TEXTOBJ 61294 . 62419) (TEXTSTREAM 62421 . 64036) (\TEDIT.INCLUDE 64038 . 67938) (\TEDIT.INSERT.PIECES
|
||||
67940 . 77855) (\TEDIT.MOVE.PIECEMAPFN 77857 . 79936) (\TEDIT.OBJECT.SHOWSEL 79938 . 83567) (
|
||||
\TEDIT.RESTARTFN 83569 . 85564) (\TEDIT.CHARDELETE 85566 . 89528) (\TEDIT.COPY.PIECEMAPFN 89530 .
|
||||
92755) (\TEDIT.DELETE 92757 . 100275) (\TEDIT.DIFFUSE.PARALOOKS 100277 . 103041) (\TEDIT.FOREIGN.COPY?
|
||||
103043 . 106770) (\TEDIT.QUIT 106772 . 109918) (\TEDIT.WORDDELETE 109920 . 114753) (\TEDIT1 114755 .
|
||||
117451)) (117567 117683 (\CREATE.TEDIT.RESTART.MENU 117577 . 117681)) (117782 121471 (PLCHAIN 117792
|
||||
. 118066) (PRINTLINE 118068 . 120832) (SEEFILE 120834 . 121469)) (121512 141155 (TEDIT.INSERT.OBJECT
|
||||
121522 . 130599) (TEDIT.EDIT.OBJECT 130601 . 132857) (TEDIT.FIND.OBJECT 132859 . 133752) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 133754 . 134560) (TEDIT.PUT.OBJECT 134562 . 136221) (TEDIT.GET.OBJECT 136223
|
||||
. 139422) (TEDIT.OBJECT.CHANGED 139424 . 141153)) (141433 141796 (MAKETEDITFORM 141443 . 141794)))))
|
||||
(FILEMAP (NIL (4330 117494 (\TEDIT2 4340 . 7091) (COERCETEXTOBJ 7093 . 15869) (TEDIT 15871 . 20840) (
|
||||
TEDIT-SEE 20842 . 23170) (TEDIT.CHARWIDTH 23172 . 25196) (TEDIT.COPY 25198 . 33634) (TEDIT.DELETE
|
||||
33636 . 34326) (TEDIT.DO.BLUEPENDINGDELETE 34328 . 37395) (TEDIT.INSERT 37397 . 42927) (TEDIT.KILL
|
||||
42929 . 44486) (TEDIT.MAPLINES 44488 . 45887) (TEDIT.MAPPIECES 45889 . 46845) (TEDIT.MOVE 46847 .
|
||||
56631) (TEDIT.QUIT 56633 . 58633) (TEDIT.STRINGWIDTH 58635 . 59306) (TEDIT.\INSERT 59308 . 61333) (
|
||||
TEXTOBJ 61335 . 62460) (TEXTSTREAM 62462 . 64077) (\TEDIT.INCLUDE 64079 . 67979) (\TEDIT.INSERT.PIECES
|
||||
67981 . 77896) (\TEDIT.MOVE.PIECEMAPFN 77898 . 79977) (\TEDIT.OBJECT.SHOWSEL 79979 . 83608) (
|
||||
\TEDIT.RESTARTFN 83610 . 85605) (\TEDIT.CHARDELETE 85607 . 89569) (\TEDIT.COPY.PIECEMAPFN 89571 .
|
||||
92796) (\TEDIT.DELETE 92798 . 100316) (\TEDIT.DIFFUSE.PARALOOKS 100318 . 103082) (\TEDIT.FOREIGN.COPY?
|
||||
103084 . 106811) (\TEDIT.QUIT 106813 . 109959) (\TEDIT.WORDDELETE 109961 . 114794) (\TEDIT1 114796 .
|
||||
117492)) (117608 117724 (\CREATE.TEDIT.RESTART.MENU 117618 . 117722)) (117823 121512 (PLCHAIN 117833
|
||||
. 118107) (PRINTLINE 118109 . 120873) (SEEFILE 120875 . 121510)) (121553 141196 (TEDIT.INSERT.OBJECT
|
||||
121563 . 130640) (TEDIT.EDIT.OBJECT 130642 . 132898) (TEDIT.FIND.OBJECT 132900 . 133793) (
|
||||
TEDIT.FIND.OBJECT.SUBTREE 133795 . 134601) (TEDIT.PUT.OBJECT 134603 . 136262) (TEDIT.GET.OBJECT 136264
|
||||
. 139463) (TEDIT.OBJECT.CHANGED 139465 . 141194)) (141474 141837 (MAKETEDITFORM 141484 . 141835)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "29-Apr-2021 22:44:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;5 275764
|
||||
|
||||
changes to%: (FNS \TEDIT.MENU.INIT)
|
||||
(FILECREATED "26-Oct-2021 08:44:02"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;3 276285
|
||||
|
||||
previous date%: "29-Apr-2021 22:40:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;4)
|
||||
changes to%: (FNS \TEXTMENU.START)
|
||||
|
||||
previous date%: "29-Apr-2021 22:44:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -19,7 +20,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
|
||||
(FILES (LOADCOMP)
|
||||
TEDITDCL))
|
||||
[COMS (* ; "Simple Menu Button support")
|
||||
[COMS (* ; "Simple Menu Button support")
|
||||
(FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN
|
||||
MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MBUTTON.CREATE MBUTTON.CHANGENAME
|
||||
MBUTTON.FIND.BUTTON MBUTTON.FIND.NEXT.BUTTON MBUTTON.FIND.NEXT.FIELD MBUTTON.INIT
|
||||
@@ -31,13 +32,13 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN]
|
||||
[COMS
|
||||
(* ;;
|
||||
"Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")
|
||||
(* ;;
|
||||
"Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")
|
||||
|
||||
(FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN
|
||||
MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (THREESTATE.INIT]
|
||||
[COMS (* ; "One-of-N Menu button sets")
|
||||
[COMS (* ; "One-of-N Menu button sets")
|
||||
(FNS MB.CREATE.NWAYBUTTON MB.NB.DISPLAYFN MB.NB.WHENOPERATEDFN MB.NB.SIZEFN
|
||||
MB.NWAYBUTTON.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS
|
||||
MB.NWAYBUTTON.ADDITEM)
|
||||
@@ -45,7 +46,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN]
|
||||
[COMS
|
||||
(* ;; "Two-state, toggling menu buttons.")
|
||||
(* ;; "Two-state, toggling menu buttons.")
|
||||
|
||||
(FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN
|
||||
\TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT
|
||||
@@ -54,7 +55,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN]
|
||||
[COMS
|
||||
(* ;; "Margin Setting and display")
|
||||
(* ;; "Margin Setting and display")
|
||||
|
||||
(FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN
|
||||
MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK
|
||||
@@ -66,11 +67,11 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT))
|
||||
(ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN]
|
||||
(COMS
|
||||
(* ;; "Text menu creation and support")
|
||||
(* ;; "Text menu creation and support")
|
||||
|
||||
(FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN)
|
||||
(BITMAPS TEXTMENUICON TEXTMENUICONMASK))
|
||||
[COMS (* ; "TEdit-specific support")
|
||||
[COMS (* ; "TEdit-specific support")
|
||||
(FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN
|
||||
\TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN)
|
||||
(FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS
|
||||
@@ -82,7 +83,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
\TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS)
|
||||
(FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING
|
||||
TEDIT.UNPARSE.PAGEFORMAT)
|
||||
(COMS (* ; "Initialization Code")
|
||||
(COMS (* ; "Initialization Code")
|
||||
(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU
|
||||
TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC
|
||||
TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU)
|
||||
@@ -2067,11 +2068,14 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(\TEXTMENU.START
|
||||
[LAMBDA (MENU MAINWINDOW TITLE HEIGHT) (* ;
|
||||
[LAMBDA (MENU MAINWINDOW TITLE HEIGHT) (* ; "Edited 26-Oct-2021 08:43 by rmk:")
|
||||
(* ;
|
||||
"Edited 4-Jun-93 11:59 by sybalsky:mv:envos")
|
||||
|
||||
(* ;; "Create a TEdit-based menu for a given main window.")
|
||||
|
||||
(* ;; "RMK: Add MAX/MINSIZE so menus don't grow vertically when the main window is reshaped. Not sure why HEIGHT is passed in or defaults to 133, but either way, the original window height should persist")
|
||||
|
||||
(PROG ([WREG (COND
|
||||
(MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION))
|
||||
(T (GETREGION]
|
||||
@@ -2104,6 +2108,9 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
||||
(* ;
|
||||
"Mark this as a TEDIT MENU window")
|
||||
(ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE)
|
||||
[SETQ HEIGHT (FETCH (REGION HEIGHT) OF (WINDOWPROP MENUW 'REGION]
|
||||
(WINDOWPROP MENUW 'MAXSIZE (CONS 64000 HEIGHT))
|
||||
(WINDOWPROP MENUW 'MINSIZE (CONS 0 HEIGHT))
|
||||
(SETQ MENUTEXT MENU)
|
||||
(replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
|
||||
with T)
|
||||
@@ -4524,20 +4531,20 @@ MB.CREATE.NWAYBUTTON 43946 . 47914) (MB.NB.DISPLAYFN 47916 . 50188) (MB.NB.WHENO
|
||||
85254 . 88164) (MB.MARGINBAR.SELFN 88166 . 100760) (MB.MARGINBAR.SIZEFN 100762 . 101124) (
|
||||
MB.MARGINBAR.DISPLAYFN 101126 . 103811) (MDESCALE 103813 . 104252) (MSCALE 104254 . 104588) (
|
||||
MB.MARGINBAR.SHOWTAB 104590 . 106761) (MB.MARGINBAR.TABTRACK 106763 . 108098) (\TEDIT.TABTYPE.SET
|
||||
108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130317 (\TEXTMENU.START 112725 . 115917) (
|
||||
\TEXTMENU.DOC.CREATE 115919 . 127443) (TEXTMENU.CLOSEFN 127445 . 130315)) (130627 150691 (
|
||||
\TEDITMENU.CREATE 130637 . 130937) (\TEDIT.EXPANDED.MENU 130939 . 131643) (MB.DEFAULTBUTTON.FN 131645
|
||||
. 134517) (\TEDITMENU.RECORD.UNFORMATTED 134519 . 134857) (MB.DEFAULTBUTTON.ACTIONFN 134859 . 150689)
|
||||
) (150692 178075 (\TEDIT.CHARLOOKSMENU.CREATE 150702 . 152842) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152844
|
||||
. 153218) (\TEDIT.APPLY.BOLDNESS 153220 . 153505) (\TEDIT.APPLY.CHARLOOKS 153507 . 155438) (
|
||||
\TEDIT.APPLY.OLINE 155440 . 155721) (\TEDIT.SHOW.CHARLOOKS 155723 . 157636) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS 157638 . 158564) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158566 . 166219) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166221 . 169104) (\TEDIT.PARSE.CHARLOOKS.MENU 169106 . 177214) (
|
||||
\TEDIT.APPLY.SLOPE 177216 . 177499) (\TEDIT.APPLY.STRIKEOUT 177501 . 177788) (\TEDIT.APPLY.ULINE
|
||||
177790 . 178073)) (178076 210142 (\TEDITPARAMENU.CREATE 178086 . 178466) (\TEDIT.EXPANDEDPARA.MENU
|
||||
178468 . 178788) (\TEDIT.APPLY.PARALOOKS 178790 . 191020) (\TEDIT.SHOW.PARALOOKS 191022 . 202549) (
|
||||
\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202551 . 208622) (\TEDIT.RECORD.TABLEADERS 208624 . 210140)) (210143
|
||||
248145 (\TEDIT.SHOW.PAGEFORMATTING 210153 . 226693) (\TEDITPAGEMENU.CREATE 226695 . 227738) (
|
||||
\TEDIT.APPLY.PAGEFORMATTING 227740 . 240111) (TEDIT.UNPARSE.PAGEFORMAT 240113 . 248143)) (248450
|
||||
275299 (\TEDIT.MENU.INIT 248460 . 275297)))))
|
||||
108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130838 (\TEXTMENU.START 112725 . 116438) (
|
||||
\TEXTMENU.DOC.CREATE 116440 . 127964) (TEXTMENU.CLOSEFN 127966 . 130836)) (131148 151212 (
|
||||
\TEDITMENU.CREATE 131158 . 131458) (\TEDIT.EXPANDED.MENU 131460 . 132164) (MB.DEFAULTBUTTON.FN 132166
|
||||
. 135038) (\TEDITMENU.RECORD.UNFORMATTED 135040 . 135378) (MB.DEFAULTBUTTON.ACTIONFN 135380 . 151210)
|
||||
) (151213 178596 (\TEDIT.CHARLOOKSMENU.CREATE 151223 . 153363) (\TEDIT.EXPANDEDCHARLOOKS.MENU 153365
|
||||
. 153739) (\TEDIT.APPLY.BOLDNESS 153741 . 154026) (\TEDIT.APPLY.CHARLOOKS 154028 . 155959) (
|
||||
\TEDIT.APPLY.OLINE 155961 . 156242) (\TEDIT.SHOW.CHARLOOKS 156244 . 158157) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS 158159 . 159085) (\TEDIT.FILL.IN.CHARLOOKS.MENU 159087 . 166740) (
|
||||
\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166742 . 169625) (\TEDIT.PARSE.CHARLOOKS.MENU 169627 . 177735) (
|
||||
\TEDIT.APPLY.SLOPE 177737 . 178020) (\TEDIT.APPLY.STRIKEOUT 178022 . 178309) (\TEDIT.APPLY.ULINE
|
||||
178311 . 178594)) (178597 210663 (\TEDITPARAMENU.CREATE 178607 . 178987) (\TEDIT.EXPANDEDPARA.MENU
|
||||
178989 . 179309) (\TEDIT.APPLY.PARALOOKS 179311 . 191541) (\TEDIT.SHOW.PARALOOKS 191543 . 203070) (
|
||||
\TEDIT.NEUTRALIZE.PARALOOKS.MENU 203072 . 209143) (\TEDIT.RECORD.TABLEADERS 209145 . 210661)) (210664
|
||||
248666 (\TEDIT.SHOW.PAGEFORMATTING 210674 . 227214) (\TEDITPAGEMENU.CREATE 227216 . 228259) (
|
||||
\TEDIT.APPLY.PAGEFORMATTING 228261 . 240632) (TEDIT.UNPARSE.PAGEFORMAT 240634 . 248664)) (248971
|
||||
275820 (\TEDIT.MENU.INIT 248981 . 275818)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
688
library/TEXTOFD
688
library/TEXTOFD
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "12-Oct-2021 15:38:41"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEXTOFD.;4 176302
|
||||
(FILECREATED "22-Dec-2021 10:29:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;12 182752
|
||||
|
||||
changes to%: (FNS \TEDITOUTCCODEFN)
|
||||
:CHANGES-TO (FNS \TEXTBIN \TEXTPEEKBIN)
|
||||
|
||||
previous date%: " 7-Oct-2021 08:41:13"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEXTOFD.;3)
|
||||
:PREVIOUS-DATE "22-Dec-2021 10:01:53"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;11)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -31,7 +30,7 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(FNS \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE
|
||||
\INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE))
|
||||
(COMS (* ;
|
||||
"Generic-IO type operations support")
|
||||
"Generic-IO type operations support")
|
||||
(FNS \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR
|
||||
\TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR
|
||||
\TEXTBOUT \TEDITOUTCCODEFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION
|
||||
@@ -1913,214 +1912,248 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(DEFINEQ
|
||||
|
||||
(\TEXTBIN
|
||||
[LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:33 by jds")
|
||||
[LAMBDA (STREAM)
|
||||
|
||||
(* ;; "Edited 22-Dec-2021 10:29 by rmk: Return value of OBJECTCHAR property for image objecdts")
|
||||
|
||||
(* ;; "Edited 28-Mar-94 15:33 by jds")
|
||||
|
||||
(* ;;; "Do BIN slow case for a text stream")
|
||||
(* ;
|
||||
"NB that PEEKBIN and BACKFILEPTR need to track changes in this code")
|
||||
"NB that PEEKBIN and BACKFILEPTR need to track changes in this code")
|
||||
(DECLARE (LOCALVARS . T))
|
||||
(PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(LET (BYTE) (* ;
|
||||
"RMK: Capture all return values for any special imageobject coercion")
|
||||
[SETQ BYTE (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(* ;
|
||||
"Simple case -- just do the usual BIN")
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) of STREAM
|
||||
)))
|
||||
"Simple case -- just do the usual BIN")
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
|
||||
of STREAM)))
|
||||
(* ; "Handle objects specially")
|
||||
(COND
|
||||
((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
|
||||
(COND
|
||||
((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
|
||||
(* ;
|
||||
"If this object has a substream in it, go to that substream")
|
||||
(add (fetch (STREAM COFFSET) of STREAM)
|
||||
1)
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T
|
||||
(* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")
|
||||
"If this object has a substream in it, go to that substream")
|
||||
(add (fetch (STREAM COFFSET) of STREAM)
|
||||
1)
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T
|
||||
(* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")
|
||||
|
||||
(replace (STREAM COFFSET) of STREAM with (fetch (STREAM
|
||||
CBUFSIZE)
|
||||
of STREAM))
|
||||
(replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
|
||||
(RETURN PO]
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(replace (STREAM COFFSET) of STREAM
|
||||
with (fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
|
||||
(RETURN PO]
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(* ;
|
||||
"This is a 16 bit BIN. grab 2 bytes.")
|
||||
"This is a 16 bit BIN. grab 2 bytes.")
|
||||
(* ;
|
||||
"WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")
|
||||
(RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(COND
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
"WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")
|
||||
(RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(COND
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(* ;
|
||||
"This pair of characters doesn't straddle a file page bound. Just grab the next char.")
|
||||
(\PAGEDBIN STREAM))
|
||||
(T (* ;
|
||||
"Need to move to the next page on the backing file. Doing so also grabs the next character.")
|
||||
(\TEDIT.TEXTBIN.NEW.PAGE STREAM T]
|
||||
(T (RETURN (\PAGEDBIN STREAM]
|
||||
(T (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
"This pair of characters doesn't straddle a file page bound. Just grab the next char.")
|
||||
(\PAGEDBIN STREAM))
|
||||
(T (* ;
|
||||
"Need to move to the next page on the backing file. Doing so also grabs the next character.")
|
||||
(\TEDIT.TEXTBIN.NEW.PAGE STREAM T]
|
||||
(T (RETURN (\PAGEDBIN STREAM]
|
||||
(T (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
(* ; "Time for a new piece.")
|
||||
[repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN) of PC)))
|
||||
do (* ;
|
||||
"Skip over any zero-length pieces at the end of the file.")
|
||||
(SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (AND OPC (fetch (PIECE NEXTPIECE)
|
||||
of OPC]
|
||||
(replace (STREAM BINABLE) of STREAM with T)
|
||||
(replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
|
||||
[repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN)
|
||||
of PC)))
|
||||
do (* ;
|
||||
"Skip over any zero-length pieces at the end of the file.")
|
||||
(SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (AND OPC (fetch (PIECE NEXTPIECE)
|
||||
of OPC]
|
||||
(replace (STREAM BINABLE) of STREAM with T)
|
||||
(replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
|
||||
(* ;
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (* ;
|
||||
"There IS a next piece to move to.")
|
||||
(AND (fetch (TEXTSTREAM LOOKSUPDATEFN) of STREAM)
|
||||
(SETQ NPC (APPLY* (fetch (TEXTSTREAM LOOKSUPDATEFN)
|
||||
of STREAM)
|
||||
STREAM PC))
|
||||
(replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (SETQ PC NPC)))
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (* ; "There IS a next piece to move to.")
|
||||
(AND (fetch (TEXTSTREAM LOOKSUPDATEFN)
|
||||
of STREAM)
|
||||
(SETQ NPC (APPLY* (fetch (TEXTSTREAM
|
||||
LOOKSUPDATEFN
|
||||
)
|
||||
of STREAM)
|
||||
STREAM PC))
|
||||
(replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (SETQ PC NPC)))
|
||||
(* ;
|
||||
"Take care of any piece-change uproar. uproar -- which may include picking a new piece to go to.")
|
||||
[COND
|
||||
(NPC (* ;
|
||||
"If we got an NPC, this was taken care of by the LOOKSUPDATEFN")
|
||||
)
|
||||
([AND (SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM]
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS) of
|
||||
SUBSTREAM
|
||||
)))
|
||||
[(NEQ (fetch (PIECE PPARALOOKS) of OPC)
|
||||
(fetch (PIECE PPARALOOKS) of PC))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.PARASTYLES (fetch (PIECE
|
||||
PPARALOOKS
|
||||
)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
((NOT (EQCLOOKS (fetch (PIECE PLOOKS) of PC)
|
||||
(fetch (PIECE PLOOKS) of OPC)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
(COND
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
"Take care of any piece-change uproar. uproar -- which may include picking a new piece to go to.")
|
||||
[COND
|
||||
(NPC (* ;
|
||||
"If we got an NPC, this was taken care of by the LOOKSUPDATEFN")
|
||||
)
|
||||
([AND (SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(SETQ SUBSTREAM (IMAGEOBJPROP
|
||||
PO
|
||||
'SUBSTREAM]
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
) of SUBSTREAM
|
||||
))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
CURRENTLOOKS)
|
||||
of SUBSTREAM)))
|
||||
[(NEQ (fetch (PIECE PPARALOOKS) of OPC)
|
||||
(fetch (PIECE PPARALOOKS) of PC))
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (\TEDIT.APPLY.PARASTYLES
|
||||
(fetch (PIECE PPARALOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM with (\TEDIT.APPLY.STYLES
|
||||
(fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
((NOT (EQCLOOKS (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
(fetch (PIECE PLOOKS) of OPC)))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM with (\TEDIT.APPLY.STYLES
|
||||
(fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM]
|
||||
(COND
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
(* ; "This piece lives in a string.")
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PS)
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP
|
||||
0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PS)
|
||||
|
||||
(* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
|
||||
(* ;
|
||||
"Then actually grab the next character to hand back to the caller.")
|
||||
(\BIN STREAM))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
"Then actually grab the next character to hand back to the caller.")
|
||||
(\BIN STREAM))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
(* ; "This piece lives on a file.")
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PF (fetch (PIECE PFATP) of PC)
|
||||
'PEEKBIN)
|
||||
(\BIN STREAM))
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (STREAM COFFSET) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM
|
||||
with 0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
|
||||
CURRENTPARALOOKS
|
||||
) of
|
||||
SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(RETURN PO]
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(T (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(COND
|
||||
((fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PF (fetch (PIECE PFATP)
|
||||
of PC)
|
||||
'PEEKBIN)
|
||||
(\BIN STREAM))
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM
|
||||
with NIL)
|
||||
(COND
|
||||
(SUBSTREAM
|
||||
(* ;
|
||||
"If there's an EOF handler, call it & return the result")
|
||||
(RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM
|
||||
)
|
||||
STREAM)))
|
||||
(T (* ; "Otherwise, return NIL")
|
||||
(RETURN NIL]
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
|
||||
of STREAM)))
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM
|
||||
TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (STREAM COFFSET)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM
|
||||
with (fetch (PIECE PLEN)
|
||||
of PC))
|
||||
(freplace (STREAM CBUFSIZE)
|
||||
of STREAM
|
||||
with (fetch (PIECE PLEN)
|
||||
of PC))
|
||||
(freplace (STREAM CPAGE)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG)
|
||||
of STREAM with 0)
|
||||
(replace (TEXTSTREAM
|
||||
CURRENTPARALOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
) of SUBSTREAM
|
||||
))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM with 0)
|
||||
(RETURN PO]
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(T (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(COND
|
||||
((fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
(* ;
|
||||
"If there's an EOF handler, call it & return the result")
|
||||
(RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP)
|
||||
of STREAM)
|
||||
STREAM)))
|
||||
(T (* ; "Otherwise, return NIL")
|
||||
(RETURN NIL]
|
||||
[(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
|
||||
of STREAM)))
|
||||
(* ; "This is an object")
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of
|
||||
SUBSTREAM))
|
||||
(freplace (STREAM COFFSET) of STREAM with 1)
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM with
|
||||
0)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM with
|
||||
1)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM with
|
||||
0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS) of
|
||||
SUBSTREAM
|
||||
))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
|
||||
(RETURN PO]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM])
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (STREAM COFFSET) of STREAM
|
||||
with 1)
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM
|
||||
with 1)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM
|
||||
with 0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
) of SUBSTREAM)
|
||||
)
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(RETURN PO]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM]
|
||||
(IF (IMAGEOBJP BYTE)
|
||||
THEN (OR (GETTEXTPROP (FETCH (TEXTSTREAM TEXTOBJ) OF STREAM)
|
||||
'OBJECTBYTE)
|
||||
BYTE)
|
||||
ELSE BYTE])
|
||||
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP
|
||||
[LAMBDA (CHOFFSET CHARSLEFT STREAM PS) (* ; "Edited 31-May-91 14:21 by jds")
|
||||
@@ -2353,123 +2386,144 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(DEFINEQ
|
||||
|
||||
(\TEXTPEEKBIN
|
||||
[LAMBDA (STREAM NOERRORFLG) (* ; "Edited 28-Mar-94 15:34 by jds")
|
||||
[LAMBDA (STREAM NOERRORFLG)
|
||||
|
||||
(* ;; "Edited 22-Dec-2021 10:29 by rmk: Return OBJECTCHAR for image objects, if present")
|
||||
|
||||
(* ;; "Edited 28-Mar-94 15:34 by jds")
|
||||
(* ; "DO PEEKBIN for a text stream")
|
||||
(PROG (CH FILE STR PF PS PC PO SUBSTREAM)
|
||||
(SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(LET (BYTE) (* ;
|
||||
"BYTE to capture all returns for imageobject coercion")
|
||||
[SETQ BYTE (PROG (CH FILE STR PF PS PC PO SUBSTREAM)
|
||||
(SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM))
|
||||
(COND
|
||||
[(ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(fetch (STREAM CBUFSIZE) of STREAM))
|
||||
(* ;
|
||||
"Simple case -- just do the usual PEEKBIN")
|
||||
(COND
|
||||
((AND PC (fetch (PIECE POBJ) of PC))
|
||||
(RETURN (fetch (PIECE POBJ) of PC)))
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(* ;
|
||||
"This is a 16 bit PEEKBIN. Grab two chars...")
|
||||
(RETURN (COND
|
||||
[(\EOFP STREAM)
|
||||
"Simple case -- just do the usual PEEKBIN")
|
||||
(COND
|
||||
(NOERRORFLG NIL)
|
||||
(T (\PEEKBIN STREAM]
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(SUB1 (fetch (STREAM CBUFSIZE) of STREAM)))
|
||||
((AND PC (SETQ PO (fetch (PIECE POBJ) of PC)))
|
||||
(RETURN PO))
|
||||
[(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
|
||||
(* ;
|
||||
"We're sure of staying on the same page. Just grab the characters")
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(\PAGEDPEEKBIN STREAM NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR STREAM)))
|
||||
(T (SETQ PS (fetch (STREAM F1) of STREAM))
|
||||
(replace (STREAM COFFSET) of PS with (fetch
|
||||
(STREAM COFFSET)
|
||||
of STREAM))
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
|
||||
256)
|
||||
(\PAGEDPEEKBIN PS NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR PS]
|
||||
(T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
|
||||
[PC (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
"This is a 16 bit PEEKBIN. Grab two chars...")
|
||||
(RETURN (COND
|
||||
[(\EOFP STREAM)
|
||||
(COND
|
||||
(NOERRORFLG NIL)
|
||||
(T (\PEEKBIN STREAM]
|
||||
((ILESSP (fetch (STREAM COFFSET) of STREAM)
|
||||
(SUB1 (fetch (STREAM CBUFSIZE) of STREAM)))
|
||||
(* ;
|
||||
"We're sure of staying on the same page. Just grab the characters")
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
|
||||
256)
|
||||
(\PAGEDPEEKBIN STREAM NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR STREAM)))
|
||||
(T (SETQ PS (fetch (STREAM F1) of STREAM))
|
||||
(replace (STREAM COFFSET) of PS
|
||||
with (fetch (STREAM COFFSET) of STREAM))
|
||||
(PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
|
||||
256)
|
||||
(\PAGEDPEEKBIN PS NOERRORFLG))
|
||||
(\PAGEDBACKFILEPTR PS]
|
||||
(T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
|
||||
[PC (* ;
|
||||
"We've either hit a page bound in a file, or a piece bound.")
|
||||
(RETURN (COND
|
||||
[(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
|
||||
(* ; "Time for a new piece.")
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (fetch (PIECE NEXTPIECE) of PC)))
|
||||
(SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
|
||||
with (fetch (PIECE NEXTPIECE) of PC)))
|
||||
(* ;
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ) of STREAM)
|
||||
))
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM with NIL)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM COFFSET) of STREAM with 0)
|
||||
(COND
|
||||
(SUBSTREAM (* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM CPAGE) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH) of STREAM
|
||||
with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG) of STREAM
|
||||
with 0)
|
||||
(replace (TEXTSTREAM CURRENTPARALOOKS)
|
||||
of STREAM with (fetch (TEXTSTREAM
|
||||
|
||||
"Move to the next piece in the chain")
|
||||
(COND
|
||||
[PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
|
||||
with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS
|
||||
)
|
||||
of PC)
|
||||
PC
|
||||
(fetch (TEXTSTREAM TEXTOBJ)
|
||||
of STREAM)))
|
||||
(COND
|
||||
[(SETQ PO (fetch (PIECE POBJ) of PC))
|
||||
(replace (STREAM BINABLE) of STREAM
|
||||
with NIL)
|
||||
(freplace (STREAM CBUFSIZE) of STREAM
|
||||
with (fetch (PIECE PLEN) of PC))
|
||||
(freplace (STREAM COFFSET) of STREAM
|
||||
with 0)
|
||||
(COND
|
||||
(SUBSTREAM
|
||||
(* ;
|
||||
"There is a stream below this one, to feed chars upward.")
|
||||
(\SETUPGETCH 1 (fetch (TEXTSTREAM
|
||||
TEXTOBJ)
|
||||
of SUBSTREAM))
|
||||
(freplace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM
|
||||
with (fetch (PIECE PLEN)
|
||||
of PC))
|
||||
(freplace (STREAM CPAGE)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTCH)
|
||||
of STREAM with 0)
|
||||
(freplace (TEXTSTREAM PCSTARTPG)
|
||||
of STREAM with 0)
|
||||
(replace (TEXTSTREAM
|
||||
CURRENTPARALOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTPARALOOKS
|
||||
)
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS) of
|
||||
STREAM
|
||||
with (fetch (TEXTSTREAM CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT) of STREAM
|
||||
with 0)
|
||||
(RETURN PO]
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
of SUBSTREAM))
|
||||
(replace (TEXTSTREAM CURRENTLOOKS)
|
||||
of STREAM
|
||||
with (fetch (TEXTSTREAM
|
||||
CURRENTLOOKS)
|
||||
of SUBSTREAM))
|
||||
(RETURN (\BIN SUBSTREAM)))
|
||||
(T (replace (TEXTSTREAM CHARSLEFT)
|
||||
of STREAM with 0)
|
||||
(RETURN PO]
|
||||
((SETQ PS (fetch (PIECE PSTR) of PC))
|
||||
(* ; "This piece lives in a string.")
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PS)
|
||||
(\TEDIT.TEXTBIN.STRINGSETUP
|
||||
0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PS)
|
||||
|
||||
(* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
|
||||
|
||||
(\PEEKBIN STREAM NOERRORFLG))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
(\PEEKBIN STREAM NOERRORFLG))
|
||||
((SETQ PF (fetch (PIECE PFILE) of PC))
|
||||
(* ; "This piece lives on a file.")
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN)
|
||||
of PC)
|
||||
STREAM PF (fetch (PIECE PFATP) of PC)
|
||||
'PEEKBIN NOERRORFLG))
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM])
|
||||
(\TEDIT.TEXTBIN.FILESETUP PC 0
|
||||
(fetch (PIECE PLEN) of PC)
|
||||
STREAM PF (fetch (PIECE PFATP)
|
||||
of PC)
|
||||
'PEEKBIN NOERRORFLG))
|
||||
(T (ERROR "CAN'T GET TO NEXT PIECE"]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM]
|
||||
(T (* ;
|
||||
"Need to move to the next page in a file.")
|
||||
(RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG]
|
||||
(NOERRORFLG (* ;
|
||||
"There are no more pieces. Punt gracefully")
|
||||
(RETURN NIL))
|
||||
(T (* ; "He wants it the hard way.")
|
||||
(APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
|
||||
STREAM]
|
||||
(IF (IMAGEOBJP BYTE)
|
||||
THEN (OR (GETTEXTPROP (FETCH (TEXTSTREAM TEXTOBJ) OF STREAM)
|
||||
'OBJECTBYTE)
|
||||
BYTE)
|
||||
ELSE BYTE])
|
||||
|
||||
(\TEDIT.PEEKBIN.NEW.PAGE
|
||||
[LAMBDA (STREAM NOERRORFLG) (* ; "Edited 11-Jun-99 15:11 by rmk:")
|
||||
@@ -2667,25 +2721,25 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
|
||||
(PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989
|
||||
1990 1991 1993 1994 1995 1999 2000 2001 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2989 53114 (COPYTEXTSTREAM 2999 . 6121) (OPENTEXTSTREAM 6123 . 21000) (REOPENTEXTSTREAM
|
||||
21002 . 21424) (TEDIT.STREAMCHANGEDP 21426 . 21724) (TEXTSTREAMP 21726 . 22040) (TXTFILE 22042 .
|
||||
22487) (\DELETECH 22489 . 33745) (\SETUPGETCH 33747 . 41026) (\TEDIT.REOPEN.STREAM 41028 . 42878) (
|
||||
\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42880 . 45318) (\TEXTINIT 45320 . 51007) (\TEXTMARK 51009 . 51757) (
|
||||
\TEXTTTYBOUT 51759 . 53112)) (53115 78547 (\INSERTCH 53125 . 76851) (\INSERTCR 76853 . 78545)) (78613
|
||||
98929 (\CHTOPC 78623 . 79812) (\CHTOPCNO 79814 . 81076) (\CLEARPCTB 81078 . 81874) (
|
||||
\CREATEPIECEORSTREAM 81876 . 84850) (\DELETEPIECE 84852 . 85765) (\FINDPIECE 85767 . 86133) (
|
||||
\INSERTPIECE 86135 . 89145) (\MAKEPCTB 89147 . 91062) (\SPLITPIECE 91064 . 98023) (\INSERT.FIRST.PIECE
|
||||
98025 . 98927)) (98981 123219 (\TEXTCLOSEF 98991 . 100218) (\TEXTCLOSEF-SUBTREE 100220 . 100926) (
|
||||
\TEXTDSPFONT 100928 . 101920) (\TEXTEOFP 101922 . 103281) (\TEXTGETEOFPTR 103283 . 103493) (
|
||||
\TEXTGETFILEPTR 103495 . 105558) (\TEXTOPENF 105560 . 106390) (\TEXTOPENF-SUBTREE 106392 . 107193) (
|
||||
\TEXTOUTCHARFN 107195 . 107543) (\TEXTBACKFILEPTR 107545 . 113446) (\TEXTBOUT 113448 . 116796) (
|
||||
\TEDITOUTCCODEFN 116798 . 118064) (\TEXTSETEOF 118066 . 118575) (\TEXTSETFILEPTR 118577 . 119802) (
|
||||
\TEXTDSPXPOSITION 119804 . 120661) (\TEXTDSPYPOSITION 120663 . 121208) (\TEXTLEFTMARGIN 121210 .
|
||||
121693) (\TEXTRIGHTMARGIN 121695 . 122631) (\TEXTDSPCHARWIDTH 122633 . 122871) (\TEXTDSPSTRINGWIDTH
|
||||
122873 . 123113) (\TEXTDSPLINEFEED 123115 . 123217)) (123220 156964 (\TEXTBIN 123230 . 140016) (
|
||||
\TEDIT.TEXTBIN.STRINGSETUP 140018 . 145731) (\TEDIT.TEXTBIN.FILESETUP 145733 . 152119) (
|
||||
\TEDIT.TEXTBIN.NEW.PAGE 152121 . 156962)) (156965 170373 (\TEXTPEEKBIN 156975 . 166114) (
|
||||
\TEDIT.PEEKBIN.NEW.PAGE 166116 . 170371)) (170411 175629 (CGETTEXTPROP 170421 . 170897) (CTEXTPROP
|
||||
170899 . 173243) (GETTEXTPROP 173245 . 173840) (PUTTEXTPROP 173842 . 175167) (TEXTPROP 175169 . 175627
|
||||
(FILEMAP (NIL (2992 53117 (COPYTEXTSTREAM 3002 . 6124) (OPENTEXTSTREAM 6126 . 21003) (REOPENTEXTSTREAM
|
||||
21005 . 21427) (TEDIT.STREAMCHANGEDP 21429 . 21727) (TEXTSTREAMP 21729 . 22043) (TXTFILE 22045 .
|
||||
22490) (\DELETECH 22492 . 33748) (\SETUPGETCH 33750 . 41029) (\TEDIT.REOPEN.STREAM 41031 . 42881) (
|
||||
\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42883 . 45321) (\TEXTINIT 45323 . 51010) (\TEXTMARK 51012 . 51760) (
|
||||
\TEXTTTYBOUT 51762 . 53115)) (53118 78550 (\INSERTCH 53128 . 76854) (\INSERTCR 76856 . 78548)) (78616
|
||||
98932 (\CHTOPC 78626 . 79815) (\CHTOPCNO 79817 . 81079) (\CLEARPCTB 81081 . 81877) (
|
||||
\CREATEPIECEORSTREAM 81879 . 84853) (\DELETEPIECE 84855 . 85768) (\FINDPIECE 85770 . 86136) (
|
||||
\INSERTPIECE 86138 . 89148) (\MAKEPCTB 89150 . 91065) (\SPLITPIECE 91067 . 98026) (\INSERT.FIRST.PIECE
|
||||
98028 . 98930)) (98984 123222 (\TEXTCLOSEF 98994 . 100221) (\TEXTCLOSEF-SUBTREE 100223 . 100929) (
|
||||
\TEXTDSPFONT 100931 . 101923) (\TEXTEOFP 101925 . 103284) (\TEXTGETEOFPTR 103286 . 103496) (
|
||||
\TEXTGETFILEPTR 103498 . 105561) (\TEXTOPENF 105563 . 106393) (\TEXTOPENF-SUBTREE 106395 . 107196) (
|
||||
\TEXTOUTCHARFN 107198 . 107546) (\TEXTBACKFILEPTR 107548 . 113449) (\TEXTBOUT 113451 . 116799) (
|
||||
\TEDITOUTCCODEFN 116801 . 118067) (\TEXTSETEOF 118069 . 118578) (\TEXTSETFILEPTR 118580 . 119805) (
|
||||
\TEXTDSPXPOSITION 119807 . 120664) (\TEXTDSPYPOSITION 120666 . 121211) (\TEXTLEFTMARGIN 121213 .
|
||||
121696) (\TEXTRIGHTMARGIN 121698 . 122634) (\TEXTDSPCHARWIDTH 122636 . 122874) (\TEXTDSPSTRINGWIDTH
|
||||
122876 . 123116) (\TEXTDSPLINEFEED 123118 . 123220)) (123223 161060 (\TEXTBIN 123233 . 144112) (
|
||||
\TEDIT.TEXTBIN.STRINGSETUP 144114 . 149827) (\TEDIT.TEXTBIN.FILESETUP 149829 . 156215) (
|
||||
\TEDIT.TEXTBIN.NEW.PAGE 156217 . 161058)) (161061 176823 (\TEXTPEEKBIN 161071 . 172564) (
|
||||
\TEDIT.PEEKBIN.NEW.PAGE 172566 . 176821)) (176861 182079 (CGETTEXTPROP 176871 . 177347) (CTEXTPROP
|
||||
177349 . 179693) (GETTEXTPROP 179695 . 180290) (PUTTEXTPROP 180292 . 181617) (TEXTPROP 181619 . 182077
|
||||
)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -1,15 +1,16 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "14-Feb-2021 23:11:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;5 64800
|
||||
|
||||
changes to%: (VARS DINFOCOMS)
|
||||
(FILECREATED "25-Oct-2021 23:24:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;2 65213
|
||||
|
||||
previous date%: "14-Feb-2021 14:55:19"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;4)
|
||||
changes to%: (FNS DINFO.CREATE.FMENU)
|
||||
|
||||
previous date%: "14-Feb-2021 23:11:36"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
Copyright (c) 1985-1987, 2020-2021 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DINFOCOMS)
|
||||
@@ -19,24 +20,24 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DINFOGRAPH DINFONODE)
|
||||
(FUNCTIONS DINFOGRAPHPROP))
|
||||
(INITRECORDS DINFOGRAPH)
|
||||
(FNS (* ; "Primary functions")
|
||||
(FNS (* ; "Primary functions")
|
||||
DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH
|
||||
DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP)
|
||||
(FNS (* ; "Koto compatability")
|
||||
(FNS (* ; "Koto compatability")
|
||||
DINFO.READ.KOTO.GRAPH)
|
||||
(FNS (* ; "Window functions")
|
||||
(FNS (* ; "Window functions")
|
||||
DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN)
|
||||
(FNS (* ; "FreeMenu functions")
|
||||
(FNS (* ; "FreeMenu functions")
|
||||
DINFO.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER
|
||||
DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY
|
||||
DINFO.TOGGLE.TEXT)
|
||||
(FNS (* ; "Other menu functions")
|
||||
(FNS (* ; "Other menu functions")
|
||||
DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY
|
||||
DINFO.HISTORIC.UPDATE)
|
||||
(FNS (* ; "Interface to GRAPHER")
|
||||
(FNS (* ; "Interface to GRAPHER")
|
||||
DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW
|
||||
DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH)
|
||||
(FNS (* ; "Interface to TEdit")
|
||||
(FNS (* ; "Interface to TEdit")
|
||||
DINFO.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL
|
||||
DINFO.GET.FILENAME)
|
||||
(ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH)
|
||||
@@ -539,14 +540,17 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
(DINFO.UPDATE.FMENU GRAPH])
|
||||
|
||||
(DINFO.CREATE.FMENU
|
||||
[LAMBDA (GRAPH) (* jow "15-Jul-86 17:39")
|
||||
|
||||
(* * Makes a DInfo FreeMenu for GRAPH)
|
||||
[LAMBDA (GRAPH) (* ; "Edited 25-Oct-2021 23:23 by rmk:")
|
||||
(* jow "15-Jul-86 17:39")
|
||||
|
||||
(* ;;; "Makes a DInfo FreeMenu for GRAPH")
|
||||
|
||||
(* ;; "RMK: Added MINSIZE and MAXSIZE so that the menu doesn't get distorted during reshaping")
|
||||
|
||||
(LET* [(ADD.ITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH))
|
||||
(FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH))
|
||||
MENUFONT))
|
||||
(FM (FREEMENU `((PROPS FONT %, FONT)
|
||||
[FM (FREEMENU `((PROPS FONT %, FONT)
|
||||
((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10))
|
||||
(ID NODE LABEL "" TYPE DISPLAY))
|
||||
((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD)
|
||||
@@ -585,8 +589,12 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
(HELVETICA 10 BOLD)
|
||||
MESSAGE
|
||||
"Lookup a term in this graph. LEFT for new term, MIDDLE to repeat last."
|
||||
)) ADD.ITEMS]
|
||||
))
|
||||
ADD.ITEMS]
|
||||
(HEIGHT (FETCH (REGION HEIGHT) OF (WINDOWPROP FM 'REGION]
|
||||
(WINDOWPROP FM 'FM.DONTRESHAPE T)
|
||||
(WINDOWPROP FM 'MINSIZE (CONS 0 HEIGHT))
|
||||
(WINDOWPROP FM 'MAXSIZE (CONS 64000 HEIGHT))
|
||||
FM])
|
||||
|
||||
(DINFO.FMW.CLOSEFN
|
||||
@@ -1110,20 +1118,20 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987 2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7732 24558 (DINFO 7742 . 9356) (DINFO.UPDATE 9358 . 12222) (DINFOGRAPH 12224 . 12642) (
|
||||
DINFO.SPECIAL.UPDATE 12644 . 14342) (DINFO.READ.GRAPH 14344 . 16199) (DINFO.WRITE.GRAPH 16201 . 17291)
|
||||
(DINFO.SELECT.GRAPH 17293 . 18200) (DINFO.DEFAULT.MENU 18202 . 20726) (DINFO.FIND 20728 . 23112) (
|
||||
DINFO.LOOKUP 23114 . 24556)) (24559 27253 (DINFO.READ.KOTO.GRAPH 24569 . 27251)) (27254 29568 (
|
||||
DINFO.SETUP.WINDOW 27264 . 27945) (DINFO.CLOSEFN 27947 . 28380) (DINFO.SHRINKFN 28382 . 28578) (
|
||||
DINFO.EXPANDFN 28580 . 29137) (DINFO.ICONFN 29139 . 29566)) (29569 40417 (DINFO.ADD.FMENU 29579 .
|
||||
30674) (DINFO.CREATE.FMENU 30676 . 34213) (DINFO.FMW.CLOSEFN 34215 . 35060) (DINFO.FMENU.HANDLER 35062
|
||||
. 35701) (DINFO.UPDATE.FMENU 35703 . 37908) (DINFO.TOGGLE.MENU 37910 . 38500) (DINFO.TOGGLE.GRAPH
|
||||
38502 . 39001) (DINFO.TOGGLE.HISTORY 39003 . 39547) (DINFO.TOGGLE.TEXT 39549 . 40415)) (40418 48116 (
|
||||
DINFO.UPDATE.MENU.DISPLAY 40428 . 44448) (DINFO.UPDATE.FROM.MENU 44450 . 44749) (DINFO.UPDATE.HISTORY
|
||||
44751 . 47285) (DINFO.HISTORIC.UPDATE 47287 . 48114)) (48117 58283 (DINFO.UPDATE.GRAPH.DISPLAY 48127
|
||||
. 49445) (DINFO.UPDATE.FROM.GRAPH 49447 . 49890) (DINFO.GET.GRAPH.WINDOW 49892 . 50477) (
|
||||
DINFO.CREATE.GRAPH.WINDOW 50479 . 51596) (DINFO.SHOWGRAPH 51598 . 53323) (DINFO.INVERT.NODE 53325 .
|
||||
54713) (DINFO.LAYOUTGRAPH 54715 . 58281)) (58284 64140 (DINFO.UPDATE.TEXT.DISPLAY 58294 . 60155) (
|
||||
DINFO.TITLEMENUFN 60157 . 61282) (DINFO.OPENTEXTSTREAM 61284 . 62500) (DINFO.SHOWSEL 62502 . 63235) (
|
||||
DINFO.GET.FILENAME 63237 . 64138)))))
|
||||
(FILEMAP (NIL (7733 24559 (DINFO 7743 . 9357) (DINFO.UPDATE 9359 . 12223) (DINFOGRAPH 12225 . 12643) (
|
||||
DINFO.SPECIAL.UPDATE 12645 . 14343) (DINFO.READ.GRAPH 14345 . 16200) (DINFO.WRITE.GRAPH 16202 . 17292)
|
||||
(DINFO.SELECT.GRAPH 17294 . 18201) (DINFO.DEFAULT.MENU 18203 . 20727) (DINFO.FIND 20729 . 23113) (
|
||||
DINFO.LOOKUP 23115 . 24557)) (24560 27254 (DINFO.READ.KOTO.GRAPH 24570 . 27252)) (27255 29569 (
|
||||
DINFO.SETUP.WINDOW 27265 . 27946) (DINFO.CLOSEFN 27948 . 28381) (DINFO.SHRINKFN 28383 . 28579) (
|
||||
DINFO.EXPANDFN 28581 . 29138) (DINFO.ICONFN 29140 . 29567)) (29570 40830 (DINFO.ADD.FMENU 29580 .
|
||||
30675) (DINFO.CREATE.FMENU 30677 . 34626) (DINFO.FMW.CLOSEFN 34628 . 35473) (DINFO.FMENU.HANDLER 35475
|
||||
. 36114) (DINFO.UPDATE.FMENU 36116 . 38321) (DINFO.TOGGLE.MENU 38323 . 38913) (DINFO.TOGGLE.GRAPH
|
||||
38915 . 39414) (DINFO.TOGGLE.HISTORY 39416 . 39960) (DINFO.TOGGLE.TEXT 39962 . 40828)) (40831 48529 (
|
||||
DINFO.UPDATE.MENU.DISPLAY 40841 . 44861) (DINFO.UPDATE.FROM.MENU 44863 . 45162) (DINFO.UPDATE.HISTORY
|
||||
45164 . 47698) (DINFO.HISTORIC.UPDATE 47700 . 48527)) (48530 58696 (DINFO.UPDATE.GRAPH.DISPLAY 48540
|
||||
. 49858) (DINFO.UPDATE.FROM.GRAPH 49860 . 50303) (DINFO.GET.GRAPH.WINDOW 50305 . 50890) (
|
||||
DINFO.CREATE.GRAPH.WINDOW 50892 . 52009) (DINFO.SHOWGRAPH 52011 . 53736) (DINFO.INVERT.NODE 53738 .
|
||||
55126) (DINFO.LAYOUTGRAPH 55128 . 58694)) (58697 64553 (DINFO.UPDATE.TEXT.DISPLAY 58707 . 60568) (
|
||||
DINFO.TITLEMENUFN 60570 . 61695) (DINFO.OPENTEXTSTREAM 61697 . 62913) (DINFO.SHOWSEL 62915 . 63648) (
|
||||
DINFO.GET.FILENAME 63650 . 64551)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
120
lispusers/EXAMINEDEFS
Normal file
120
lispusers/EXAMINEDEFS
Normal file
@@ -0,0 +1,120 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "20-Dec-2021 11:06:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;7 6367
|
||||
|
||||
:CHANGES-TO (FNS EXAMINEDEFS)
|
||||
|
||||
:PREVIOUS-DATE "19-Dec-2021 22:45:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;5)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXAMINEDEFSCOMS)
|
||||
|
||||
(RPAQQ EXAMINEDEFSCOMS ((FNS EXAMINEDEFS EXAMINEDEFS-REGION)
|
||||
(INITVARS (EXAMINEDEFS-PROCESS-LIST))))
|
||||
(DEFINEQ
|
||||
|
||||
(EXAMINEDEFS
|
||||
[LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION) (* ; "Edited 20-Dec-2021 11:06 by rmk")
|
||||
|
||||
(* ;; "This provides for side-by-side examination of separate but presumably related expressions. The (LISTP) expressions can be provided directly as SOURCE1 and SOURCE2 or, if NAME is given the copies of the definitions of NAME as TYPE on the two sources are examined.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "Examination is in side-by-side attached SEDIT windows if SEDIT is the EDITMODE. You can use SEDIT operations to zoom in on the location of any changes, deleting common stuff for example. But you are always working on a copy, so that changes are safe and ephemeral. This is an examination, not an edit.")
|
||||
|
||||
(CL:UNLESS NAME
|
||||
(CL:UNLESS (LISTP SOURCE1)
|
||||
(ERROR SOURCE1 " cannot be examined"))
|
||||
(CL:UNLESS (LISTP SOURCE2)
|
||||
(ERROR SOURCE2 " cannot be examined")))
|
||||
|
||||
(* ;; "TITLE1 and TITLE2 are optional strings that will be used to construct the titles of the SEDIT windows. We would like to know where GETDEF got the definition so we can use that, but there isn't an interface that provides that information (extended WHEREIS?)")
|
||||
|
||||
(LET (DEF1 DEF2)
|
||||
(SETQ DEF1 (IF (LISTP SOURCE1)
|
||||
THEN
|
||||
(* ;; "Copy to simulate READONLY")
|
||||
|
||||
(SETQ DEF1 (COPY SOURCE1))
|
||||
ELSEIF (GETDEF NAME TYPE SOURCE1)
|
||||
ELSE (ERROR NAME " not found on " SOURCE1)))
|
||||
(SETQ DEF2 (IF (LISTP SOURCE2)
|
||||
THEN (COPY SOURCE2)
|
||||
ELSEIF (GETDEF NAME TYPE SOURCE2)
|
||||
ELSE (ERROR NAME " not found on " SOURCE2)))
|
||||
(CL:UNLESS TITLE1
|
||||
(SETQ TITLE1 (OR SOURCE1 "File 1")))
|
||||
(CL:UNLESS TITLE2
|
||||
(SETQ TITLE2 (OR SOURCE2 "File 2")))
|
||||
(SELECTQ (EDITMODE)
|
||||
(SEDIT:SEDIT
|
||||
(* ;;
|
||||
"A kludge to eliminate dangling SEDIT processes from previous examinations")
|
||||
|
||||
[SETQ EXAMINEDEFS-PROCESS-LIST
|
||||
(FOR PAIR IN EXAMINEDEFS-PROCESS-LIST
|
||||
COLLECT (IF (OPENWP (CAR PAIR))
|
||||
THEN PAIR
|
||||
ELSE (DEL.PROCESS (CDR PAIR))
|
||||
(GO $$ITERATE]
|
||||
|
||||
(* ;; "Set it up for new side-by-side regions that are forgotten when the window is closed. Their shape is usually not that useful for regular edits.")
|
||||
|
||||
(* ;;
|
||||
"Crude suggestions for height, width, position. Suggest shorter window for smaller structures")
|
||||
|
||||
(CL:UNLESS (REGIONP REGION)
|
||||
(SETQ REGION (GETREGION)))
|
||||
(LET (W1 W2 HALFWIDTH)
|
||||
(SETQ HALFWIDTH (IQUOTIENT (FETCH (REGION WIDTH) OF REGION)
|
||||
2))
|
||||
[SETQ W1
|
||||
(SEDIT:GET-WINDOW (SEDIT:SEDIT DEF1
|
||||
`(:NAME ,(CONCAT NAME " from " TITLE1)
|
||||
:REGION
|
||||
,(CREATE REGION
|
||||
USING REGION WIDTH _ HALFWIDTH)
|
||||
:DONT-KEEP-WINDOW-REGION T]
|
||||
[SETQ W2
|
||||
(SEDIT:GET-WINDOW
|
||||
(SEDIT:SEDIT DEF2
|
||||
`(:NAME ,(CONCAT NAME " from " TITLE2)
|
||||
:REGION
|
||||
,(CREATE REGION USING REGION LEFT _
|
||||
(IPLUS (FETCH (REGION LEFT)
|
||||
OF REGION)
|
||||
HALFWIDTH)
|
||||
WIDTH _ HALFWIDTH)
|
||||
:DONT-KEEP-WINDOW-REGION T]
|
||||
|
||||
(* ;;
|
||||
"So we can kill the processes on the next call, if they still exist after the windows are closed.")
|
||||
|
||||
[PUSH EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP W1 'PROCESS))
|
||||
(CONS W2 (WINDOWPROP W2 'PROCESS]
|
||||
(ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
|
||||
(MODERNWINDOW W2)))
|
||||
(PROGN (EDITE DEF1)
|
||||
(EDITE DEF2])
|
||||
|
||||
(EXAMINEDEFS-REGION
|
||||
[LAMBDA (WIDTH HEIGHT) (* ; "Edited 10-Dec-2021 10:15 by rmk")
|
||||
|
||||
(* ;; "Prompts for a WIDTH-HEIGHT region with the top-left corner positioned at the initial cursor but the cursor then moved to the bottom-right for size adjustments. Thus the default behavior is that the upper left corner is fixed.")
|
||||
|
||||
(GETMOUSESTATE)
|
||||
(LET* ((LEFT LASTMOUSEX)
|
||||
(RIGHT (IPLUS LEFT WIDTH))
|
||||
(TOP LASTMOUSEY)
|
||||
(BOTTOM (IDIFFERENCE TOP HEIGHT)))
|
||||
(\CURSORPOSITION RIGHT BOTTOM)
|
||||
(GETREGION NIL NIL (CREATEREGION LEFT BOTTOM WIDTH HEIGHT)
|
||||
NIL NIL (LIST LEFT TOP RIGHT BOTTOM])
|
||||
)
|
||||
|
||||
(RPAQ? EXAMINEDEFS-PROCESS-LIST )
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (513 6305 (EXAMINEDEFS 523 . 5601) (EXAMINEDEFS-REGION 5603 . 6303)))))
|
||||
STOP
|
||||
BIN
lispusers/EXAMINEDEFS.LCOM
Normal file
BIN
lispusers/EXAMINEDEFS.LCOM
Normal file
Binary file not shown.
BIN
lispusers/EXAMINEDEFS.TEDIT
Normal file
BIN
lispusers/EXAMINEDEFS.TEDIT
Normal file
Binary file not shown.
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
1496
lispusers/OBJECTWINDOW
Normal file
1496
lispusers/OBJECTWINDOW
Normal file
File diff suppressed because it is too large
Load Diff
BIN
lispusers/OBJECTWINDOW.LCOM
Normal file
BIN
lispusers/OBJECTWINDOW.LCOM
Normal file
Binary file not shown.
BIN
lispusers/OBJECTWINDOW.TEDIT
Normal file
BIN
lispusers/OBJECTWINDOW.TEDIT
Normal file
Binary file not shown.
@@ -1,11 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED " 9-Jul-2021 21:55:15"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;5 93788
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS PRETTYFILEINDEX PFI.PRINT.FILECREATED)
|
||||
(FILECREATED "30-Nov-2021 22:12:37" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;2 94399
|
||||
|
||||
previous date%: " 9-Jul-2021 08:04:40"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;4)
|
||||
:CHANGES-TO (FNS PFI.PRINT.FILECREATED)
|
||||
|
||||
:PREVIOUS-DATE " 9-Jul-2021 21:55:15" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -16,7 +15,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
|
||||
(RPAQQ PRETTYFILEINDEXCOMS
|
||||
[(COMS
|
||||
(* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")
|
||||
(* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")
|
||||
|
||||
(FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX)
|
||||
(FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN
|
||||
@@ -25,25 +24,25 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER
|
||||
PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE
|
||||
PFI.ESTIMATE.SIZE1))
|
||||
(COMS (* ; "Expression handlers")
|
||||
(COMS (* ; "Expression handlers")
|
||||
(FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER
|
||||
PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF
|
||||
PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS
|
||||
PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE))
|
||||
(COMS (* ; "Previewers")
|
||||
(COMS (* ; "Previewers")
|
||||
(FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ))
|
||||
(COMS (* ; "Printing the index")
|
||||
(COMS (* ; "Printing the index")
|
||||
(FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE
|
||||
PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME)
|
||||
(FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES))
|
||||
(COMS (* ; "Combined listings")
|
||||
(COMS (* ; "Combined listings")
|
||||
(FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST
|
||||
PFI.MERGE.INDICES))
|
||||
(COMS (* ;
|
||||
"Hooks for seeing files pretty elsewhere")
|
||||
(COMS (* ;
|
||||
"Hooks for seeing files pretty elsewhere")
|
||||
(FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION)
|
||||
(INITVARS (*PRINT-PRETTY-FROM-FILES* T)))
|
||||
(COMS (* ; "Bitmap hack")
|
||||
(COMS (* ; "Bitmap hack")
|
||||
(FNS PFI.PRINT.BITMAP)
|
||||
(INITVARS (*PRINT-PRETTY-BITMAPS* T)))
|
||||
(INITVARS [*PFI-PRINTOPTIONS* '(REGION (72 54 504 702]
|
||||
@@ -57,8 +56,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
then *INTERLISP-PACKAGE* else
|
||||
*KEYWORD-PACKAGE*)))
|
||||
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
|
||||
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
|
||||
(FUNCTION CL:INTERN]
|
||||
@@ -66,7 +65,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX"))
|
||||
(\PFI.PROCESS))
|
||||
(COMS
|
||||
(* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex")
|
||||
(* ;; "These are just in case our afternewpagefn escapes our dynamic context. *PFI-TITLE* being NIL means we're outside prettyfileindex")
|
||||
|
||||
(INITVARS (*PFI-TITLE*)
|
||||
(*PFI-PAGE-COUNT* 0)))
|
||||
@@ -102,8 +101,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(*PFI-PROPERTIES* (COPYRIGHT)
|
||||
(READVICE ADVICE))
|
||||
(*PFI-FILTERS* (VARIABLES . CONSTANTS)))
|
||||
(COMS (* ;
|
||||
"Prettyprint augmentation to mimic system makefile dumping")
|
||||
(COMS (* ;
|
||||
"Prettyprint augmentation to mimic system makefile dumping")
|
||||
(FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT
|
||||
MAYBE.PRETTYPRINT.BOLD)
|
||||
(ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM)))
|
||||
@@ -119,8 +118,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES
|
||||
MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS*
|
||||
*COMMON-LISP-READ-ENVIRONMENT*))
|
||||
[DECLARE%: EVAL@COMPILE DOCOPY (* ;
|
||||
"Public variables to declare special")
|
||||
[DECLARE%: EVAL@COMPILE DOCOPY (* ;
|
||||
"Public variables to declare special")
|
||||
(P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS*
|
||||
*PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS*
|
||||
*PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS*
|
||||
@@ -130,24 +129,24 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(P (OR (GETD 'CODEWRAPPER.PRETTYPRINT)
|
||||
(FILESLOAD (SYSLOAD)
|
||||
DEFINERPRINT))
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
(MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
|
||||
S)
|
||||
(* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
(* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
LP
|
||||
(COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
|
||||
(GETD S))
|
||||
(RETURN (PROG1 S
|
||||
(COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE"
|
||||
))
|
||||
(* ; "Also fix SEE")
|
||||
(* ; "Also fix SEE")
|
||||
(MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
|
||||
((SETQ SYMS (CDR SYMS))
|
||||
(GO LP))
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(RETURN 'LISTFILES1]
|
||||
'PFI.ORIGINAL.LISTFILES1 NIL T)
|
||||
(MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T)
|
||||
@@ -459,12 +458,17 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(PFI.PRINT.FILECREATED
|
||||
[LAMBDA (EXPR ENV) (* ; "Edited 9-Jul-2021 07:59 by rmk:")
|
||||
[LAMBDA (EXPR ENV) (* ;
|
||||
"Edited 30-Nov-2021 22:08 by larry")
|
||||
(* ;
|
||||
"Edited 30-Nov-2021 21:40 by larry")
|
||||
(* ;
|
||||
"Edited 9-Jul-2021 07:59 by rmk:")
|
||||
|
||||
(* ;; "Display the FILECREATED expression and environment prettily")
|
||||
(* ;; "Display the FILECREATED expression and environment prettily")
|
||||
|
||||
(* ;;
|
||||
"Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
|
||||
(* ;;
|
||||
"Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")
|
||||
|
||||
(pop EXPR)
|
||||
(CHANGEFONT ITALICFONT)
|
||||
@@ -477,34 +481,41 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
STRWIDTHS]
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "File created:")
|
||||
TABSTOP) (* ; "File created:")
|
||||
(PRINTOUT NIL (pop EXPR)
|
||||
" " .FONT LAMBDAFONT (pop EXPR)
|
||||
T T) (* ; "date and file name")
|
||||
T T) (* ; "date and file name")
|
||||
(if (OR (NULL (CAR EXPR))
|
||||
(FIXP (CAR EXPR)))
|
||||
then (* ; "Skip over filemaploc")
|
||||
then (* ; "Skip over filemaploc")
|
||||
(pop EXPR))
|
||||
(if (EQ (CAR EXPR)
|
||||
'changes)
|
||||
then (* ; "handle %"Changes to:%"")
|
||||
(if (SELECTQ (CAR EXPR)
|
||||
(changes (SETQ EXPR (CDR EXPR))
|
||||
T)
|
||||
(:CHANGES-TO T)
|
||||
NIL)
|
||||
then (* ; "handle %"Changes to:%"")
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP)
|
||||
(SETQ EXPR (CDDR EXPR))
|
||||
(SETQ EXPR (CDR EXPR))
|
||||
(PRINTDEF (while (LISTP (CAR EXPR)) collect (pop EXPR))
|
||||
T NIL T)
|
||||
(TERPRI)
|
||||
(TERPRI)
|
||||
else (pop STRINGS)
|
||||
(pop STRWIDTHS))
|
||||
(if (EQ (CAR EXPR)
|
||||
'previous)
|
||||
then (* ; "Handle %"Previous date:%"")
|
||||
(if (SELECTQ (CAR EXPR)
|
||||
(previous (SETQ EXPR (CDR EXPR))
|
||||
T)
|
||||
(:PREVIOUS-DATE
|
||||
T)
|
||||
NIL)
|
||||
then (* ; "Handle %"Previous date:%"")
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP)
|
||||
(SETQ EXPR (CDDR EXPR))
|
||||
(SETQ EXPR (CDR EXPR))
|
||||
(PRINTOUT NIL (pop EXPR)
|
||||
" "
|
||||
(pop EXPR)
|
||||
@@ -512,25 +523,25 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
else (pop STRINGS)
|
||||
(pop STRWIDTHS))
|
||||
|
||||
(* ;; "Show environment")
|
||||
(* ;; "Show environment")
|
||||
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "Read table")
|
||||
TABSTOP) (* ; "Read table")
|
||||
(PFI.PRINT.ENVIRONMENT ENV :READTABLE)
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "Package")
|
||||
TABSTOP) (* ; "Package")
|
||||
(PFI.PRINT.ENVIRONMENT ENV :PACKAGE)
|
||||
(if (NEQ *PRINT-BASE* 10)
|
||||
then (PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP)
|
||||
(PFI.PRINT.ENVIRONMENT ENV :BASE)
|
||||
ELSE (pop STRINGS))
|
||||
else (pop STRINGS))
|
||||
(PFI.PRINT.TO.TAB (pop STRINGS)
|
||||
(pop STRWIDTHS)
|
||||
TABSTOP) (* ; "Format")
|
||||
TABSTOP) (* ; "Format")
|
||||
(PFI.PRINT.ENVIRONMENT ENV :FORMAT])
|
||||
|
||||
(PFI.PRINT.TO.TAB
|
||||
@@ -819,8 +830,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))
|
||||
)
|
||||
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
(* ;;
|
||||
"Properties of definers changed between Lyric and Medley (yech).")
|
||||
|
||||
(MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
|
||||
(FUNCTION CL:INTERN))))
|
||||
@@ -948,24 +959,24 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
(FILESLOAD (SYSLOAD)
|
||||
DEFINERPRINT))
|
||||
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
(* ;
|
||||
"Get prettyprinter fixes if running in old sysout")
|
||||
|
||||
(MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
|
||||
S) (* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
S) (* ;
|
||||
"Look for LISTFILES1. These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")
|
||||
LP (COND
|
||||
[(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
|
||||
(GETD S))
|
||||
(RETURN (PROG1 S
|
||||
(COND
|
||||
((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE"))
|
||||
(* ; "Also fix SEE")
|
||||
(* ; "Also fix SEE")
|
||||
(MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
|
||||
((SETQ SYMS (CDR SYMS))
|
||||
(GO LP))
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(T (* ;
|
||||
"Neither one loaded, take original")
|
||||
(RETURN 'LISTFILES1]
|
||||
'PFI.ORIGINAL.LISTFILES1 NIL T)
|
||||
|
||||
@@ -983,28 +994,28 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (10148 12383 (PFI.NEW.LISTFILES1 10158 . 10652) (PFI.ENQUEUE 10654 . 11278) (
|
||||
\PFI.DO.HARDCOPY 11280 . 11866) (MAYBE.PRETTYFILEINDEX 11868 . 12381)) (12384 35298 (PRETTYFILEINDEX
|
||||
12394 . 26826) (PFI.MAKE.LPT.STREAM 26828 . 29879) (PFI.SETUP.TRANSLATIONS 29881 . 31395) (
|
||||
PFI.OUTCHARFN 31397 . 33371) (PFI.COLLECT.DEFINERS 33373 . 34185) (PFI.AFTER.NEW.PAGE 34187 . 35296))
|
||||
(35299 40558 (PFI.PRINT.FILECREATED 35309 . 38825) (PFI.PRINT.TO.TAB 38827 . 39192) (
|
||||
PFI.PRINT.ENVIRONMENT 39194 . 40556)) (40559 47743 (PFI.PROCESS.FILE 40569 . 41799) (PFI.PASS.COMMENT
|
||||
41801 . 42771) (PFI.HANDLE.EXPR 42773 . 43440) (PFI.DEFAULT.HANDLER 43442 . 45495) (PFI.PRETTYPRINT
|
||||
45497 . 45832) (PFI.LINES.REMAINING 45834 . 46161) (PFI.MAYBE.NEW.PAGE 46163 . 46666) (
|
||||
PFI.ESTIMATE.SIZE 46668 . 47199) (PFI.ESTIMATE.SIZE1 47201 . 47741)) (47780 57267 (PFI.HANDLE.RPAQQ
|
||||
47790 . 49198) (PFI.HANDLE.DECLARE 49200 . 50139) (PFI.HANDLE.EVAL-WHEN 50141 . 50624) (
|
||||
PFI.HANDLE.DEFDEFINER 50626 . 51916) (PFI.HANDLE.DEFINEQ 51918 . 52162) (PFI.PRINT.LAMBDA 52164 .
|
||||
52502) (PFI.PRINT.LAMBDA.BODY 52504 . 52839) (PFI.HANDLE.PUTDEF 52841 . 53338) (PFI.HANDLE.PUTPROPS
|
||||
53340 . 53955) (PFI.HANDLE./DECLAREDATATYPE 53957 . 54504) (PFI.HANDLE.* 54506 . 55768) (
|
||||
PFI.PRINT.COMMENTS 55770 . 56670) (PFI.HANDLE.FILEMAP 56672 . 56960) (PFI.HANDLE.PACKAGE 56962 . 57265
|
||||
)) (57295 58287 (PFI.PREVIEW.DECLARE 57305 . 57967) (PFI.PREVIEW.DEFINEQ 57969 . 58285)) (58323 69311
|
||||
(PFI.PRINT.INDEX 58333 . 59184) (PFI.CONDENSE.INDEX 59186 . 60993) (PFI.SORT.INDICES 60995 . 62134) (
|
||||
PFI.COMPUTE.INDEX.SHAPE 62136 . 63600) (PFI.PRINT.INDICES 63602 . 68144) (PFI.CENTER.PRINT 68146 .
|
||||
68716) (PFI.INDEX.BREAK 68718 . 69176) (PFI.LOOKUP.NAME 69178 . 69309)) (69312 70543 (PFI.ADD.TO.INDEX
|
||||
69322 . 69832) (PFI.VARNAME 69834 . 70244) (PFI.CONSTANTNAMES 70246 . 70541)) (70578 78891 (
|
||||
MULTIFILEINDEX 70588 . 71384) (MULTIFILEINDEX1 71386 . 72842) (PFI.PRINT.MULTI.INDEX 72844 . 77947) (
|
||||
PFI.CHOOSE.BEST 77949 . 78176) (PFI.MERGE.INDICES 78178 . 78889)) (78948 80566 (PFI.MAYBE.SEE.PRETTY
|
||||
78958 . 79888) (PFI.MAYBE.PP.DEFINITION 79890 . 80564)) (80636 84471 (PFI.PRINT.BITMAP 80646 . 84469))
|
||||
(87316 90430 (PUTPROPS.PRETTYPRINT 87326 . 88737) (RPAQX.PRETTYPRINT 88739 . 89464) (
|
||||
COURIERPROGRAM.PRETTYPRINT 89466 . 90166) (MAYBE.PRETTYPRINT.BOLD 90168 . 90428)))))
|
||||
(FILEMAP (NIL (10070 12305 (PFI.NEW.LISTFILES1 10080 . 10574) (PFI.ENQUEUE 10576 . 11200) (
|
||||
\PFI.DO.HARDCOPY 11202 . 11788) (MAYBE.PRETTYFILEINDEX 11790 . 12303)) (12306 35220 (PRETTYFILEINDEX
|
||||
12316 . 26748) (PFI.MAKE.LPT.STREAM 26750 . 29801) (PFI.SETUP.TRANSLATIONS 29803 . 31317) (
|
||||
PFI.OUTCHARFN 31319 . 33293) (PFI.COLLECT.DEFINERS 33295 . 34107) (PFI.AFTER.NEW.PAGE 34109 . 35218))
|
||||
(35221 41169 (PFI.PRINT.FILECREATED 35231 . 39436) (PFI.PRINT.TO.TAB 39438 . 39803) (
|
||||
PFI.PRINT.ENVIRONMENT 39805 . 41167)) (41170 48354 (PFI.PROCESS.FILE 41180 . 42410) (PFI.PASS.COMMENT
|
||||
42412 . 43382) (PFI.HANDLE.EXPR 43384 . 44051) (PFI.DEFAULT.HANDLER 44053 . 46106) (PFI.PRETTYPRINT
|
||||
46108 . 46443) (PFI.LINES.REMAINING 46445 . 46772) (PFI.MAYBE.NEW.PAGE 46774 . 47277) (
|
||||
PFI.ESTIMATE.SIZE 47279 . 47810) (PFI.ESTIMATE.SIZE1 47812 . 48352)) (48391 57878 (PFI.HANDLE.RPAQQ
|
||||
48401 . 49809) (PFI.HANDLE.DECLARE 49811 . 50750) (PFI.HANDLE.EVAL-WHEN 50752 . 51235) (
|
||||
PFI.HANDLE.DEFDEFINER 51237 . 52527) (PFI.HANDLE.DEFINEQ 52529 . 52773) (PFI.PRINT.LAMBDA 52775 .
|
||||
53113) (PFI.PRINT.LAMBDA.BODY 53115 . 53450) (PFI.HANDLE.PUTDEF 53452 . 53949) (PFI.HANDLE.PUTPROPS
|
||||
53951 . 54566) (PFI.HANDLE./DECLAREDATATYPE 54568 . 55115) (PFI.HANDLE.* 55117 . 56379) (
|
||||
PFI.PRINT.COMMENTS 56381 . 57281) (PFI.HANDLE.FILEMAP 57283 . 57571) (PFI.HANDLE.PACKAGE 57573 . 57876
|
||||
)) (57906 58898 (PFI.PREVIEW.DECLARE 57916 . 58578) (PFI.PREVIEW.DEFINEQ 58580 . 58896)) (58934 69922
|
||||
(PFI.PRINT.INDEX 58944 . 59795) (PFI.CONDENSE.INDEX 59797 . 61604) (PFI.SORT.INDICES 61606 . 62745) (
|
||||
PFI.COMPUTE.INDEX.SHAPE 62747 . 64211) (PFI.PRINT.INDICES 64213 . 68755) (PFI.CENTER.PRINT 68757 .
|
||||
69327) (PFI.INDEX.BREAK 69329 . 69787) (PFI.LOOKUP.NAME 69789 . 69920)) (69923 71154 (PFI.ADD.TO.INDEX
|
||||
69933 . 70443) (PFI.VARNAME 70445 . 70855) (PFI.CONSTANTNAMES 70857 . 71152)) (71189 79502 (
|
||||
MULTIFILEINDEX 71199 . 71995) (MULTIFILEINDEX1 71997 . 73453) (PFI.PRINT.MULTI.INDEX 73455 . 78558) (
|
||||
PFI.CHOOSE.BEST 78560 . 78787) (PFI.MERGE.INDICES 78789 . 79500)) (79559 81177 (PFI.MAYBE.SEE.PRETTY
|
||||
79569 . 80499) (PFI.MAYBE.PP.DEFINITION 80501 . 81175)) (81247 85082 (PFI.PRINT.BITMAP 81257 . 85080))
|
||||
(87927 91041 (PUTPROPS.PRETTYPRINT 87937 . 89348) (RPAQX.PRETTYPRINT 89350 . 90075) (
|
||||
COURIERPROGRAM.PRETTYPRINT 90077 . 90777) (MAYBE.PRETTYPRINT.BOLD 90779 . 91039)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,220 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "10-Sep-87 12:12:37" {DSK}<OST>STREAMDECLS.\;1 10202
|
||||
|
||||
|changes| |to:| (VARS STREAMDECLSCOMS)
|
||||
(RECORDS STREAM))
|
||||
|
||||
|
||||
(PRETTYCOMPRINT STREAMDECLSCOMS)
|
||||
|
||||
(RPAQQ STREAMDECLSCOMS ((RECORDS STREAM)))
|
||||
(DECLARE\: EVAL@COMPILE
|
||||
|
||||
(DATATYPE STREAM
|
||||
(
|
||||
|
||||
(* |;;| "First 8 words are fixed for BIN, BOUT opcodes. Used to require length of whole datatype be multiple of 4, but Dolphin dead now.")
|
||||
|
||||
(COFFSET WORD) (* \;
|
||||
"Offset in CPPTR of next bin or bout")
|
||||
|
||||
(CBUFSIZE WORD) (* \;
|
||||
"Offset past last byte in that buffer")
|
||||
|
||||
(BINABLE FLAG) (* \; "BIN punts unless this bit on")
|
||||
|
||||
(BOUTABLE FLAG) (* \; "BOUT punts unless this bit on")
|
||||
|
||||
(EXTENDABLE FLAG) (* \;
|
||||
"BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512")
|
||||
|
||||
(CBUFDIRTY FLAG) (* \;
|
||||
"true if BOUT has sullied the current buffer")
|
||||
|
||||
(PEEKEDCHARP FLAG) (* \;
|
||||
"if true, PEEKEDCHAR contains value of recent call to unread-char")
|
||||
|
||||
(ACCESSBITS BITS 3) (* \;
|
||||
"What kind of access file is open for (read, write, append)")
|
||||
|
||||
(CBUFPTR POINTER) (* \; "Pointer to current buffer")
|
||||
|
||||
(BYTESIZE BYTE) (* \;
|
||||
"Byte size of stream, always 8 for now")
|
||||
|
||||
(CHARSET BYTE) (* \; "the current character set for this stream. If 255, stream is not runcoded, so read-char consumes two bytes every time")
|
||||
|
||||
(PEEKEDCHAR WORD) (* \; "value of unread-char call")
|
||||
|
||||
(CHARPOSITION WORD) (* \; "Used by POSITION etc.")
|
||||
|
||||
(CBUFMAXSIZE WORD) (* \;
|
||||
"on output, the size of the physical buffer--can't extend beyond this")
|
||||
|
||||
(* |;;| "-------- Above fields (8 words) potentially known to microcode. --------")
|
||||
|
||||
(NONDEFAULTDATEFLG FLAG)
|
||||
(REVALIDATEFLG FLAG)
|
||||
(MULTIBUFFERHINT FLAG) (* \;
|
||||
"True if stream likes to read and write more than one buffer at a time")
|
||||
|
||||
(USERCLOSEABLE FLAG) (* \;
|
||||
"Can be closed by CLOSEF; NIL for terminal, dribble...")
|
||||
|
||||
(USERVISIBLE FLAG) (* \;
|
||||
"Listed by OPENP; NIL for terminal, dribble ...")
|
||||
|
||||
(EOLCONVENTION BITS 2) (* \; "End-of-line convention")
|
||||
|
||||
(NIL FLAG)
|
||||
(FULLFILENAME POINTER) (* \;
|
||||
"Name by which file is known to user")
|
||||
|
||||
(DEVICE POINTER) (* \; "FDEV of this guy")
|
||||
|
||||
(VALIDATION POINTER) (* \;
|
||||
"A number somehow identifying file, used to determine if file has changed in our absence")
|
||||
|
||||
(CPAGE POINTER) (* \;
|
||||
"CPAGE,,COFFSET constitutes current file pointer for most randaccess streams")
|
||||
|
||||
(EPAGE POINTER)
|
||||
(EOFFSET WORD) (* \; "Page, byte offset of eof")
|
||||
|
||||
(LINELENGTH WORD) (* \;
|
||||
"LINELENGTH of stream, or -1 for no line length")
|
||||
|
||||
(* |;;| "----Following are device-specific fields----")
|
||||
|
||||
(F1 POINTER)
|
||||
(F2 POINTER)
|
||||
(F3 POINTER)
|
||||
(F4 POINTER)
|
||||
(F5 POINTER)
|
||||
(FW6 WORD)
|
||||
(FW7 WORD)
|
||||
(FW8 WORD)
|
||||
(FW9 WORD)
|
||||
(F10 POINTER)
|
||||
|
||||
(* |;;| "----Following only filled in for open streams----")
|
||||
|
||||
(STRMBINFN POINTER) (* \;
|
||||
"Either the BIN fn from the FDEV, or a trap")
|
||||
|
||||
(STRMBOUTFN POINTER) (* \;
|
||||
"Either the BIN fn from the FDEV, or a trap")
|
||||
|
||||
(OUTCHARFN POINTER)
|
||||
(ENDOFSTREAMOP POINTER)
|
||||
(OTHERPROPS POINTER)
|
||||
(IMAGEOPS POINTER) (* \; "Image operations vector")
|
||||
|
||||
(IMAGEDATA POINTER) (* \;
|
||||
"Image instance variables--format depends on IMAGEOPS value")
|
||||
|
||||
(BUFFS POINTER) (* \; "Buffer chain for pmapped streams")
|
||||
|
||||
(MAXBUFFERS WORD)
|
||||
(NIL WORD)
|
||||
(EXTRASTREAMOP POINTER) (* \;
|
||||
"For use of applications programs, not devices")
|
||||
|
||||
)
|
||||
(BLOCKRECORD STREAM ((NIL 2 WORD)
|
||||
(UCODEFLAGS BITS 5)
|
||||
|
||||
(* |;;| "respecification of access bits:")
|
||||
|
||||
(RANDOMWRITEABLE FLAG) (* \;
|
||||
"File open for output (access = OUTPUT or BOTH)")
|
||||
|
||||
(APPENDABLE FLAG) (* \;
|
||||
"File open for append (OUTPUT or APPEND or BOTH)")
|
||||
|
||||
(READABLE FLAG) (* \;
|
||||
"File open for read (READ or BOTH)")
|
||||
|
||||
(NIL POINTER)))
|
||||
(ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS)
|
||||
(FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM)
|
||||
DATUM))
|
||||
(NAMEDP (AND (|fetch| (STREAM FULLFILENAME) |of| DATUM)
|
||||
T))))
|
||||
(SYNONYM CBUFPTR (CPPTR))
|
||||
USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ |NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL
|
||||
BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (GLOBALVARS
|
||||
\\STREAM.DEFAULT.MAXBUFFERS
|
||||
))
|
||||
\\STREAM.DEFAULT.MAXBUFFERS)
|
||||
CHARPOSITION _ 0 LINELENGTH _ (LET NIL (DECLARE (GLOBALVARS FILELINELENGTH))
|
||||
FILELINELENGTH)
|
||||
OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN)
|
||||
ENDOFSTREAMOP _ (FUNCTION \\EOSERROR)
|
||||
IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE)
|
||||
(D CR.EOLC)
|
||||
(VAX LF.EOLC)
|
||||
(JERICHO CRLF.EOLC)
|
||||
CR.EOLC)
|
||||
STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN)
|
||||
STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN))
|
||||
)
|
||||
(/DECLAREDATATYPE 'STREAM
|
||||
'(WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 3)
|
||||
POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 2)
|
||||
FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER
|
||||
POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER
|
||||
POINTER POINTER WORD WORD POINTER)
|
||||
'((STREAM 0 (BITS . 15))
|
||||
(STREAM 1 (BITS . 15))
|
||||
(STREAM 2 (FLAGBITS . 0))
|
||||
(STREAM 2 (FLAGBITS . 16))
|
||||
(STREAM 2 (FLAGBITS . 32))
|
||||
(STREAM 2 (FLAGBITS . 48))
|
||||
(STREAM 2 (FLAGBITS . 64))
|
||||
(STREAM 2 (BITS . 82))
|
||||
(STREAM 2 POINTER)
|
||||
(STREAM 4 (BITS . 7))
|
||||
(STREAM 4 (BITS . 135))
|
||||
(STREAM 5 (BITS . 15))
|
||||
(STREAM 6 (BITS . 15))
|
||||
(STREAM 7 (BITS . 15))
|
||||
(STREAM 8 (FLAGBITS . 0))
|
||||
(STREAM 8 (FLAGBITS . 16))
|
||||
(STREAM 8 (FLAGBITS . 32))
|
||||
(STREAM 8 (FLAGBITS . 48))
|
||||
(STREAM 8 (FLAGBITS . 64))
|
||||
(STREAM 8 (BITS . 81))
|
||||
(STREAM 8 (FLAGBITS . 112))
|
||||
(STREAM 8 POINTER)
|
||||
(STREAM 10 POINTER)
|
||||
(STREAM 12 POINTER)
|
||||
(STREAM 14 POINTER)
|
||||
(STREAM 16 POINTER)
|
||||
(STREAM 18 (BITS . 15))
|
||||
(STREAM 19 (BITS . 15))
|
||||
(STREAM 20 POINTER)
|
||||
(STREAM 22 POINTER)
|
||||
(STREAM 24 POINTER)
|
||||
(STREAM 26 POINTER)
|
||||
(STREAM 28 POINTER)
|
||||
(STREAM 30 (BITS . 15))
|
||||
(STREAM 31 (BITS . 15))
|
||||
(STREAM 32 (BITS . 15))
|
||||
(STREAM 33 (BITS . 15))
|
||||
(STREAM 34 POINTER)
|
||||
(STREAM 36 POINTER)
|
||||
(STREAM 38 POINTER)
|
||||
(STREAM 40 POINTER)
|
||||
(STREAM 42 POINTER)
|
||||
(STREAM 44 POINTER)
|
||||
(STREAM 46 POINTER)
|
||||
(STREAM 48 POINTER)
|
||||
(STREAM 50 POINTER)
|
||||
(STREAM 52 (BITS . 15))
|
||||
(STREAM 53 (BITS . 15))
|
||||
(STREAM 54 POINTER))
|
||||
'56)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
@@ -1,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,78 +1,74 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "23-Dec-98 17:05:12" {DSK}<project>medley3.5>lispusers>comparetext.;3 39844
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS IMCOMPARE.HASH IMCOMPARE.COLLECT.HASH.CHUNKS)
|
||||
(VARS COMPARETEXTCOMS)
|
||||
(FILECREATED "22-Dec-2021 10:37:46"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;20 39405
|
||||
|
||||
previous date%: "18-Nov-93 14:43:00" {DSK}<project>medley3.5>lispusers>comparetext.;1)
|
||||
:CHANGES-TO (FNS IMCOMPARE.COLLECT.HASH.CHUNKS COMPARETEXT)
|
||||
(RECORDS IMCOMPARE.CHUNK)
|
||||
|
||||
:PREVIOUS-DATE "19-Dec-2021 12:45:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;19)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPARETEXTCOMS)
|
||||
|
||||
(RPAQQ COMPARETEXTCOMS
|
||||
((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP)
|
||||
GRAPHER))
|
||||
(FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
((FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH
|
||||
IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE)
|
||||
(P (MOVD 'COMPARETEXT 'IMCOMPARE))
|
||||
(VARS (IMCOMPARE.LAST.NODE NIL)
|
||||
(IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
(IMCOMPARE.HASH.TYPE.MENU NIL))
|
||||
(INITVARS (IMCOMPARE.LAST.NODE NIL)
|
||||
(IMCOMPARE.LAST.GRAPH.WINDOW NIL))
|
||||
(RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB)
|
||||
(FILES GRAPHER)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
GRAPHER)
|
||||
)
|
||||
(FILES (SYSLOAD)
|
||||
GRAPHER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
GRAPHER))))
|
||||
(DEFINEQ
|
||||
|
||||
(COMPARETEXT
|
||||
[LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION)
|
||||
[LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION FILELABELS)
|
||||
(* ; "Edited 22-Dec-2021 10:35 by rmk")
|
||||
(* ; "Edited 15-Dec-2021 16:23 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 12:21 by rmk")
|
||||
(* ; "Edited 8-Nov-2021 08:44 by rmk:")
|
||||
(* mjs " 8-Jan-84 21:06")
|
||||
|
||||
(* Compares the two files, and produces a graph showing their corresponding
|
||||
chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may
|
||||
be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
|
||||
The file difference graph is displayed at GRAPHREGION.
|
||||
If GRAPH.REGION = NIL, the user is asked to specify a region.
|
||||
If GRAPH.REGION = T, a standard region is used.)
|
||||
(* ;; "Compares the two files, and produces a graph showing their corresponding chunks. The courseness of the 'chunking' is determined by HASH.TYPE, which may be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA. The file difference graph is displayed at GRAPHREGION. If GRAPH.REGION = NIL, the user is asked to specify a region. If GRAPH.REGION = T, a standard region is used.")
|
||||
|
||||
(PROG ((NEWFILE (FINDFILE NEWFILENAME T))
|
||||
(OLDFILE (FINDFILE OLDFILENAME T)))
|
||||
(if (AND OLDFILE NEWFILE)
|
||||
then (* compare the two "chunks"
|
||||
consisting of the entire text of the
|
||||
two files)
|
||||
(IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK
|
||||
FILENAME _ NEWFILE
|
||||
FILEPTR _ 0
|
||||
CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH))
|
||||
(create IMCOMPARE.CHUNK
|
||||
FILENAME _ OLDFILE
|
||||
FILEPTR _ 0
|
||||
CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH))
|
||||
HASH.TYPE
|
||||
(if (EQ GRAPH.REGION T)
|
||||
then (create REGION
|
||||
LEFT _ 25
|
||||
BOTTOM _ 25
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif GRAPH.REGION
|
||||
else (CLRPROMPT)
|
||||
(printout PROMPTWINDOW
|
||||
"Please specify a window for the file difference graph" T)
|
||||
(GETREGION)))
|
||||
else (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME
|
||||
" --- IMCOMPARE aborted" T])
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA LINE WORD))
|
||||
(NIL (SETQ HASH.TYPE 'PARA))
|
||||
(ERROR (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)))
|
||||
(LET ((NEWFILE (FINDFILE NEWFILENAME T))
|
||||
(OLDFILE (FINDFILE OLDFILENAME T)))
|
||||
(CL:UNLESS (AND OLDFILE NEWFILE)
|
||||
(ERROR "Can't find both files" (LIST NEWFILENAME OLDFILENAME)))
|
||||
(IMCOMPARE.CHUNKS (create IMCOMPARE.CHUNK
|
||||
FILENAME _ NEWFILE
|
||||
FILEPTR _ 0)
|
||||
(create IMCOMPARE.CHUNK
|
||||
FILENAME _ OLDFILE
|
||||
FILEPTR _ 0)
|
||||
HASH.TYPE
|
||||
(if (EQ GRAPH.REGION T)
|
||||
then (create REGION
|
||||
LEFT _ 25
|
||||
BOTTOM _ 25
|
||||
WIDTH _ 500
|
||||
HEIGHT _ 150)
|
||||
elseif GRAPH.REGION
|
||||
else (CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please specify a window for the file difference graph"
|
||||
T)
|
||||
(GETREGION))
|
||||
FILELABELS])
|
||||
|
||||
(IMCOMPARE.BOXNODE
|
||||
[LAMBDA (NODE WINDOW) (* rmk%: "14-Dec-84 13:40")
|
||||
@@ -86,401 +82,345 @@ Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation. All rights reserved.
|
||||
(SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW])
|
||||
|
||||
(IMCOMPARE.CHUNKS
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION)
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION FILELABELS)
|
||||
(* ; "Edited 18-Dec-2021 13:21 by rmk")
|
||||
(* ; "Edited 15-Dec-2021 16:28 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 12:32 by rmk")
|
||||
(* rmk%: " 8-Sep-84 00:06")
|
||||
|
||||
(* this is the main text-comparison function.
|
||||
It compares the text in the two chunks <which may be small pieces of files, or
|
||||
entire files> and produces a graph showing how the sub-chunks of the two main
|
||||
chunks are related. The two main chunks may be in the same file, and the file
|
||||
may actually be an open Tedit textstream.
|
||||
The main chunks are broken down according to HASH.TYPE, which may be PARA
|
||||
<chunk by paragraph>, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
|
||||
The file difference graph is displayed at GRAPH.REGION.)
|
||||
(* ;; "This is the main text-comparison function. It compares the text in the two chunks <which may be small pieces of files, or entire files> and produces a graph showing how the sub-chunks of the two main chunks are related. The two main chunks may be in the same file, and the file may actually be an open Tedit textstream. The main chunks are broken down according to HASH.TYPE, which may be PARA <chunk by paragraph>, LINE, WORD, or PARA. The file difference graph is displayed at GRAPH.REGION.")
|
||||
|
||||
(* this text comparison algorithm is originally from the article
|
||||
"A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM,
|
||||
V21, %#4, April 1978 --- major difference is that I use lists instead of arrays)
|
||||
(* ;; "This text comparison algorithm is originally from the article 'A Technique for Isolating Differences Between Files' by Paul Heckel, in CACM, V21, #4, April 1978 --- major difference is that I use lists instead of arrays")
|
||||
|
||||
(PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
|
||||
NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST)
|
||||
(* ;; "")
|
||||
|
||||
(* * collect lists of chunks from each of the main chunks, dividing them
|
||||
according to HASH.TYPE)
|
||||
(* ;; "Collect lists of chunks from each of the main chunks, dividing them according to HASH.TYPE. We start with whole-file chunks to provide the interface that the")
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE))
|
||||
(SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE))
|
||||
(LET ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
|
||||
(NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS NEWFILE.SPEC.CHUNK HASH.TYPE))
|
||||
(OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS OLDFILE.SPEC.CHUNK HASH.TYPE)))
|
||||
|
||||
(* * update the chunk symbol table. For each hash value, this table records the
|
||||
number of "new" chunks with that hash value, the number of "old" chunks with
|
||||
that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD chunk
|
||||
itself>.)
|
||||
(* ;; "Update the chunk symbol table. For each hash value, this table records the number of 'new' chunks with that hash value, the number of 'old' chunks with that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD c hunk itself>.")
|
||||
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
|
||||
(IMCOMPARE.UPDATE.SYMBOL.TABLE OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
|
||||
|
||||
(* * For every new chunk whose hash value matches EXACTLY ONE old chunk's
|
||||
value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK
|
||||
field to point to the appropriate place in the old chunk list <not the old
|
||||
chunk directly>. Also, make sure that OTHERCHUNK of the matching old chunk is
|
||||
non-NIL, so that unconnected old chunks will be merged correctly.)
|
||||
(* ;; "For every new chunk whose hash value matches EXACTLY ONE old chunk's value, 'connect' it to the old chunk by setting the new chunk's OTHERCHUNK field to point to the appropriate place in the old chunk list <not the old chunk directly>. Also, make sure that OTHERCHUNK of the matching old chunk is non-NIL, so that unconnected old chunks will be merged correctly.")
|
||||
|
||||
(for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB
|
||||
do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK)
|
||||
CHUNK.SYMBOL.TABLE))
|
||||
(if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB))
|
||||
(EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK
|
||||
with (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB))
|
||||
(replace (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of (CAR (fetch (IMCOMPARE.SYMB OLDPTR) of SYMB))
|
||||
with T)))
|
||||
(for NEW.CHUNK in NEWFILE.CHUNK.LIST bind SYMB
|
||||
do (SETQ SYMB (GETHASH (fetch (IMCOMPARE.CHUNK HASHVALUE) of NEW.CHUNK)
|
||||
CHUNK.SYMBOL.TABLE))
|
||||
(if (AND (EQ 1 (fetch (IMCOMPARE.SYMB NEWCOUNT) of SYMB))
|
||||
(EQ 1 (fetch (IMCOMPARE.SYMB OLDCOUNT) of SYMB)))
|
||||
then (replace (IMCOMPARE.CHUNK OTHERCHUNK) of NEW.CHUNK with (fetch (
|
||||
IMCOMPARE.SYMB
|
||||
OLDPTR)
|
||||
of SYMB))
|
||||
(replace (IMCOMPARE.CHUNK OTHERCHUNK) of (CAR (fetch (IMCOMPARE.SYMB OLDPTR)
|
||||
of SYMB)) with T)))
|
||||
|
||||
(* * merge connected chunks forward)
|
||||
(* ;; "Merge connected chunks forward")
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL)
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST NIL)
|
||||
|
||||
(* * merge connected chunks backwards)
|
||||
(* ;; "Merge connected chunks backwards")
|
||||
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T)
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS NEWFILE.CHUNK.LIST T)
|
||||
(SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
|
||||
(SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
|
||||
|
||||
(* * merge unconnected chunks)
|
||||
(* ;; "Merge unconnected chunks")
|
||||
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS NEWFILE.CHUNK.LIST)
|
||||
(IMCOMPARE.MERGE.UNCONNECTED.CHUNKS OLDFILE.CHUNK.LIST)
|
||||
|
||||
(* * now, the file comparison is complete.
|
||||
Format and display the file difference graph)
|
||||
(* ;; "The file comparison is complete. Format and display the file difference graph")
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK
|
||||
HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST])
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE
|
||||
GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST FILELABELS])
|
||||
|
||||
(IMCOMPARE.COLLECT.HASH.CHUNKS
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 23-Dec-98 16:54 by rmk:")
|
||||
(* mjs " 8-Jan-84 20:57")
|
||||
[LAMBDA (CHUNK HASH.TYPE) (* ; "Edited 22-Dec-2021 10:37 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 16:32 by rmk")
|
||||
(* ; "Edited 23-Dec-98 16:54 by rmk:")
|
||||
(* mjs " 8-Jan-84 20:57")
|
||||
|
||||
(* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE)
|
||||
(* ;;; "Returns a list of the chunks inside CHUNK as hashed of type HASH.TYPE. Presumably CHUNK is is higher on the ranking PARA > LINE >. WORD. The initial CHUNK covers the whole file, middle-mouse refinement-chunks cover only subsections.")
|
||||
|
||||
(LET (STREAM END.OF.CHUNK.PTR CHUNK.LIST)
|
||||
[SETQ STREAM (OPENSTREAM (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK)
|
||||
'INPUT
|
||||
'OLD
|
||||
'((TYPE TEXT]
|
||||
(SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(SETQ END.OF.CHUNK.PTR (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)))
|
||||
(SETQ CHUNK.LIST (until (IGEQ (GETFILEPTR STREAM)
|
||||
END.OF.CHUNK.PTR) collect (IMCOMPARE.HASH STREAM
|
||||
END.OF.CHUNK.PTR
|
||||
HASH.TYPE)))
|
||||
(CLOSEF STREAM)
|
||||
CHUNK.LIST])
|
||||
(* ;; "It is overkill to open raw text streams as TEDIT stream. So we open, test for TEDIT and if so, close and reoopen. TEDIT may not yet honor external formats other than XCCS for rawtext files.")
|
||||
|
||||
(BIND (FILENAME _ (fetch (IMCOMPARE.CHUNK FILENAME) of CHUNK))
|
||||
STREAM ENDPOS FIRST (SETQ STREAM (OPENSTREAM FILENAME 'INPUT 'OLD))
|
||||
(CL:WHEN (\TEDIT.FORMATTEDP1 STREAM)
|
||||
(CLOSEF STREAM) (* ;
|
||||
"The OBJECTCHAR is produced in place of image objects")
|
||||
[SETQ STREAM (OPENTEXTSTREAM FILENAME NIL NIL NIL
|
||||
`(OBJECTBYTE ,(CHARCODE NULL])
|
||||
(SETFILEINFO STREAM 'EOL 'ANY)
|
||||
(CL:UNLESS (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)
|
||||
|
||||
(* ;;
|
||||
"For TEDIT files, the character length isn't known until after text-opening")
|
||||
|
||||
(REPLACE (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK
|
||||
WITH (GETFILEINFO STREAM 'LENGTH)))
|
||||
(SETFILEPTR STREAM (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK))
|
||||
(SETQ ENDPOS (IPLUS (fetch (IMCOMPARE.CHUNK FILEPTR) of CHUNK)
|
||||
(fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of CHUNK)))
|
||||
WHILE (SETQ CHUNK (IMCOMPARE.HASH STREAM HASH.TYPE ENDPOS))
|
||||
COLLECT (REPLACE FILENAME OF CHUNK WITH FILENAME)
|
||||
CHUNK FINALLY (CLOSEF STREAM])
|
||||
|
||||
(IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
|
||||
[LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST
|
||||
OLDFILE.CHUNK.LIST) (* mjs "11-Jul-85 09:10")
|
||||
OLDFILE.CHUNK.LIST FILELABELS) (* ; "Edited 18-Dec-2021 13:16 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 10:48 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 12:19 by rmk")
|
||||
(* mjs "11-Jul-85 09:10")
|
||||
|
||||
(* * format and display the graph)
|
||||
(* ;;; "format and display the graph")
|
||||
|
||||
(PROG ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK))
|
||||
(OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK))
|
||||
(OLD.CHUNK.NODE.FROM.NODES NIL)
|
||||
(BORDERSIZE 1)
|
||||
GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD
|
||||
YCOORD.INCREMENT DIFF.GRAPH)
|
||||
(LET ((NEWFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of NEWFILE.SPEC.CHUNK))
|
||||
(OLDFILENAME (fetch (IMCOMPARE.CHUNK FILENAME) of OLDFILE.SPEC.CHUNK))
|
||||
NEWFILELABEL OLDFILELABEL (OLD.CHUNK.NODE.FROM.NODES NIL)
|
||||
(BORDERSIZE 1)
|
||||
GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD
|
||||
YCOORD.INCREMENT DIFF.GRAPH)
|
||||
|
||||
(* * set up GRAPH.WINDOW. This is done first so you can get the width and
|
||||
height of strings to be printed in the window.)
|
||||
(* ;;; "set up GRAPH.WINDOW. This is done first so you can get the width and height of strings to be printed in the window.")
|
||||
|
||||
[SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA NIL)
|
||||
"Paragraph")
|
||||
(LINE "Line")
|
||||
(WORD "Word")
|
||||
(SHOULDNT]
|
||||
(WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
|
||||
[WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
|
||||
(if (EQ WINDOW
|
||||
IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
then (SETQ
|
||||
IMCOMPARE.LAST.GRAPH.WINDOW
|
||||
NIL)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL]
|
||||
(SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW)
|
||||
2))
|
||||
[SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
|
||||
(IQUOTIENT (STRINGWIDTH
|
||||
OLDFILENAME
|
||||
GRAPH.WINDOW)
|
||||
2)
|
||||
20]
|
||||
[SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
|
||||
(fetch (REGION HEIGHT) of (STRINGREGION
|
||||
NEWFILENAME
|
||||
GRAPH.WINDOW]
|
||||
(SETQ NEWFILELABEL (OR (CAR (LISTP FILELABELS))
|
||||
NEWFILENAME))
|
||||
(SETQ OLDFILELABEL (OR (CADR (LISTP FILELABELS))
|
||||
OLDFILENAME))
|
||||
[SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
|
||||
(SELECTQ HASH.TYPE
|
||||
((PARA NIL)
|
||||
"Paragraph")
|
||||
(LINE "Line")
|
||||
(WORD "Word")
|
||||
(SHOULDNT]
|
||||
(WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
|
||||
[WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
|
||||
(if (EQ WINDOW IMCOMPARE.LAST.GRAPH.WINDOW)
|
||||
then (SETQ IMCOMPARE.LAST.GRAPH.WINDOW
|
||||
NIL)
|
||||
(SETQ IMCOMPARE.LAST.NODE NIL]
|
||||
(SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILELABEL GRAPH.WINDOW)
|
||||
2))
|
||||
[SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
|
||||
(IQUOTIENT (STRINGWIDTH
|
||||
OLDFILELABEL
|
||||
GRAPH.WINDOW)
|
||||
2)
|
||||
20]
|
||||
[SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
|
||||
(fetch (REGION HEIGHT) of (STRINGREGION NEWFILELABEL
|
||||
GRAPH.WINDOW]
|
||||
|
||||
(* * collect new-chunk graph nodes, while accumulating
|
||||
OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks)
|
||||
(* ;;; "collect new-chunk graph nodes, while accumulating OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks")
|
||||
|
||||
(SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from
|
||||
YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK
|
||||
collect (SETQ CORRESPONDING.OLD.CHUNK
|
||||
(CAR (fetch (IMCOMPARE.CHUNK OTHERCHUNK)
|
||||
of NEW.CHUNK)))
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (SETQ OLD.CHUNK.NODE.FROM.NODES
|
||||
(CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
|
||||
OLD.CHUNK.NODE.FROM.NODES)))
|
||||
(* Start out with 2 point white
|
||||
border, so we can invert it)
|
||||
(NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK
|
||||
FILEPTR)
|
||||
of NEW.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of NEW.CHUNK))
|
||||
12)
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (LIST CORRESPONDING.OLD.CHUNK)
|
||||
else NIL)
|
||||
NIL DEFAULTFONT -2)))
|
||||
(SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from
|
||||
YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK
|
||||
collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK
|
||||
(SETQ NEW.CHUNK.NODES (for NEW.CHUNK in NEWFILE.CHUNK.LIST as Y from YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.OLD.CHUNK
|
||||
collect (SETQ CORRESPONDING.OLD.CHUNK (CAR (fetch (IMCOMPARE.CHUNK
|
||||
OTHERCHUNK)
|
||||
of NEW.CHUNK)))
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (SETQ OLD.CHUNK.NODE.FROM.NODES
|
||||
(CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
|
||||
OLD.CHUNK.NODE.FROM.NODES)))
|
||||
(* ;
|
||||
"Start out with 2 point white border, so we can invert it")
|
||||
(NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK FILEPTR
|
||||
) of NEW.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of NEW.CHUNK))
|
||||
12)
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
(if CORRESPONDING.OLD.CHUNK
|
||||
then (LIST CORRESPONDING.OLD.CHUNK)
|
||||
else NIL)
|
||||
NIL DEFAULTFONT -2)))
|
||||
(SETQ OLD.CHUNK.NODES (for OLD.CHUNK in OLDFILE.CHUNK.LIST as Y from YCOORD.INCREMENT
|
||||
by YCOORD.INCREMENT bind CORRESPONDING.NEW.CHUNK
|
||||
collect (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK
|
||||
OLD.CHUNK.NODE.FROM.NODES
|
||||
)))
|
||||
(NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK
|
||||
FILEPTR)
|
||||
of OLD.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of OLD.CHUNK))
|
||||
12 "-")
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
NIL
|
||||
(if CORRESPONDING.NEW.CHUNK
|
||||
then (LIST CORRESPONDING.NEW.CHUNK)
|
||||
else NIL)
|
||||
DEFAULTFONT -2)))
|
||||
(SETQ DIFF.GRAPH (create GRAPH
|
||||
DIRECTEDFLG _ T
|
||||
SIDESFLG _ T
|
||||
GRAPHNODES _
|
||||
(NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
NEW.CHUNK.NODES
|
||||
(LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
OLD.CHUNK.NODES)))
|
||||
(SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
|
||||
T NIL])
|
||||
)))
|
||||
(NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM
|
||||
(PACK* (fetch (IMCOMPARE.CHUNK FILEPTR
|
||||
) of OLD.CHUNK)
|
||||
":"
|
||||
(fetch (IMCOMPARE.CHUNK
|
||||
CHUNKLENGTH)
|
||||
of OLD.CHUNK))
|
||||
12 "-")
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ Y)
|
||||
NIL
|
||||
(if CORRESPONDING.NEW.CHUNK
|
||||
then (LIST CORRESPONDING.NEW.CHUNK)
|
||||
else NIL)
|
||||
DEFAULTFONT -2)))
|
||||
(SETQ DIFF.GRAPH (create GRAPH
|
||||
DIRECTEDFLG _ T
|
||||
SIDESFLG _ T
|
||||
GRAPHNODES _
|
||||
(NCONC (LIST (NODECREATE NEWFILENAME NEWFILELABEL
|
||||
(create POSITION
|
||||
XCOORD _ NEW.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
NEW.CHUNK.NODES
|
||||
(LIST (NODECREATE OLDFILENAME OLDFILELABEL
|
||||
(create POSITION
|
||||
XCOORD _ OLD.CHUNK.XCOORD
|
||||
YCOORD _ 0)
|
||||
NIL NIL DEFAULTFONT -2))
|
||||
OLD.CHUNK.NODES)))
|
||||
(GRAPHERPROP DIFF.GRAPH 'FILELABELS (LIST NEWFILELABEL OLDFILELABEL))
|
||||
(* ;
|
||||
"So Middle mouse graphs can get the right labels")
|
||||
(GRAPHERPROP DIFF.GRAPH 'HASH.TYPE HASH.TYPE)
|
||||
(SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
|
||||
(FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
|
||||
T NIL])
|
||||
|
||||
(IMCOMPARE.FIND.TEDIT.TEXT.OBJECT
|
||||
[LAMBDA (FILE) (* mjs " 2-Jan-84 16:19")
|
||||
[LAMBDA (FILE) (* ; "Edited 16-Dec-2021 08:40 by rmk")
|
||||
(* mjs " 2-Jan-84 16:19")
|
||||
|
||||
(* returns the Tedit text object of the first Tedit window which is currently
|
||||
looking at FILE, if there is one. Returns NIL if none is found.)
|
||||
(* ;; "returns the Tedit text object of the first Tedit window which is currently looking at FILE, if there is one. Returns NIL if none is found.")
|
||||
|
||||
(PROG ((TEDIT.TEXT.OBJECT NIL))
|
||||
(for X in (OPENWINDOWS) bind POSS.TOBJ POSS.FILENAME
|
||||
when (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil TEDIT.TEXT.OBJECT
|
||||
do (SETQ POSS.FILENAME (FULLNAME (fetch (TEXTOBJ TXTFILE) of POSS.TOBJ)))
|
||||
(if (EQ FILE POSS.FILENAME)
|
||||
then (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ)))
|
||||
(RETURN TEDIT.TEXT.OBJECT])
|
||||
(for W in (OPENWINDOWS) bind POSS.TOBJ when [AND (SETQ POSS.TOBJ (WINDOWPROP W 'TEXTOBJ))
|
||||
(EQ FILE (FULLNAME (fetch (TEXTOBJ TXTFILE)
|
||||
of POSS.TOBJ]
|
||||
unless (TEDIT.STREAMCHANGEDP POSS.TOBJ) do (RETURN POSS.TOBJ])
|
||||
|
||||
(IMCOMPARE.HASH
|
||||
[LAMBDA (STREAM EOF.PTR HASH.TYPE) (* ; "Edited 23-Dec-98 16:58 by rmk:")
|
||||
[LAMBDA (STREAM HASH.TYPE ENDPOS) (* ; "Edited 19-Dec-2021 09:07 by rmk")
|
||||
(* ; "Edited 15-Dec-2021 15:58 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 16:35 by rmk")
|
||||
(* ; "Edited 23-Dec-98 16:58 by rmk:")
|
||||
|
||||
(* reads caracters from STREAM and creates a hash value for the "next" "chunk"
|
||||
A chunk is a paragraph ending in two consecutive CRs <HASH.TYPE = NIL or PARA>,
|
||||
a line ending in a CR <HASH.TYPE = LINE>, or a word ending in any white space
|
||||
character space <HASH.TYPE = WORD>. In computing the hash value, white space is
|
||||
ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR
|
||||
Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the
|
||||
beginning of the chunk, the length of the chunk, and the fullname of the stream)
|
||||
(* ;; "IMCOMPARE.HASH automatically stops before reading char number EOF.PTR.")
|
||||
|
||||
(* Note%: Most of the time in COMPARETEXT is spent reading in and hashing
|
||||
chunks, so this function was optimizes for speed, at the expense of length)
|
||||
(* ;; "Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the beginning of the chunk, the length of the chunk, and the fullname of the stream")
|
||||
|
||||
(PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM))
|
||||
(EOLC (GETFILEINFO STREAM 'EOL))
|
||||
(HASHNUM 0)
|
||||
FILE.PTR C)
|
||||
(SETQ FILE.PTR BEGIN.FILE.PTR)
|
||||
(SELECTQ HASH.TYPE
|
||||
((NIL PARA)
|
||||
(* ;; "Note: Most of the time in COMPARETEXT is spent reading in and hashing chunks, so this function was optimizes for speed, at the expense of length")
|
||||
|
||||
(* Paragraph chunks end with two consecutive EOL's.
|
||||
In order to detect this without slowing down the gobbling of normal chars,
|
||||
LAST.EOL.POS is set to the filepos of the last EOL detected.
|
||||
This is only checked when another EOL comes along.)
|
||||
(LET ((STARTPOS (GETFILEPTR STREAM))
|
||||
(HASHNUM 0)
|
||||
C NBYTES)
|
||||
(DECLARE (SPECVARS NBYTES))
|
||||
(SETQ NBYTES (IDIFFERENCE ENDPOS STARTPOS)) (* ;
|
||||
"\INCCODE counts down. We reach NBYTES only on the chunk")
|
||||
|
||||
(PROG ((LAST.EOL.POS -5))
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
(CR
|
||||
(* ;; "Don't hash on white space")
|
||||
|
||||
(* If this is the second consecutive CR, this is the end of the chunk.
|
||||
Otherwise, reset LAST.EOL.POS)
|
||||
|
||||
(SELECTQ EOLC
|
||||
(CR (if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM))))
|
||||
(CRLF (if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SELCHARQ (\PEEKBIN STREAM T)
|
||||
(LF (SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(BIN STREAM)
|
||||
(if (IEQP LAST.EOL.POS (IDIFFERENCE
|
||||
(GETFILEPTR STREAM)
|
||||
2))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM
|
||||
))))
|
||||
NIL))
|
||||
NIL))
|
||||
(LF [COND
|
||||
((EQ EOLC 'LF)
|
||||
(if (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
|
||||
then (GO endchunk)
|
||||
else (SETQ LAST.EOL.POS (GETFILEPTR STREAM])
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(LINE (* Line chunks end on a single CR.)
|
||||
(PROG NIL
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
(CR (SELECTQ EOLC
|
||||
(CR (GO endchunk))
|
||||
(LF)
|
||||
(CRLF (if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SELCHARQ (\PEEKBIN STREAM T)
|
||||
(LF (SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(BIN STREAM)
|
||||
(GO endchunk))
|
||||
NIL))
|
||||
(SHOULDNT)))
|
||||
(LF (AND (EQ EOLC 'LF)
|
||||
(GO endchunk)))
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(WORD (* word chunks end on any white
|
||||
space)
|
||||
(PROG NIL
|
||||
loop
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (SETQ C (BIN STREAM))
|
||||
((CR SPACE TAB LF)
|
||||
(GO endchunk))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(GO loop)))
|
||||
(HELP (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)
|
||||
"
|
||||
Should be PARA, LINE, or WORD"))
|
||||
endchunk
|
||||
(* flush all white space before next
|
||||
chunk)
|
||||
(if (IGEQ FILE.PTR EOF.PTR)
|
||||
then (GO return))
|
||||
(SETQ FILE.PTR (ADD1 FILE.PTR))
|
||||
(SELCHARQ (BIN STREAM)
|
||||
((CR SPACE TAB LF)
|
||||
(GO endchunk))
|
||||
(PROGN (SETQ FILE.PTR (SUB1 FILE.PTR))
|
||||
(SETFILEPTR STREAM FILE.PTR)))
|
||||
return
|
||||
(RETURN (create IMCOMPARE.CHUNK
|
||||
HASHVALUE _ HASHNUM
|
||||
FILEPTR _ BEGIN.FILE.PTR
|
||||
CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR)
|
||||
FILENAME _ (FULLNAME STREAM])
|
||||
(CL:WHEN (IGREATERP NBYTES 0)
|
||||
(SELECTQ HASH.TYPE
|
||||
(PARA (* ;
|
||||
"Paragraph chunks end with two consecutive EOL's.")
|
||||
(BIND EOLSEEN WHILE (IGREATERP NBYTES 0)
|
||||
DO (SELCHARQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
|
||||
(EOL (CL:WHEN EOLSEEN (RETURN))
|
||||
(SETQ EOLSEEN T) (* ; "Skip the NIL SETQ below")
|
||||
(GO $$ITERATE))
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16)))
|
||||
(SETQ EOLSEEN NIL)))
|
||||
(LINE (* ; "Line chunks end on EOL.")
|
||||
[WHILE (IGREATERP NBYTES 0)
|
||||
DO (SELCHARQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
|
||||
(EOL (RETURN))
|
||||
((SPACE TAB))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16])
|
||||
(WORD (* ;
|
||||
"word chunks end on any white space")
|
||||
[WHILE (IGREATERP NBYTES 0)
|
||||
DO (SELECTQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
|
||||
((SPACE EOL TAB)
|
||||
(RETURN))
|
||||
(SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
|
||||
1 16)
|
||||
1 16)
|
||||
1 16])
|
||||
(SHOULDNT)) (* ;
|
||||
"flush all white space before next chunk")
|
||||
(WHILE (IGREATERP NBYTES 0) DO (SELCHARQ (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES)
|
||||
((EOL SPACE TAB))
|
||||
(RETURN)))
|
||||
(CREATE IMCOMPARE.CHUNK
|
||||
HASHVALUE _ HASHNUM
|
||||
FILEPTR _ STARTPOS
|
||||
CHUNKLENGTH _ (IDIFFERENCE (GETFILEPTR STREAM)
|
||||
STARTPOS)))])
|
||||
|
||||
(IMCOMPARE.LEFTBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* mjs " 2-Apr-85 14:21")
|
||||
[LAMBDA (GNODE WINDOW) (* ; "Edited 18-Dec-2021 13:02 by rmk")
|
||||
(* mjs " 2-Apr-85 14:21")
|
||||
(if GNODE
|
||||
then (IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(PROG ((NODEID (fetch (GRAPHNODE NODEID) of GNODE))
|
||||
(FILEPTR 1)
|
||||
(CHUNKLENGTH 0)
|
||||
(TEDIT.TEXT.OBJECT NIL)
|
||||
FILE)
|
||||
(SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID))
|
||||
(SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID))
|
||||
(SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID))
|
||||
(SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE))
|
||||
(if TEDIT.TEXT.OBJECT
|
||||
then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25))
|
||||
0
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of
|
||||
|
||||
TEDIT.TEXT.OBJECT
|
||||
))
|
||||
'PROCESS))
|
||||
else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH])
|
||||
then (LET ((NODEID (fetch (GRAPHNODE NODEID) of GNODE)))
|
||||
(IF (FIXP (CAR NODEID))
|
||||
THEN (IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
[LET ((FILEPTR 1)
|
||||
(CHUNKLENGTH 0)
|
||||
(TEDIT.TEXT.OBJECT NIL)
|
||||
FILE)
|
||||
(SETQ FILE (fetch (IMCOMPARE.CHUNK FILENAME) of NODEID))
|
||||
(SETQ FILEPTR (fetch (IMCOMPARE.CHUNK FILEPTR) of NODEID))
|
||||
(SETQ CHUNKLENGTH (fetch (IMCOMPARE.CHUNK CHUNKLENGTH) of NODEID))
|
||||
(SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT FILE))
|
||||
(if TEDIT.TEXT.OBJECT
|
||||
then (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR
|
||||
25))
|
||||
0
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH
|
||||
'LEFT)
|
||||
(TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
|
||||
(TTY.PROCESS (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW)
|
||||
of TEDIT.TEXT.OBJECT))
|
||||
'PROCESS))
|
||||
else (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH]
|
||||
ELSEIF (AND (LITATOM NODEID)
|
||||
(INFILEP NODEID))
|
||||
THEN
|
||||
(* ;;
|
||||
"A file name as a column header, do TEDIT on the whole file, no selection")
|
||||
|
||||
(TEDIT-SEE NODEID)
|
||||
ELSE (SHOULDNT])
|
||||
|
||||
(IMCOMPARE.LENGTHEN.ATOM
|
||||
[LAMBDA (X MIN.LENGTH EXTENDER) (* mjs "30-Dec-83 15:11")
|
||||
[LAMBDA (X MIN.LENGTH EXTENDER) (* ; "Edited 13-Dec-2021 21:18 by rmk")
|
||||
(* mjs "30-Dec-83 15:11")
|
||||
|
||||
(* makes sure that the atom X is at least MIN.LENGTH characters long, by
|
||||
concatinating the first character of EXTENDER
|
||||
(or space, if not given) to the front)
|
||||
(* ;; "makes sure that the atom X is at least MIN.LENGTH characters long, by concatenating the first character of EXTENDER (or space, if not given) to the front")
|
||||
|
||||
(PROG ((C (CHCON X)))
|
||||
(SETQ EXTENDER (if EXTENDER
|
||||
then (CHCON1 EXTENDER)
|
||||
else (CHARCODE SPACE)))
|
||||
(while (ILESSP (LENGTH C)
|
||||
MIN.LENGTH) do (SETQ C (CONS EXTENDER C)))
|
||||
(RETURN (PACKC C])
|
||||
(IF (ILESSP (NCHARS X)
|
||||
MIN.LENGTH)
|
||||
THEN (PACK* (ALLOCSTRING (IDIFFERENCE MIN.LENGTH (NCHARS X))
|
||||
(CL:IF EXTENDER
|
||||
(NTHCHAR EXTENDER 1)
|
||||
" "))
|
||||
X)
|
||||
ELSE X])
|
||||
|
||||
(IMCOMPARE.MERGE.CONNECTED.CHUNKS
|
||||
[LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG) (* mjs " 6-Jan-84 10:35")
|
||||
@@ -551,45 +491,44 @@ Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation. All rights reserved.
|
||||
(RPLACD CHUNK.LST (CDDR CHUNK.LST])
|
||||
|
||||
(IMCOMPARE.MIDDLEBUTTONFN
|
||||
[LAMBDA (GNODE WINDOW) (* mjs " 6-Jan-84 11:37")
|
||||
[LAMBDA (GNODE WINDOW)
|
||||
|
||||
(* This function is called if the MIDDLE mouse button is pressed over a graph
|
||||
node. The selected node is IMCOMPARE-ed with the last node selected <which is
|
||||
boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a
|
||||
pop-up menu. If none of the hashing types is selected, the current node is
|
||||
boxed. The pop-up menu is always located a little above the current cursor
|
||||
position, so a quick double-MIDDLE-click is an easy way to change the current
|
||||
boxed node.)
|
||||
(* ;; "Edited 16-Dec-2021 10:55 by rmk: Remove previous HASH.TYPE from the middle mouse menu")
|
||||
(* ; "Edited 16-Dec-2021 10:51 by rmk")
|
||||
(* mjs " 6-Jan-84 11:37")
|
||||
|
||||
(* ;; "This function is called if the MIDDLE mouse button is pressed over a graph node. The selected node is IMCOMPARE-ed with the last node selected <which is boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a pop-up menu. If none of the hashing types is selected, the current node is boxed. The pop-up menu is always located a little above the current cursor position, so a quick double-MIDDLE-click is an easy way to change the current boxed node.")
|
||||
|
||||
(if GNODE
|
||||
then (PROG (INNER.HASH.TYPE)
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please select the type of hashing you wish." T)
|
||||
[SETQ INNER.HASH.TYPE
|
||||
(MENU (if (type? MENU IMCOMPARE.HASH.TYPE.MENU)
|
||||
then IMCOMPARE.HASH.TYPE.MENU
|
||||
else (SETQ IMCOMPARE.HASH.TYPE.MENU
|
||||
(create MENU
|
||||
ITEMS _ '(PARA LINE WORD)
|
||||
MENUOFFSET _
|
||||
(create POSITION
|
||||
XCOORD _ 20
|
||||
YCOORD _ -20]
|
||||
(if (NULL INNER.HASH.TYPE)
|
||||
then (* if no hash type is selected, just
|
||||
box the current node and return)
|
||||
(IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(RETURN))
|
||||
(if (NULL IMCOMPARE.LAST.NODE)
|
||||
then (CLRPROMPT)
|
||||
(PRIN1 "You must select another graph node first." PROMPTWINDOW)
|
||||
(RETURN))
|
||||
(printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
|
||||
(IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE
|
||||
)
|
||||
(fetch (GRAPHNODE NODEID) of GNODE)
|
||||
INNER.HASH.TYPE
|
||||
(WINDOWPROP WINDOW 'REGION])
|
||||
(CLRPROMPT)
|
||||
(printout PROMPTWINDOW "Please select the type of hashing you wish." T)
|
||||
[SETQ INNER.HASH.TYPE (MENU (create MENU
|
||||
ITEMS _ (REMOVE (GRAPHERPROP
|
||||
(WINDOWPROP WINDOW
|
||||
'GRAPH)
|
||||
'HASH.TYPE)
|
||||
'(PARA LINE WORD))
|
||||
MENUOFFSET _
|
||||
(create POSITION
|
||||
XCOORD _ 20
|
||||
YCOORD _ -20]
|
||||
(if (NULL INNER.HASH.TYPE)
|
||||
then (* ;
|
||||
"if no hash type is selected, just box the current node and return")
|
||||
(IMCOMPARE.BOXNODE GNODE WINDOW)
|
||||
(RETURN))
|
||||
(if (NULL IMCOMPARE.LAST.NODE)
|
||||
then (CLRPROMPT)
|
||||
(PRIN1 "You must select another graph node first." PROMPTWINDOW)
|
||||
(RETURN))
|
||||
(printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
|
||||
(IMCOMPARE.CHUNKS (fetch (GRAPHNODE NODEID) of IMCOMPARE.LAST.NODE)
|
||||
(fetch (GRAPHNODE NODEID) of GNODE)
|
||||
INNER.HASH.TYPE
|
||||
(WINDOWPROP WINDOW 'REGION)
|
||||
(GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
|
||||
'FILELABELS])
|
||||
|
||||
(IMCOMPARE.SHOW.DIST
|
||||
[LAMBDA (LST MAX) (* mjs "30-Dec-83 15:13")
|
||||
@@ -634,27 +573,31 @@ Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(MOVD 'COMPARETEXT 'IMCOMPARE)
|
||||
|
||||
(RPAQQ IMCOMPARE.LAST.NODE NIL)
|
||||
(RPAQ? IMCOMPARE.LAST.NODE NIL)
|
||||
|
||||
(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
|
||||
(RPAQQ IMCOMPARE.HASH.TYPE.MENU NIL)
|
||||
(RPAQ? IMCOMPARE.LAST.GRAPH.WINDOW NIL)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD IMCOMPARE.CHUNK (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK)
|
||||
FILEPTR _ 1 CHUNKLENGTH _ 0)
|
||||
FILEPTR _ 1)
|
||||
|
||||
(RECORD IMCOMPARE.SYMB (NEWCOUNT OLDCOUNT . OLDPTR))
|
||||
)
|
||||
|
||||
(FILESLOAD GRAPHER)
|
||||
(FILESLOAD (SYSLOAD)
|
||||
GRAPHER)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
GRAPHER)
|
||||
)
|
||||
(PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1365 39345 (COMPARETEXT 1375 . 3770) (IMCOMPARE.BOXNODE 3772 . 4288) (IMCOMPARE.CHUNKS
|
||||
4290 . 8476) (IMCOMPARE.COLLECT.HASH.CHUNKS 8478 . 9707) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9709
|
||||
. 18575) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18577 . 19340) (IMCOMPARE.HASH 19342 . 26603) (
|
||||
IMCOMPARE.LEFTBUTTONFN 26605 . 28341) (IMCOMPARE.LENGTHEN.ATOM 28343 . 28981) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 28983 . 32479) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32481 . 34436) (
|
||||
IMCOMPARE.MIDDLEBUTTONFN 34438 . 37010) (IMCOMPARE.SHOW.DIST 37012 . 37458) (
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE 37460 . 39343)))))
|
||||
(FILEMAP (NIL (1334 38876 (COMPARETEXT 1344 . 3554) (IMCOMPARE.BOXNODE 3556 . 4072) (IMCOMPARE.CHUNKS
|
||||
4074 . 8592) (IMCOMPARE.COLLECT.HASH.CHUNKS 8594 . 11053) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
|
||||
11055 . 20136) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 20138 . 20912) (IMCOMPARE.HASH 20914 . 25101) (
|
||||
IMCOMPARE.LEFTBUTTONFN 25103 . 27545) (IMCOMPARE.LENGTHEN.ATOM 27547 . 28249) (
|
||||
IMCOMPARE.MERGE.CONNECTED.CHUNKS 28251 . 31747) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 31749 . 33704) (
|
||||
IMCOMPARE.MIDDLEBUTTONFN 33706 . 36541) (IMCOMPARE.SHOW.DIST 36543 . 36989) (
|
||||
IMCOMPARE.UPDATE.SYMBOL.TABLE 36991 . 38874)))))
|
||||
STOP
|
||||
|
||||
299
sources/ATBL
299
sources/ATBL
@@ -1,11 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Oct-2021 21:53:59" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;28 92451
|
||||
(FILECREATED "19-Dec-2021 14:09:43" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;31 91882
|
||||
|
||||
changes to%: (FNS MAKE-READER-ENVIRONMENT)
|
||||
:CHANGES-TO (FNS EQUAL-READER-ENVIRONMENT)
|
||||
|
||||
previous date%: "24-Oct-2021 20:14:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;27)
|
||||
:PREVIOUS-DATE "24-Oct-2021 21:53:59"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>ATBL.;29)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -16,7 +16,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(RPAQQ ATBLCOMS
|
||||
[(COMS (* ;
|
||||
"Common features of read and terminal tables")
|
||||
"Common features of read and terminal tables")
|
||||
(DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
|
||||
(RECORDS CHARTABLE))
|
||||
(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
|
||||
@@ -39,9 +39,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
\SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
|
||||
(PROP ARGNAMES READTABLEPROP)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
|
||||
"READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
|
||||
"READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
|
||||
(* ;
|
||||
"OTHER must be zero because of initialization.")
|
||||
"OTHER must be zero because of initialization.")
|
||||
[VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
|
||||
(FUNCTION (LAMBDA
|
||||
(PAIR)
|
||||
@@ -50,7 +50,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CADR PAIR]
|
||||
(MACROS \COMPUTED.FORM)
|
||||
(* ;
|
||||
"This macro ought to be official somehow")
|
||||
"This macro ought to be official somehow")
|
||||
(RECORDS CONTEXTS ESCAPES WAKEUPS)
|
||||
(EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
|
||||
(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
|
||||
@@ -66,7 +66,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(FNS \ATBLSET)
|
||||
(INITRECORDS READER-ENVIRONMENT)
|
||||
(* ;
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
|
||||
(INITVARS (*LISP-PACKAGE*)
|
||||
(*INTERLISP-PACKAGE*)
|
||||
@@ -85,30 +85,27 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ;
|
||||
"0 is either NONE.TC, REAL.CCE, or OTHER.RC")
|
||||
(COND
|
||||
((IGREATERP CHAR \MAXTHINCHAR)
|
||||
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
|
||||
(GETHASH CHAR (fetch (CHARTABLE NSCHARHASH)
|
||||
of TABLE)))
|
||||
0))
|
||||
(T (\GETBASEBYTE TABLE CHAR])
|
||||
(CHECK (type? CHARTABLE TABLE)) (* ;
|
||||
"0 is either NONE.TC, REAL.CCE, or OTHER.RC")
|
||||
(COND
|
||||
((IGREATERP CHAR \MAXTHINCHAR)
|
||||
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
|
||||
(GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) of TABLE)))
|
||||
0))
|
||||
(T (\GETBASEBYTE TABLE CHAR])
|
||||
|
||||
(PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE)
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ;
|
||||
"0 is REAL.CCE, NONE.TC, OTHER.RC")
|
||||
(COND
|
||||
((ILEQ CHAR \MAXTHINCHAR)
|
||||
(\PUTBASEBYTE TABLE CHAR CODE))
|
||||
(T (\SETFATSYNCODE TABLE CHAR CODE])
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ; "0 is REAL.CCE, NONE.TC, OTHER.RC")
|
||||
(COND
|
||||
((ILEQ CHAR \MAXTHINCHAR)
|
||||
(\PUTBASEBYTE TABLE CHAR CODE))
|
||||
(T (\SETFATSYNCODE TABLE CHAR CODE])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE CHARTABLE ((CHARSET0 256 BYTE)
|
||||
(NSCHARHASH FULLPOINTER)))
|
||||
(NSCHARHASH FULLPOINTER)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'CHARTABLE
|
||||
@@ -402,11 +399,11 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
|
||||
"added size argument for creation of \ORIGTERMTABLE during initialization.")
|
||||
(LIST 'HASHARRAY (OR (CAR ARGS)
|
||||
'\NSCHARHASHKEYS)
|
||||
'\NSCHARHASHOVERFLOW)))
|
||||
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
|
||||
"added size argument for creation of \ORIGTERMTABLE during initialization.")
|
||||
(LIST 'HASHARRAY (OR (CAR ARGS)
|
||||
'\NSCHARHASHKEYS)
|
||||
'\NSCHARHASHOVERFLOW)))
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
@@ -924,8 +921,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
|
||||
)
|
||||
|
||||
(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC
|
||||
RETYPE.TC CTRLV.TC))
|
||||
(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC
|
||||
CTRLV.TC))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ NONE.TC 0)
|
||||
@@ -950,14 +947,14 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24))
|
||||
(TERMCLASS (LOGAND DATUM 7))) (* ;
|
||||
"We assume that values are appropriately shifted")
|
||||
(CREATE (LOGOR CCECHO TERMCLASS)))
|
||||
(TERMCLASS (LOGAND DATUM 7))) (* ;
|
||||
"We assume that values are appropriately shifted")
|
||||
(CREATE (LOGOR CCECHO TERMCLASS)))
|
||||
|
||||
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL
|
||||
EMPTYCHDEL (CONTROLFLG FLAG)
|
||||
(ECHOFLG FLAG))
|
||||
TERMSA _ (create CHARTABLE))
|
||||
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL
|
||||
(CONTROLFLG FLAG)
|
||||
(ECHOFLG FLAG))
|
||||
TERMSA _ (create CHARTABLE))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
|
||||
@@ -1440,9 +1437,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PACKAGEDELIM (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
|
||||
|
||||
(RPAQ READCLASSES [MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR)
|
||||
(LIST (PACK* (CAR PAIR)
|
||||
".RC")
|
||||
(CADR PAIR])
|
||||
(LIST (PACK* (CAR PAIR)
|
||||
".RC")
|
||||
(CADR PAIR])
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1452,60 +1449,60 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS CONTEXTS ((KEY (SELECTC DATUM
|
||||
(ALWAYS.RMC 'ALWAYS)
|
||||
(FIRST.RMC 'FIRST)
|
||||
(ALONE.RMC 'ALONE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
(ALWAYS ALWAYS.RMC)
|
||||
(FIRST FIRST.RMC)
|
||||
(ALONE ALONE.RMC)
|
||||
NIL))))
|
||||
(ALWAYS.RMC 'ALWAYS)
|
||||
(FIRST.RMC 'FIRST)
|
||||
(ALONE.RMC 'ALONE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
(ALWAYS ALWAYS.RMC)
|
||||
(FIRST FIRST.RMC)
|
||||
(ALONE ALONE.RMC)
|
||||
NIL))))
|
||||
|
||||
(ACCESSFNS ESCAPES ((KEY (SELECTC DATUM
|
||||
(ESC.RME 'ESCQUOTE)
|
||||
(NOESC.RME 'NOESCQUOTE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((ESCQUOTE ESC)
|
||||
ESC.RME)
|
||||
((NOESCQUOTE NOESC)
|
||||
NOESC.RME)
|
||||
NIL))))
|
||||
(ESC.RME 'ESCQUOTE)
|
||||
(NOESC.RME 'NOESCQUOTE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((ESCQUOTE ESC)
|
||||
ESC.RME)
|
||||
((NOESCQUOTE NOESC)
|
||||
NOESC.RME)
|
||||
NIL))))
|
||||
|
||||
(ACCESSFNS WAKEUPS ((KEY (SELECTC DATUM
|
||||
(IMMEDIATE.RMW 'IMMEDIATE)
|
||||
(NONIMMEDIATE.RMW
|
||||
'NONIMMEDIATE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((IMMEDIATE IMMED WAKEUP)
|
||||
IMMEDIATE.RMW)
|
||||
((NONIMMEDIATE NONIMMED NOWAKEUP)
|
||||
NONIMMEDIATE.RMW)
|
||||
NIL))))
|
||||
(IMMEDIATE.RMW 'IMMEDIATE)
|
||||
(NONIMMEDIATE.RMW
|
||||
'NONIMMEDIATE)
|
||||
NIL))
|
||||
(VAL (SELECTQ DATUM
|
||||
((IMMEDIATE IMMED WAKEUP)
|
||||
IMMEDIATE.RMW)
|
||||
((NONIMMEDIATE NONIMMED NOWAKEUP)
|
||||
NONIMMEDIATE.RMW)
|
||||
NIL))))
|
||||
)
|
||||
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \GETREADMACRODEF MACRO ((C TBL)
|
||||
(GETHASH C (fetch READMACRODEFS of TBL))))
|
||||
(GETHASH C (fetch READMACRODEFS of TBL))))
|
||||
|
||||
(PUTPROPS \GTREADTABLE MACRO [ARGS (COND
|
||||
[(LITATOM (CAR ARGS))
|
||||
(SUBPAIR '(X . FLG)
|
||||
ARGS
|
||||
'(SELECTQ X
|
||||
((NIL T)
|
||||
(\DTEST *READTABLE* 'READTABLEP))
|
||||
(\GTREADTABLE1 X . FLG]
|
||||
(T 'IGNOREMACRO])
|
||||
[(LITATOM (CAR ARGS))
|
||||
(SUBPAIR '(X . FLG)
|
||||
ARGS
|
||||
'(SELECTQ X
|
||||
((NIL T)
|
||||
(\DTEST *READTABLE* 'READTABLEP))
|
||||
(\GTREADTABLE1 X . FLG]
|
||||
(T 'IGNOREMACRO])
|
||||
|
||||
(PUTPROPS \GTREADTABLE1 DMACRO [ARGS (COND
|
||||
[(NULL (CDR ARGS))
|
||||
(LIST '\DTEST (CAR ARGS)
|
||||
''READTABLEP]
|
||||
(T 'IGNOREMACRO])
|
||||
[(NULL (CDR ARGS))
|
||||
(LIST '\DTEST (CAR ARGS)
|
||||
''READTABLEP]
|
||||
(T 'IGNOREMACRO])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1524,7 +1521,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
|
||||
(WAKEUPMASK (LOGOR MACROBIT 2))))
|
||||
(WAKEUPMASK (LOGOR MACROBIT 2))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
|
||||
@@ -1537,8 +1534,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
|
||||
(FIRST.RMC (LOGOR MACROBIT 0))
|
||||
(ALONE.RMC (LOGOR MACROBIT 1))))
|
||||
(FIRST.RMC (LOGOR MACROBIT 0))
|
||||
(ALONE.RMC (LOGOR MACROBIT 1))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
|
||||
@@ -1604,7 +1601,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2))
|
||||
(NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
|
||||
(NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))
|
||||
@@ -1617,7 +1614,7 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT)
|
||||
(NOESC.RME 0)))
|
||||
(NOESC.RME 0)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ ESC.RME ESCAPEBIT)
|
||||
@@ -1631,46 +1628,46 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT))
|
||||
(ESCQUOTE (BITTEST DATUM ESCAPEBIT))
|
||||
(STOPATOM (BITTEST DATUM STOPATOMBIT))
|
||||
(INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT)))
|
||||
(MACROCONTEXT (LOGAND DATUM CONTEXTMASK))
|
||||
(MACROP (BITTEST DATUM MACROBIT))
|
||||
(WAKEUP (LOGAND DATUM WAKEUPMASK))
|
||||
(BREAK (BITTEST DATUM BREAKBIT))))
|
||||
(ESCQUOTE (BITTEST DATUM ESCAPEBIT))
|
||||
(STOPATOM (BITTEST DATUM STOPATOMBIT))
|
||||
(INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT)))
|
||||
(MACROCONTEXT (LOGAND DATUM CONTEXTMASK))
|
||||
(MACROP (BITTEST DATUM MACROBIT))
|
||||
(WAKEUP (LOGAND DATUM WAKEUPMASK))
|
||||
(BREAK (BITTEST DATUM BREAKBIT))))
|
||||
|
||||
(RECORD READMACRODEF (MACROTYPE . MACROFN))
|
||||
|
||||
(DATATYPE READTABLEP ((READSA POINTER) (* ;
|
||||
"A CHARTABLE defining syntax of each char")
|
||||
(READMACRODEFS POINTER) (* ;
|
||||
"A hash table associating macro chars with macro definitions")
|
||||
(READMACROFLG FLAG) (* ;
|
||||
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
|
||||
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
|
||||
(COMMONLISP FLAG) (* ;
|
||||
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
|
||||
(NUMBERBASE BITS 5) (* ; "Not used")
|
||||
(CASEINSENSITIVE FLAG) (* ;
|
||||
"If true, unescaped lowercase chars are converted to uppercase in symbols")
|
||||
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
|
||||
(USESILPACKAGE FLAG) (* ;
|
||||
"If true, IL:READ ignores *PACKAGE* and reads in the IL package")
|
||||
(NIL 5 FLAG)
|
||||
(DISPATCHMACRODEFS POINTER) (* ;
|
||||
"An a-list of dispatching macro char and its dispatch definitions")
|
||||
(HASHMACROCHAR BYTE) (* ;
|
||||
"The character code used in this read table for the # dispatch macro")
|
||||
(ESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for single escape")
|
||||
(MULTESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for multiple escape")
|
||||
(PACKAGECHAR BYTE) (* ;
|
||||
"The character code used in this read table for package delimiter")
|
||||
(READTBLNAME POINTER) (* ;
|
||||
"The canonical 'name' of this read table")
|
||||
)
|
||||
READSA _ (create CHARTABLE))
|
||||
(DATATYPE READTABLEP ((READSA POINTER) (* ;
|
||||
"A CHARTABLE defining syntax of each char")
|
||||
(READMACRODEFS POINTER) (* ;
|
||||
"A hash table associating macro chars with macro definitions")
|
||||
(READMACROFLG FLAG) (* ;
|
||||
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
|
||||
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
|
||||
(COMMONLISP FLAG) (* ;
|
||||
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
|
||||
(NUMBERBASE BITS 5) (* ; "Not used")
|
||||
(CASEINSENSITIVE FLAG) (* ;
|
||||
"If true, unescaped lowercase chars are converted to uppercase in symbols")
|
||||
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
|
||||
(USESILPACKAGE FLAG) (* ;
|
||||
"If true, IL:READ ignores *PACKAGE* and reads in the IL package")
|
||||
(NIL 5 FLAG)
|
||||
(DISPATCHMACRODEFS POINTER) (* ;
|
||||
"An a-list of dispatching macro char and its dispatch definitions")
|
||||
(HASHMACROCHAR BYTE) (* ;
|
||||
"The character code used in this read table for the # dispatch macro")
|
||||
(ESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for single escape")
|
||||
(MULTESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for multiple escape")
|
||||
(PACKAGECHAR BYTE) (* ;
|
||||
"The character code used in this read table for package delimiter")
|
||||
(READTBLNAME POINTER) (* ;
|
||||
"The canonical 'name' of this read table")
|
||||
)
|
||||
READSA _ (create CHARTABLE))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'READTABLEP
|
||||
@@ -1870,8 +1867,12 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
REREADTABLEFORM _ READTABLEFORM])
|
||||
|
||||
(EQUAL-READER-ENVIRONMENT
|
||||
[LAMBDA (ENV1 ENV2) (* ; "Edited 16-Aug-2021 23:43 by rmk:")
|
||||
(* ; ":XCCS is the prehistoric value")
|
||||
[LAMBDA (ENV1 ENV2)
|
||||
|
||||
(* ;; "Edited 19-Dec-2021 14:09 by rmk: Replace constant :XCCS with *DEFAULT-EXTERNALFORMAT*")
|
||||
|
||||
(* ;; "Edited 19-Dec-2021 14:01 by rmk")
|
||||
|
||||
(AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1)
|
||||
(fetch (READER-ENVIRONMENT REREADTABLE) of ENV2))
|
||||
(EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1)
|
||||
@@ -1879,9 +1880,9 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1)
|
||||
(fetch (READER-ENVIRONMENT REBASE) of ENV2))
|
||||
(EQ (OR (fetch (READER-ENVIRONMENT REFORMAT) of ENV1)
|
||||
:XCCS)
|
||||
*DEFAULT-EXTERNALFORMAT*)
|
||||
(OR (fetch (READER-ENVIRONMENT REFORMAT) of ENV2)
|
||||
:XCCS))
|
||||
*DEFAULT-EXTERNALFORMAT*))
|
||||
(EQUAL (fetch (READER-ENVIRONMENT REPACKAGEFORM) of ENV1)
|
||||
(fetch (READER-ENVIRONMENT REPACKAGEFORM) of ENV2))
|
||||
(EQUAL (fetch (READER-ENVIRONMENT REREADTABLEFORM) of ENV1)
|
||||
@@ -1924,22 +1925,22 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018
|
||||
2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (18046 29198 (GETSYNTAX 18056 . 22887) (SETSYNTAX 22889 . 23962) (SYNTAXP 23964 . 26461)
|
||||
(\COPYSYNTAX 26463 . 27180) (\GETCHARCODE 27182 . 27470) (\SETFATSYNCODE 27472 . 28763) (
|
||||
\MAPCHARTABLE 28765 . 29196)) (29231 44197 (CONTROL 29241 . 29493) (COPYTERMTABLE 29495 . 29862) (
|
||||
DELETECONTROL 29864 . 32505) (GETDELETECONTROL 32507 . 33469) (ECHOCHAR 33471 . 34912) (ECHOCONTROL
|
||||
34914 . 35371) (ECHOMODE 35373 . 35619) (GETECHOMODE 35621 . 35785) (GETCONTROL 35787 . 35953) (
|
||||
GETTERMTABLE 35955 . 36022) (RAISE 36024 . 36450) (GETRAISE 36452 . 36614) (RESETTERMTABLE 36616 .
|
||||
37700) (SETTERMTABLE 37702 . 37936) (TERMTABLEP 37938 . 38099) (\GETTERMSYNTAX 38101 . 38372) (
|
||||
\GTTERMTABLE 38374 . 38710) (\ORIGTERMTABLE 38712 . 42322) (\SETTERMSYNTAX 42324 . 42959) (
|
||||
\TERMCLASSTOCODE 42961 . 43390) (\TERMCODETOCLASS 43392 . 43779) (\LITCHECK 43781 . 44195)) (46727
|
||||
70551 (COPYREADTABLE 46737 . 46935) (FIND-READTABLE 46937 . 47084) (IN-READTABLE 47086 . 47246) (
|
||||
ESCAPE 47248 . 47501) (GETBRK 47503 . 47641) (GETREADTABLE 47643 . 47779) (GETSEPR 47781 . 47919) (
|
||||
READMACROS 47921 . 48184) (READTABLEP 48186 . 48349) (READTABLEPROP 48351 . 53509) (RESETREADTABLE
|
||||
53511 . 57758) (SETBRK 57760 . 59370) (SETREADTABLE 59372 . 59560) (SETSEPR 59562 . 61104) (
|
||||
\GETREADSYNTAX 61106 . 63796) (\GTREADTABLE 63798 . 64023) (\GTREADTABLE1 64025 . 64281) (
|
||||
\ORIGREADTABLE 64283 . 66191) (\READCLASSTOCODE 66193 . 66644) (\SETMACROSYNTAX 66646 . 68441) (
|
||||
\SETREADSYNTAX 68443 . 69504) (\READTABLEP.DEFPRINT 69506 . 70549)) (83643 88096 (\ATBLSET 83653 .
|
||||
88094)) (88543 91975 (MAKE-READER-ENVIRONMENT 88553 . 90231) (EQUAL-READER-ENVIRONMENT 90233 . 91377)
|
||||
(SET-READER-ENVIRONMENT 91379 . 91973)))))
|
||||
(FILEMAP (NIL (17750 28902 (GETSYNTAX 17760 . 22591) (SETSYNTAX 22593 . 23666) (SYNTAXP 23668 . 26165)
|
||||
(\COPYSYNTAX 26167 . 26884) (\GETCHARCODE 26886 . 27174) (\SETFATSYNCODE 27176 . 28467) (
|
||||
\MAPCHARTABLE 28469 . 28900)) (28935 43901 (CONTROL 28945 . 29197) (COPYTERMTABLE 29199 . 29566) (
|
||||
DELETECONTROL 29568 . 32209) (GETDELETECONTROL 32211 . 33173) (ECHOCHAR 33175 . 34616) (ECHOCONTROL
|
||||
34618 . 35075) (ECHOMODE 35077 . 35323) (GETECHOMODE 35325 . 35489) (GETCONTROL 35491 . 35657) (
|
||||
GETTERMTABLE 35659 . 35726) (RAISE 35728 . 36154) (GETRAISE 36156 . 36318) (RESETTERMTABLE 36320 .
|
||||
37404) (SETTERMTABLE 37406 . 37640) (TERMTABLEP 37642 . 37803) (\GETTERMSYNTAX 37805 . 38076) (
|
||||
\GTTERMTABLE 38078 . 38414) (\ORIGTERMTABLE 38416 . 42026) (\SETTERMSYNTAX 42028 . 42663) (
|
||||
\TERMCLASSTOCODE 42665 . 43094) (\TERMCODETOCLASS 43096 . 43483) (\LITCHECK 43485 . 43899)) (46412
|
||||
70236 (COPYREADTABLE 46422 . 46620) (FIND-READTABLE 46622 . 46769) (IN-READTABLE 46771 . 46931) (
|
||||
ESCAPE 46933 . 47186) (GETBRK 47188 . 47326) (GETREADTABLE 47328 . 47464) (GETSEPR 47466 . 47604) (
|
||||
READMACROS 47606 . 47869) (READTABLEP 47871 . 48034) (READTABLEPROP 48036 . 53194) (RESETREADTABLE
|
||||
53196 . 57443) (SETBRK 57445 . 59055) (SETREADTABLE 59057 . 59245) (SETSEPR 59247 . 60789) (
|
||||
\GETREADSYNTAX 60791 . 63481) (\GTREADTABLE 63483 . 63708) (\GTREADTABLE1 63710 . 63966) (
|
||||
\ORIGREADTABLE 63968 . 65876) (\READCLASSTOCODE 65878 . 66329) (\SETMACROSYNTAX 66331 . 68126) (
|
||||
\SETREADSYNTAX 68128 . 69189) (\READTABLEP.DEFPRINT 69191 . 70234)) (83068 87521 (\ATBLSET 83078 .
|
||||
87519)) (87968 91406 (MAKE-READER-ENVIRONMENT 87978 . 89656) (EQUAL-READER-ENVIRONMENT 89658 . 90808)
|
||||
(SET-READER-ENVIRONMENT 90810 . 91404)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,104 +1,94 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED " 3-Apr-91 15:11:53" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CLSTREAMS.;4| 54013
|
||||
|
||||
|changes| |to:| (FUNCTIONS CL:WITH-INPUT-FROM-STRING)
|
||||
(FILECREATED "27-Nov-2021 13:30:46"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;3| 53235
|
||||
|
||||
|previous| |date:| "27-Feb-91 20:05:55" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CLSTREAMS.;3|)
|
||||
|previous| |date:| " 3-Apr-91 15:11:53"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CLSTREAMS.;2|)
|
||||
|
||||
|
||||
; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1985-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT CLSTREAMSCOMS)
|
||||
|
||||
(RPAQQ CLSTREAMSCOMS (
|
||||
(RPAQQ CLSTREAMSCOMS
|
||||
(
|
||||
|
||||
(* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21")
|
||||
|
||||
(COMS
|
||||
(* |;;| "documented functions and macros")
|
||||
(COMS
|
||||
(* |;;| "documented functions and macros")
|
||||
|
||||
(FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT)
|
||||
(FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P
|
||||
CL:OUTPUT-STREAM-P XCL:OPEN-STREAM-P)
|
||||
(COMS (FUNCTIONS FILE-STREAM-POSITION)
|
||||
(SETFS FILE-STREAM-POSITION))
|
||||
(FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P
|
||||
XCL:SYNONYM-STREAM-SYMBOL XCL:FOLLOW-SYNONYM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P
|
||||
XCL:BROADCAST-STREAM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P
|
||||
XCL:CONCATENATED-STREAM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P
|
||||
XCL:TWO-WAY-STREAM-OUTPUT-STREAM
|
||||
XCL:TWO-WAY-STREAM-INPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P
|
||||
XCL:ECHO-STREAM-INPUT-STREAM XCL:ECHO-STREAM-OUTPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-STRING-INPUT-STREAM
|
||||
MAKE-CONCATENATED-STRING-INPUT-STREAM)
|
||||
(FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
|
||||
(FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING
|
||||
CL:WITH-OUTPUT-TO-STRING CL:WITH-OPEN-FILE)
|
||||
(FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM
|
||||
MAKE-FILL-POINTER-OUTPUT-STREAM CL:GET-OUTPUT-STREAM-STRING
|
||||
\\STRING-STREAM-OUTCHARFN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN
|
||||
))
|
||||
(COMS
|
||||
(* |;;| "helpers")
|
||||
(FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT)
|
||||
(FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P CL:OUTPUT-STREAM-P
|
||||
XCL:OPEN-STREAM-P)
|
||||
(COMS (FUNCTIONS FILE-STREAM-POSITION)
|
||||
(SETFS FILE-STREAM-POSITION))
|
||||
(FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P XCL:SYNONYM-STREAM-SYMBOL
|
||||
XCL:FOLLOW-SYNONYM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P XCL:BROADCAST-STREAM-STREAMS
|
||||
)
|
||||
(FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P
|
||||
XCL:CONCATENATED-STREAM-STREAMS)
|
||||
(FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P XCL:TWO-WAY-STREAM-OUTPUT-STREAM
|
||||
XCL:TWO-WAY-STREAM-INPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P XCL:ECHO-STREAM-INPUT-STREAM
|
||||
XCL:ECHO-STREAM-OUTPUT-STREAM)
|
||||
(FUNCTIONS CL:MAKE-STRING-INPUT-STREAM MAKE-CONCATENATED-STRING-INPUT-STREAM)
|
||||
(FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
|
||||
(FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING CL:WITH-OUTPUT-TO-STRING
|
||||
CL:WITH-OPEN-FILE)
|
||||
(FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM MAKE-FILL-POINTER-OUTPUT-STREAM
|
||||
CL:GET-OUTPUT-STREAM-STRING \\STRING-STREAM-OUTCHARFN
|
||||
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN))
|
||||
(COMS
|
||||
(* |;;| "helpers")
|
||||
|
||||
(FUNCTIONS %NEW-FILE PREDICT-NAME)
|
||||
(DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
|
||||
(COMS
|
||||
(* |;;| "methods for the special devices")
|
||||
(FUNCTIONS %NEW-FILE PREDICT-NAME)
|
||||
(DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
|
||||
(COMS
|
||||
(* |;;| "methods for the special devices")
|
||||
|
||||
(FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN
|
||||
%BROADCAST-STREAM-DEVICE-CLOSEFILE
|
||||
%BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
|
||||
(FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %CONCATENATED-STREAM-DEVICE-BIN
|
||||
%CONCATENATED-STREAM-DEVICE-CLOSEFILE
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP
|
||||
%CONCATENATED-STREAM-DEVICE-PEEKBIN
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
|
||||
(FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %ECHO-STREAM-DEVICE-BIN)
|
||||
(FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
|
||||
(FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN
|
||||
%SYNONYM-STREAM-DEVICE-CLOSEFILE %SYNONYM-STREAM-DEVICE-EOFP
|
||||
%SYNONYM-STREAM-DEVICE-FORCEOUTPUT
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO
|
||||
%SYNONYM-STREAM-DEVICE-PEEKBIN %SYNONYM-STREAM-DEVICE-READP
|
||||
%SYNONYM-STREAM-DEVICE-BACKFILEPTR
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO
|
||||
%SYNONYM-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-OUTCHARFN
|
||||
%TWO-WAY-STREAM-DEVICE-CLOSEFILE %TWO-WAY-STREAM-DEVICE-EOFP
|
||||
%TWO-WAY-STREAM-DEVICE-READP %TWO-WAY-STREAM-DEVICE-BACKFILEPTR
|
||||
%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN)
|
||||
(FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE
|
||||
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR)
|
||||
(GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE
|
||||
%CONCATENATED-STREAM-DEVICE %TWO-WAY-STREAM-DEVICE
|
||||
%ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE))
|
||||
(COMS
|
||||
(* |;;| "helper stuff")
|
||||
(FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN
|
||||
%BROADCAST-STREAM-DEVICE-CLOSEFILE %BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
|
||||
(FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %CONCATENATED-STREAM-DEVICE-BIN %CONCATENATED-STREAM-DEVICE-CLOSEFILE
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP %CONCATENATED-STREAM-DEVICE-PEEKBIN
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
|
||||
(FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %ECHO-STREAM-DEVICE-BIN)
|
||||
(FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
|
||||
(FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN %SYNONYM-STREAM-DEVICE-CLOSEFILE
|
||||
%SYNONYM-STREAM-DEVICE-EOFP %SYNONYM-STREAM-DEVICE-FORCEOUTPUT
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO %SYNONYM-STREAM-DEVICE-PEEKBIN
|
||||
%SYNONYM-STREAM-DEVICE-READP %SYNONYM-STREAM-DEVICE-BACKFILEPTR
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO %SYNONYM-STREAM-DEVICE-CHARSETFN)
|
||||
(FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
|
||||
%TWO-WAY-STREAM-DEVICE-OUTCHARFN %TWO-WAY-STREAM-DEVICE-CLOSEFILE
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP %TWO-WAY-STREAM-DEVICE-READP
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN)
|
||||
(FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE %FILL-POINTER-STREAM-DEVICE-GETFILEPTR
|
||||
)
|
||||
(GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE
|
||||
%TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE))
|
||||
(COMS
|
||||
(* |;;| "helper stuff")
|
||||
|
||||
(FNS %SYNONYM-STREAM-DEVICE-GET-STREAM))
|
||||
(COMS
|
||||
(* |;;| "module initialization")
|
||||
(FNS %SYNONYM-STREAM-DEVICE-GET-STREAM))
|
||||
(COMS
|
||||
(* |;;| "module initialization")
|
||||
|
||||
(VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT*
|
||||
*STANDARD-OUTPUT* *STANDARD-INPUT*)
|
||||
(FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
|
||||
(FNS %INITIALIZE-CLSTREAM-TYPES)
|
||||
(DECLARE\: DONTEVAL@LOAD DOCOPY
|
||||
(* \; "initialization")
|
||||
(P (%INITIALIZE-CLSTREAM-TYPES)
|
||||
(%INITIALIZE-STANDARD-STREAMS))))
|
||||
(PROP FILETYPE CLSTREAMS)))
|
||||
(VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT* *STANDARD-OUTPUT*
|
||||
*STANDARD-INPUT*)
|
||||
(FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
|
||||
(FNS %INITIALIZE-CLSTREAM-TYPES)
|
||||
(DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization")
|
||||
(P (%INITIALIZE-CLSTREAM-TYPES)
|
||||
(%INITIALIZE-STANDARD-STREAMS))))
|
||||
(PROP FILETYPE CLSTREAMS)))
|
||||
|
||||
|
||||
|
||||
@@ -111,10 +101,10 @@
|
||||
|
||||
|
||||
(CL:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT)
|
||||
(ELEMENT-TYPE 'CL:STRING-CHAR)
|
||||
(IF-EXISTS NIL EXISTS-P)
|
||||
(IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
|
||||
(EXTERNAL-FORMAT :DEFAULT))
|
||||
(ELEMENT-TYPE 'CL:STRING-CHAR)
|
||||
(IF-EXISTS NIL EXISTS-P)
|
||||
(IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
|
||||
(EXTERNAL-FORMAT :DEFAULT))
|
||||
|
||||
(* |;;;| "Return a stream which reads from or writes to Filename. Defined keywords: :direction (one of :input, :output or :probe :element-type), Type of object to read or write, default String-Char, :if-exists (one of :error, :new-version, :overwrite, :append or nil), :if-does-not-exist (one of :error, :create or nil). :external-format (one of :DEFAULT, :EUC, :JIS, :W-MS, :MS or :XCCS). The specification of :external-format is based on the JEIDA proposal. See the manual for details.")
|
||||
|
||||
@@ -134,10 +124,10 @@
|
||||
(FOR-OUTPUT (MEMQ DIRECTION '(:IO :OUTPUT)))
|
||||
(ACCESS (INTERLISP-ACCESS DIRECTION))
|
||||
(FILE-TYPE (IF (CL:MEMBER ELEMENT-TYPE '(CL:UNSIGNED-BYTE CL:SIGNED-BYTE (CL:UNSIGNED-BYTE
|
||||
8)
|
||||
(CL:SIGNED-BYTE 8))
|
||||
:TEST
|
||||
'CL:EQUAL)
|
||||
8)
|
||||
(CL:SIGNED-BYTE 8))
|
||||
:TEST
|
||||
'CL:EQUAL)
|
||||
THEN 'BINARY
|
||||
ELSE 'TEXT))
|
||||
(STREAM NIL))
|
||||
@@ -149,7 +139,7 @@
|
||||
:NEWEST)
|
||||
:NEW-VERSION
|
||||
:ERROR))) (* \;
|
||||
"If the file does not exist, it is OK to have :if-exists :overwrite. ")
|
||||
"If the file does not exist, it is OK to have :if-exists :overwrite. ")
|
||||
(CL:UNLESS DOES-NOT-EXIST-P
|
||||
(SETQ IF-DOES-NOT-EXIST (COND
|
||||
((OR (EQ IF-EXISTS :APPEND)
|
||||
@@ -159,101 +149,98 @@
|
||||
NIL)
|
||||
(T :CREATE))))
|
||||
(CL:LOOP (* \;
|
||||
"See if the file exists and handle the existential keywords.")
|
||||
"See if the file exists and handle the existential keywords.")
|
||||
(LET* ((NAME (PREDICT-NAME PATHNAME))
|
||||
(CL:NAMESTRING (MKSTRING NAME)))
|
||||
(IF NAME
|
||||
THEN (* \; "file exists")
|
||||
(IF FOR-OUTPUT
|
||||
THEN
|
||||
THEN (* \; "file exists")
|
||||
(IF FOR-OUTPUT
|
||||
THEN
|
||||
(* |;;| "open for output/both")
|
||||
|
||||
(* |;;| "open for output/both")
|
||||
(CASE IF-EXISTS
|
||||
(:ERROR
|
||||
(CL:CERROR "write it anyway." "File ~A already exists."
|
||||
CL:NAMESTRING)
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS NIL
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE)
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:OVERWRITE
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:APPEND
|
||||
(IF (EQ DIRECTION :OUTPUT)
|
||||
THEN (* \;
|
||||
"if the direction is output it is the same as interlisp append")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'APPEND
|
||||
'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))
|
||||
))
|
||||
ELSE (* \;
|
||||
"if direction is io it opens the file for both and goes to the end of the file")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'BOTH 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(SETFILEPTR STREAM -1))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-exists." IF-EXISTS)))
|
||||
|elseif| FOR-INPUT
|
||||
|then|
|
||||
|
||||
(CASE IF-EXISTS
|
||||
(:ERROR
|
||||
(CL:CERROR "write it anyway." "File ~A already exists."
|
||||
CL:NAMESTRING)
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS NIL
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE)
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:OVERWRITE
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
(:APPEND
|
||||
(IF (EQ DIRECTION :OUTPUT)
|
||||
THEN (* \;
|
||||
"if the direction is output it is the same as interlisp append")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'APPEND
|
||||
'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT
|
||||
,EXTERNAL-FORMAT))))
|
||||
ELSE (* \;
|
||||
"if direction is io it opens the file for both and goes to the end of the file")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING 'BOTH
|
||||
'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT)
|
||||
)))
|
||||
(SETFILEPTR STREAM -1))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-exists." IF-EXISTS)))
|
||||
|elseif| FOR-INPUT
|
||||
|then|
|
||||
(* |;;| "open for input/both")
|
||||
|
||||
(* |;;| "open for input/both")
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL)
|
||||
|else|
|
||||
|
||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL)
|
||||
|else|
|
||||
(* |;;| "open for probe")
|
||||
|
||||
(* |;;| "open for probe")
|
||||
|
||||
(SETQ STREAM (|create| STREAM
|
||||
FULLFILENAME _ (FULLNAME CL:NAMESTRING)))
|
||||
(RETURN NIL))
|
||||
(SETQ STREAM (|create| STREAM
|
||||
FULLFILENAME _ (FULLNAME CL:NAMESTRING)))
|
||||
(RETURN NIL))
|
||||
|else|
|
||||
|
||||
(* |;;| "file does not exist")
|
||||
|
||||
(|if| FOR-OUTPUT
|
||||
|then| (CASE IF-DOES-NOT-EXIST
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE
|
||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||
`((TYPE ,FILE-TYPE)
|
||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||
(RETURN NIL))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
|elseif| FOR-INPUT
|
||||
|then| (CASE IF-DOES-NOT-EXIST
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE (%NEW-FILE PATHNAME))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
|else| (* \; "Open for probe.")
|
||||
(:ERROR
|
||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||
:PATHNAME PATHNAME)
|
||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||
(:CREATE (%NEW-FILE PATHNAME))
|
||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||
IF-DOES-NOT-EXIST)))
|
||||
|else| (* \; "Open for probe.")
|
||||
(RETURN NIL)))))
|
||||
(STREAMPROP STREAM :FILE-STREAM-P T)
|
||||
STREAM))
|
||||
@@ -264,18 +251,18 @@
|
||||
|
||||
(|if| (STREAMP STREAM)
|
||||
|then| (|if| (OPENP STREAM)
|
||||
|then|
|
||||
|then|
|
||||
|
||||
(* |;;|
|
||||
"determine 'deletability' of stream's file before closing, as that trashes the info")
|
||||
(* |;;|
|
||||
"determine 'deletability' of stream's file before closing, as that trashes the info")
|
||||
|
||||
(LET ((ABORTABLE (AND (DIRTYABLE STREAM)
|
||||
(NOT (APPENDONLY STREAM)))))
|
||||
(CLOSEF STREAM)
|
||||
(|if| (AND ABORT ABORTABLE)
|
||||
|then| (* \;
|
||||
"eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.")
|
||||
(DELFILE (CL:NAMESTRING STREAM)))))
|
||||
(LET ((ABORTABLE (AND (DIRTYABLE STREAM)
|
||||
(NOT (APPENDONLY STREAM)))))
|
||||
(CLOSEF STREAM)
|
||||
(|if| (AND ABORT ABORTABLE)
|
||||
|then| (* \;
|
||||
"eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.")
|
||||
(DELFILE (CL:NAMESTRING STREAM)))))
|
||||
|else| (ERROR "Closing a non-stream" STREAM))
|
||||
T)
|
||||
|
||||
@@ -323,15 +310,19 @@
|
||||
DEVICE _ %SYNONYM-STREAM-DEVICE
|
||||
ACCESS _ 'BOTH
|
||||
F1 _ CL:SYMBOL
|
||||
LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE
|
||||
CL:SYMBOL))
|
||||
LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE CL:SYMBOL))
|
||||
OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN))))
|
||||
(STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T)
|
||||
|
||||
(* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE")
|
||||
|
||||
(|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE
|
||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE)))
|
||||
(|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (CONS STREAM
|
||||
(|fetch| (FDEV
|
||||
OPENFILELST
|
||||
)
|
||||
|of|
|
||||
%SYNONYM-STREAM-DEVICE
|
||||
)))
|
||||
STREAM))
|
||||
|
||||
(CL:DEFUN XCL:SYNONYM-STREAM-P (STREAM)
|
||||
@@ -355,14 +346,14 @@
|
||||
|
||||
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
||||
THEN (LET ((STREAM (|create| STREAM
|
||||
DEVICE _ %BROADCAST-STREAM-DEVICE
|
||||
ACCESS _ 'OUTPUT
|
||||
F1 _ STREAMS
|
||||
OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
|
||||
(STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
|
||||
STREAM)
|
||||
DEVICE _ %BROADCAST-STREAM-DEVICE
|
||||
ACCESS _ 'OUTPUT
|
||||
F1 _ STREAMS
|
||||
OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
|
||||
(STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
|
||||
STREAM)
|
||||
ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?))
|
||||
DO (RETURN STREAM?)))))
|
||||
DO (RETURN STREAM?)))))
|
||||
|
||||
(CL:DEFUN XCL:BROADCAST-STREAM-P (STREAM)
|
||||
|
||||
@@ -383,13 +374,13 @@
|
||||
|
||||
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
||||
THEN (LET ((STREAM (|create| STREAM
|
||||
DEVICE _ %CONCATENATED-STREAM-DEVICE
|
||||
ACCESS _ 'INPUT
|
||||
F1 _ STREAMS)))
|
||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
|
||||
STREAM)
|
||||
DEVICE _ %CONCATENATED-STREAM-DEVICE
|
||||
ACCESS _ 'INPUT
|
||||
F1 _ STREAMS)))
|
||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
|
||||
STREAM)
|
||||
ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?))
|
||||
DO (RETURN STREAM?)))))
|
||||
DO (RETURN STREAM?)))))
|
||||
|
||||
(CL:DEFUN XCL:CONCATENATED-STREAM-P (STREAM)
|
||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P))
|
||||
@@ -420,8 +411,13 @@
|
||||
|
||||
(* |;;| "save STREAM in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE")
|
||||
|
||||
(|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE
|
||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE)))
|
||||
(|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE |with| (CONS STREAM
|
||||
(|fetch| (FDEV
|
||||
OPENFILELST
|
||||
)
|
||||
|of|
|
||||
%TWO-WAY-STREAM-DEVICE
|
||||
)))
|
||||
STREAM))
|
||||
|
||||
(CL:DEFUN XCL:TWO-WAY-STREAM-P (STREAM)
|
||||
@@ -457,8 +453,13 @@
|
||||
|
||||
(* |;;| "save STREAM in the OPENFILELST field of %ECHO-STREAM-DEVICE")
|
||||
|
||||
(|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE
|
||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE)))
|
||||
(|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE |with| (CONS STREAM
|
||||
(|fetch| (FDEV
|
||||
OPENFILELST
|
||||
)
|
||||
|of|
|
||||
%ECHO-STREAM-DEVICE
|
||||
)))
|
||||
STREAM))
|
||||
|
||||
(CL:DEFUN XCL:ECHO-STREAM-P (STREAM)
|
||||
@@ -476,12 +477,12 @@
|
||||
(FETCH (STREAM F2) OF STREAM)))
|
||||
|
||||
(CL:DEFUN CL:MAKE-STRING-INPUT-STREAM (STRING &OPTIONAL (CL::START 0)
|
||||
(CL::END NIL))
|
||||
(CL::END NIL))
|
||||
|
||||
(* |;;;| "A CommonLisp function for producing a stream from a string. See CLtL p. 330")
|
||||
|
||||
(OPENSTRINGSTREAM (|if| (OR (NOT (CL:ZEROP CL::START))
|
||||
(NOT (NULL CL::END)))
|
||||
(NOT (NULL CL::END)))
|
||||
|then|
|
||||
|
||||
(* |;;| "A displaced array is ok here because the stream's uses GETBASEBYTE directly and doesn't go through the array code at all. ")
|
||||
@@ -497,9 +498,9 @@
|
||||
NIL)
|
||||
((NULL (CL:REST STRINGS))
|
||||
(CL:MAKE-STRING-INPUT-STREAM (CL:FIRST STRINGS)))
|
||||
(T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS
|
||||
COLLECT (CL:MAKE-STRING-INPUT-STREAM
|
||||
STRING))))))
|
||||
(T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS COLLECT (
|
||||
CL:MAKE-STRING-INPUT-STREAM
|
||||
STRING))))))
|
||||
|
||||
(CL:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS ()
|
||||
(CL:MAKE-ARRAY '(256)
|
||||
@@ -507,8 +508,8 @@
|
||||
'CL:STRING-CHAR :EXTENDABLE T :FILL-POINTER 0))
|
||||
|
||||
(DEFMACRO CL:WITH-OPEN-STREAM ((VAR STREAM)
|
||||
&BODY
|
||||
(BODY DECLS))
|
||||
&BODY
|
||||
(BODY DECLS))
|
||||
(LET ((ABORTP (GENSYM)))
|
||||
`(LET ((,VAR ,STREAM)
|
||||
(,ABORTP T))
|
||||
@@ -519,15 +520,15 @@
|
||||
(CL:CLOSE ,VAR :ABORT ,ABORTP)))))
|
||||
|
||||
(DEFMACRO CL:WITH-INPUT-FROM-STRING ((CL::VAR STRING &KEY (CL::INDEX NIL CL::INDEXP)
|
||||
(CL::START 0 CL::STARTP)
|
||||
(CL::END NIL CL:ENDP))
|
||||
&BODY
|
||||
(CL::BODY CL::DECLS))
|
||||
(CL::START 0 CL::STARTP)
|
||||
(CL::END NIL CL:ENDP))
|
||||
&BODY
|
||||
(CL::BODY CL::DECLS))
|
||||
`(LET* ((CL::$STRING$ ,STRING)
|
||||
(CL::$START$ ,CL::START))
|
||||
(DECLARE (LOCALVARS CL::$STRING$ CL::$START$))
|
||||
(CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$
|
||||
CL::$START$ ,CL::END))
|
||||
(CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$ CL::$START$
|
||||
,CL::END))
|
||||
,@CL::DECLS
|
||||
,@(CL:IF CL::INDEXP
|
||||
|
||||
@@ -541,8 +542,8 @@
|
||||
CL::BODY))))
|
||||
|
||||
(DEFMACRO CL:WITH-OUTPUT-TO-STRING ((VAR &OPTIONAL (STRING NIL ST-P))
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
(COND
|
||||
(ST-P `(CL:WITH-OPEN-STREAM (,VAR (MAKE-FILL-POINTER-OUTPUT-STREAM ,STRING))
|
||||
,@DECLS
|
||||
@@ -552,8 +553,8 @@
|
||||
(PROGN ,@FORMS (CL:GET-OUTPUT-STREAM-STRING ,VAR))))))
|
||||
|
||||
(DEFMACRO CL:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS)
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
&BODY
|
||||
(FORMS DECLS))
|
||||
|
||||
(* |;;;| "The file whose name is File-Name is opened using the OPEN-ARGS and bound to the variable VAR. The Forms are executed, and when they terminate, normally or otherwise, the file is closed.")
|
||||
|
||||
@@ -572,26 +573,26 @@
|
||||
|
||||
(MAKE-FILL-POINTER-OUTPUT-STREAM))
|
||||
|
||||
(CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||
)))
|
||||
(CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (%MAKE-INITIAL-STRING-STREAM-CONTENTS)))
|
||||
(DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE))
|
||||
(|if| (NOT (CL:ARRAY-HAS-FILL-POINTER-P STRING))
|
||||
|then| (\\ILLEGAL.ARG STRING)
|
||||
|else| (LET ((STREAM (|create| STREAM
|
||||
DEVICE _ \\FILL-POINTER-STREAM-DEVICE
|
||||
F1 _ STRING
|
||||
ACCESS _ 'OUTPUT
|
||||
OTHERPROPS _ '(STRING-OUTPUT-STREAM T))))
|
||||
DEVICE _ \\FILL-POINTER-STREAM-DEVICE
|
||||
F1 _ STRING
|
||||
ACCESS _ 'OUTPUT
|
||||
OTHERPROPS _ '(STRING-OUTPUT-STREAM T))))
|
||||
(* \;
|
||||
"give it a canned property list to save some consing.")
|
||||
(|replace| (STREAM OUTCHARFN) |of| STREAM
|
||||
|with| (|if| (EXTENDABLE-ARRAY-P STRING)
|
||||
|then| (FUNCTION \\ADJUSTABLE-STRING-STREAM-OUTCHARFN)
|
||||
|else| (FUNCTION \\STRING-STREAM-OUTCHARFN)))
|
||||
(|replace| (STREAM STRMBOUTFN) |of| STREAM |with|
|
||||
(FUNCTION \\OUTCHAR))
|
||||
STREAM)))
|
||||
"give it a canned property list to save some consing.")
|
||||
(|replace| (STREAM OUTCHARFN) |of| STREAM |with| (|if| (EXTENDABLE-ARRAY-P STRING)
|
||||
|then| (FUNCTION
|
||||
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN
|
||||
)
|
||||
|else| (FUNCTION
|
||||
\\STRING-STREAM-OUTCHARFN
|
||||
)))
|
||||
(|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\OUTCHAR))
|
||||
STREAM)))
|
||||
|
||||
(CL:DEFUN CL:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM)
|
||||
|
||||
@@ -600,17 +601,17 @@
|
||||
(|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM))
|
||||
|then| (ERROR "Stream not a string-output-stream" STRING-OUTPUT-STREAM)
|
||||
|else| (PROG1 (|fetch| (STREAM F1) |of| STRING-OUTPUT-STREAM)
|
||||
(|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||
)))))
|
||||
(|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||
)))))
|
||||
|
||||
(CL:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR)
|
||||
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
1))
|
||||
1))
|
||||
(CL:VECTOR-PUSH (CL:CHARACTER CHAR)
|
||||
(FETCH (STREAM F1) OF STREAM)))
|
||||
|
||||
@@ -618,11 +619,11 @@
|
||||
(LET ((STRING (FETCH (STREAM F1) OF STREAM))
|
||||
(CH (CL:CHARACTER CHAR)))
|
||||
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||
(EQ CHAR (CHARCODE EOL)))
|
||||
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
1))
|
||||
1))
|
||||
|
||||
(* |;;| "Do the equivalent of VECTOR-PUSH-EXTEND inline to save the significant! overhead of calculating the new length at each character.")
|
||||
|
||||
@@ -630,17 +631,16 @@
|
||||
(LET ((CURRENT-LENGTH (CL:ARRAY-TOTAL-SIZE STRING)))
|
||||
(IF (>= CURRENT-LENGTH (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT))
|
||||
THEN (PROCEED-CASE (CL:ERROR 'END-OF-FILE :STREAM STREAM)
|
||||
(SI::RETRY-OUTCHAR NIL :REPORT
|
||||
"VECTOR-PUSH the character anyway" :CONDITION END-OF-FILE
|
||||
(CL:VECTOR-PUSH CH (FETCH (STREAM F1) OF STREAM))
|
||||
))
|
||||
(SI::RETRY-OUTCHAR NIL :REPORT "VECTOR-PUSH the character anyway"
|
||||
:CONDITION END-OF-FILE (CL:VECTOR-PUSH CH (FETCH (STREAM
|
||||
F1)
|
||||
OF STREAM))))
|
||||
ELSE (CL:ADJUST-ARRAY STRING (MIN (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT)
|
||||
(+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH
|
||||
1)
|
||||
|
||||
(+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH 1)
|
||||
|
||||
*DEFAULT-PUSH-EXTENSION-SIZE*
|
||||
))))
|
||||
(CL:VECTOR-PUSH CH STRING))))))
|
||||
))))
|
||||
(CL:VECTOR-PUSH CH STRING))))))
|
||||
|
||||
|
||||
|
||||
@@ -691,8 +691,7 @@
|
||||
|
||||
(* |;;| "charset function for broadcast streams. Not clear what the value should be, so we arbitrarily return the value of the last stream.")
|
||||
|
||||
(FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S
|
||||
NEWVALUE))))
|
||||
(FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S NEWVALUE))))
|
||||
(DEFINEQ
|
||||
|
||||
(%concatenated-stream-device-bin
|
||||
@@ -723,7 +722,7 @@
|
||||
(LET ((STREAMS (FETCH (STREAM F1) OF STREAM)))
|
||||
(IF STREAMS
|
||||
THEN (ACCESS-CHARSET (CAR STREAMS)
|
||||
NEWVALUE)
|
||||
NEWVALUE)
|
||||
ELSE 0)))
|
||||
(DEFINEQ
|
||||
|
||||
@@ -933,7 +932,7 @@
|
||||
(CL:DEFUN %INITIALIZE-STANDARD-STREAMS ()
|
||||
|
||||
(* |;;|
|
||||
"Called when CLSTREAMS is loaded. Almost everything is same as *TERMINAL-IO* to start with.")
|
||||
"Called when CLSTREAMS is loaded. Almost everything is same as *TERMINAL-IO* to start with.")
|
||||
|
||||
(CL:SETQ *QUERY-IO* (CL:MAKE-TWO-WAY-STREAM (CL:MAKE-SYNONYM-STREAM '\\LINEBUF.OFD)
|
||||
(CL:MAKE-SYNONYM-STREAM '\\TERM.OFD)))
|
||||
@@ -953,27 +952,51 @@
|
||||
(%INITIALIZE-STANDARD-STREAMS)
|
||||
)
|
||||
|
||||
(PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (34128 35316 (%BROADCAST-STREAM-DEVICE-BOUT 34138 . 34361) (
|
||||
%BROADCAST-STREAM-DEVICE-OUTCHARFN 34363 . 34814) (%BROADCAST-STREAM-DEVICE-CLOSEFILE 34816 . 35055) (
|
||||
%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 35057 . 35314)) (35732 37791 (%CONCATENATED-STREAM-DEVICE-BIN
|
||||
35742 . 36147) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 36149 . 36462) (%CONCATENATED-STREAM-DEVICE-EOFP
|
||||
36464 . 36828) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36830 . 37305) (
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 37307 . 37789)) (38129 38348 (%ECHO-STREAM-DEVICE-BIN 38139 .
|
||||
38346)) (38576 41921 (%SYNONYM-STREAM-DEVICE-BIN 38586 . 38774) (%SYNONYM-STREAM-DEVICE-BOUT 38776 .
|
||||
38977) (%SYNONYM-STREAM-DEVICE-OUTCHARFN 38979 . 39686) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 39688 .
|
||||
40272) (%SYNONYM-STREAM-DEVICE-EOFP 40274 . 40465) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 40467 . 40705)
|
||||
(%SYNONYM-STREAM-DEVICE-GETFILEINFO 40707 . 40944) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40946 . 41169) (
|
||||
%SYNONYM-STREAM-DEVICE-READP 41171 . 41282) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 41284 . 41430) (
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO 41432 . 41681) (%SYNONYM-STREAM-DEVICE-CHARSETFN 41683 . 41919)) (
|
||||
41922 46247 (%TWO-WAY-STREAM-DEVICE-BIN 41932 . 42105) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 42107 .
|
||||
42298) (%TWO-WAY-STREAM-DEVICE-BOUT 42300 . 42472) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 42474 . 42664)
|
||||
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 42666 . 43528) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 43530 . 44953) (
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP 44955 . 45131) (%TWO-WAY-STREAM-DEVICE-READP 45133 . 45326) (
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 45328 . 45464) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 45466 . 45695) (
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN 45697 . 45910) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45912 . 46245)) (46835
|
||||
47074 (%SYNONYM-STREAM-DEVICE-GET-STREAM 46845 . 47072)) (47780 53743 (%INITIALIZE-CLSTREAM-TYPES
|
||||
47790 . 53741)))))
|
||||
(FILEMAP (NIL (5167 14142 (OPEN 5167 . 14142)) (14144 15070 (CL:CLOSE 14144 . 15070)) (15072 15150 (
|
||||
CL:STREAM-EXTERNAL-FORMAT 15072 . 15150)) (15152 15219 (CL:STREAM-ELEMENT-TYPE 15152 . 15219)) (15221
|
||||
15455 (CL:INPUT-STREAM-P 15221 . 15455)) (15457 15693 (CL:OUTPUT-STREAM-P 15457 . 15693)) (15695 15832
|
||||
(XCL:OPEN-STREAM-P 15695 . 15832)) (15834 15901 (FILE-STREAM-POSITION 15834 . 15901)) (15953 17296 (
|
||||
CL:MAKE-SYNONYM-STREAM 15953 . 17296)) (17298 17387 (XCL:SYNONYM-STREAM-P 17298 . 17387)) (17389 17527
|
||||
(XCL:SYNONYM-STREAM-SYMBOL 17389 . 17527)) (17529 17807 (XCL:FOLLOW-SYNONYM-STREAMS 17529 . 17807)) (
|
||||
17809 18568 (CL:MAKE-BROADCAST-STREAM 17809 . 18568)) (18570 18713 (XCL:BROADCAST-STREAM-P 18570 .
|
||||
18713)) (18715 18930 (XCL:BROADCAST-STREAM-STREAMS 18715 . 18930)) (18932 19617 (
|
||||
CL:MAKE-CONCATENATED-STREAM 18932 . 19617)) (19619 19718 (XCL:CONCATENATED-STREAM-P 19619 . 19718)) (
|
||||
19720 19933 (XCL:CONCATENATED-STREAM-STREAMS 19720 . 19933)) (19935 21519 (CL:MAKE-TWO-WAY-STREAM
|
||||
19935 . 21519)) (21521 21658 (XCL:TWO-WAY-STREAM-P 21521 . 21658)) (21660 21805 (
|
||||
XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21660 . 21805)) (21807 21951 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21807
|
||||
. 21951)) (21953 23503 (CL:MAKE-ECHO-STREAM 21953 . 23503)) (23505 23634 (XCL:ECHO-STREAM-P 23505 .
|
||||
23634)) (23636 23774 (XCL:ECHO-STREAM-INPUT-STREAM 23636 . 23774)) (23776 23915 (
|
||||
XCL:ECHO-STREAM-OUTPUT-STREAM 23776 . 23915)) (23917 24644 (CL:MAKE-STRING-INPUT-STREAM 23917 . 24644)
|
||||
) (24646 25139 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24646 . 25139)) (25141 25301 (
|
||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS 25141 . 25301)) (28348 29874 (MAKE-FILL-POINTER-OUTPUT-STREAM
|
||||
28348 . 29874)) (29876 30597 (CL:GET-OUTPUT-STREAM-STRING 29876 . 30597)) (30599 31078 (
|
||||
\\STRING-STREAM-OUTCHARFN 30599 . 31078)) (31080 32935 (\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31080 .
|
||||
32935)) (32964 33046 (%NEW-FILE 32964 . 33046)) (33048 33193 (PREDICT-NAME 33048 . 33193)) (33434
|
||||
34622 (%BROADCAST-STREAM-DEVICE-BOUT 33444 . 33667) (%BROADCAST-STREAM-DEVICE-OUTCHARFN 33669 . 34120)
|
||||
(%BROADCAST-STREAM-DEVICE-CLOSEFILE 34122 . 34361) (%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 34363 .
|
||||
34620)) (34624 34951 (%BROADCAST-STREAM-DEVICE-CHARSETFN 34624 . 34951)) (34952 37011 (
|
||||
%CONCATENATED-STREAM-DEVICE-BIN 34962 . 35367) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 35369 . 35682) (
|
||||
%CONCATENATED-STREAM-DEVICE-EOFP 35684 . 36048) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36050 . 36525) (
|
||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 36527 . 37009)) (37013 37344 (
|
||||
%CONCATENATED-STREAM-DEVICE-CHARSETFN 37013 . 37344)) (37345 37564 (%ECHO-STREAM-DEVICE-BIN 37355 .
|
||||
37562)) (37566 37791 (%SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM 37566 . 37791)) (37792 41137 (
|
||||
%SYNONYM-STREAM-DEVICE-BIN 37802 . 37990) (%SYNONYM-STREAM-DEVICE-BOUT 37992 . 38193) (
|
||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN 38195 . 38902) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 38904 . 39488) (
|
||||
%SYNONYM-STREAM-DEVICE-EOFP 39490 . 39681) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 39683 . 39921) (
|
||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO 39923 . 40160) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40162 . 40385) (
|
||||
%SYNONYM-STREAM-DEVICE-READP 40387 . 40498) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 40500 . 40646) (
|
||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO 40648 . 40897) (%SYNONYM-STREAM-DEVICE-CHARSETFN 40899 . 41135)) (
|
||||
41138 45463 (%TWO-WAY-STREAM-DEVICE-BIN 41148 . 41321) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 41323 .
|
||||
41514) (%TWO-WAY-STREAM-DEVICE-BOUT 41516 . 41688) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 41690 . 41880)
|
||||
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 41882 . 42744) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 42746 . 44169) (
|
||||
%TWO-WAY-STREAM-DEVICE-EOFP 44171 . 44347) (%TWO-WAY-STREAM-DEVICE-READP 44349 . 44542) (
|
||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 44544 . 44680) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 44682 . 44911) (
|
||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN 44913 . 45126) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45128 . 45461)) (45465
|
||||
45690 (%FILL-POINTER-STREAM-DEVICE-CLOSEFILE 45465 . 45690)) (45692 45811 (
|
||||
%FILL-POINTER-STREAM-DEVICE-GETFILEPTR 45692 . 45811)) (46051 46290 (%SYNONYM-STREAM-DEVICE-GET-STREAM
|
||||
46061 . 46288)) (46521 46997 (%INITIALIZE-STANDARD-STREAMS 46521 . 46997)) (46998 52961 (
|
||||
%INITIALIZE-CLSTREAM-TYPES 47008 . 52959)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
556
sources/CMLEXEC
556
sources/CMLEXEC
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Oct-2021 10:51:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLEXEC.;2 92464
|
||||
(FILECREATED "19-Dec-2021 09:48:29" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLEXEC.;5 91886
|
||||
|
||||
previous date%: "21-Jan-93 11:16:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLEXEC.;1)
|
||||
:CHANGES-TO (VARS CMLEXECCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Oct-2021 10:51:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLEXEC.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -18,7 +19,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(XCL:PROFILES "EXEC")
|
||||
(STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY)
|
||||
(* ;
|
||||
"These are public except for command-entry.")
|
||||
"These are public except for command-entry.")
|
||||
(FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW
|
||||
XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE
|
||||
@@ -29,7 +30,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(FUNCTIONS CIRCLAR-COPYER)
|
||||
(FNS COPY-CIRCLE)
|
||||
(* ;
|
||||
"CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
|
||||
"CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
|
||||
(FNS EXEC-READ DIR)
|
||||
(VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:///
|
||||
*CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED*
|
||||
@@ -64,10 +65,10 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(FILESLOAD CMLUNDO PROFILE)
|
||||
|
||||
(XCL:DEFPROFILE "EXEC" (XCL:*DEBUGGER-PROMPT* "")
|
||||
(XCL:*EXEC-PROMPT* "")
|
||||
(*READTABLE* "XCL")
|
||||
(*PACKAGE* "XCL")
|
||||
(XCL:*EVAL-FUNCTION* 'CL:EVAL))
|
||||
(XCL:*EXEC-PROMPT* "")
|
||||
(*READTABLE* "XCL")
|
||||
(*PACKAGE* "XCL")
|
||||
(XCL:*EVAL-FUNCTION* 'CL:EVAL))
|
||||
|
||||
(CL:DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST))
|
||||
ARGUMENTS
|
||||
@@ -148,39 +149,37 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(T (PRINT-EVENT-PROMPT *CURRENT-EVENT*)
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CURSOR T) (* ;
|
||||
"make sure can edit (in case cursor smashed somehow?)")
|
||||
"make sure can edit (in case cursor smashed somehow?)")
|
||||
(CL:WHEN NIL (* ; "Old expression")
|
||||
(TTYIN "" NIL NIL 'LISPXREAD NIL NIL BUFFER-EXPR-FROM-BELOW *READTABLE*))
|
||||
(EXEC-READ-LINE (LET ((%#RPARS NIL)
|
||||
(FONTCHANGEFLG NIL)
|
||||
(*PRINT-ESCAPE* T)
|
||||
(*PRINT-RADIX* (NOT (= *READ-BASE* 10)))
|
||||
(*PRINT-BASE* *READ-BASE*)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(*PRINT-GENSYM* ':REREAD)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-STRUCTURE* T))
|
||||
(DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG)
|
||||
(FONTCHANGEFLG NIL)
|
||||
(*PRINT-ESCAPE* T)
|
||||
(*PRINT-RADIX* (NOT (= *READ-BASE* 10)))
|
||||
(*PRINT-BASE* *READ-BASE*)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(*PRINT-GENSYM* ':REREAD)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-STRUCTURE* T))
|
||||
(DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG)
|
||||
(* ;
|
||||
"others are already globally special ")
|
||||
)
|
||||
(CL:WITH-OUTPUT-TO-STRING
|
||||
(STR)
|
||||
(FOR X ON INPUT
|
||||
DO (IF CIRCLE-FLAG
|
||||
THEN (* ;
|
||||
"Edited by TT (31-May-1990) CL:PRIN1 can print circlar")
|
||||
(CL:PRIN1 (CAR X)
|
||||
STR)
|
||||
ELSEIF (LISTP (CAR X))
|
||||
THEN (PRINTDEF (CAR X)
|
||||
(POSITION STR)
|
||||
NIL NIL NIL STR)
|
||||
ELSE (PRIN2 (CAR X)
|
||||
STR))
|
||||
(AND (CDR X)
|
||||
(PRIN1 " " STR])
|
||||
"others are already globally special "))
|
||||
(CL:WITH-OUTPUT-TO-STRING (STR)
|
||||
(FOR X ON INPUT
|
||||
DO (IF CIRCLE-FLAG
|
||||
THEN (* ;
|
||||
"Edited by TT (31-May-1990) CL:PRIN1 can print circlar")
|
||||
(CL:PRIN1 (CAR X)
|
||||
STR)
|
||||
ELSEIF (LISTP (CAR X))
|
||||
THEN (PRINTDEF (CAR X)
|
||||
(POSITION STR)
|
||||
NIL NIL NIL STR)
|
||||
ELSE (PRIN2 (CAR X)
|
||||
STR))
|
||||
(AND (CDR X)
|
||||
(PRIN1 " " STR])
|
||||
|
||||
(CL:DEFUN XCL::GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS)))
|
||||
(PROCESSPROP XCL::PROCESS 'PROFILE))
|
||||
@@ -192,7 +191,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(XCL:SAVE-PROFILE XCL::PROFILE))))
|
||||
|
||||
(CL:DEFUN XCL::SETF-GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS))
|
||||
(XCL::PROFILE XCL:*PROFILE*))
|
||||
(XCL::PROFILE XCL:*PROFILE*))
|
||||
(CL:SETQ XCL::PROFILE (XCL::PROFILIZE XCL::PROFILE))
|
||||
(PROCESSPROP XCL::PROCESS 'PROFILE XCL::PROFILE)
|
||||
XCL::PROFILE)
|
||||
@@ -215,7 +214,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"Start up an exec function in the proper profile, setting the default window title properly."
|
||||
(XCL:WITH-PROFILE (XCL:COPY-PROFILE XCL::PROFILE)
|
||||
(XCL::EXEC-TITLE-FUNCTION T (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
XCL::ID))
|
||||
(CL:FUNCALL XCL::EXEC-FUNCTION)))
|
||||
|
||||
(CL:DEFSETF XCL::GET-PROCESS-PROFILE XCL::SETF-GET-PROCESS-PROFILE)
|
||||
@@ -226,13 +225,13 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
STR
|
||||
(RETRYFLAG NIL) (* ; "A really gross hack for RETRY to always break. It exists because: users can setq HELPFLAG anywhere (can't bind it in DO-EVENTand set it in RETRY), RETRY operates on commands (can't wrap the form with a binding of HELPFLAG).")
|
||||
)
|
||||
(DECLARE (CL:SPECIAL RETRYFLAG)) (* ;
|
||||
"RETRY command sets this variable if it wants to be sure to break.")
|
||||
(DECLARE (CL:SPECIAL RETRYFLAG)) (* ;
|
||||
"RETRY command sets this variable if it wants to be sure to break.")
|
||||
(DSPFONT PRINTOUTFONT T)
|
||||
(SETQ INPUT ORIGINAL-INPUT)
|
||||
RETRY
|
||||
(SETQ TODO (COPY-CIRCLE INPUT)) (* ;
|
||||
"Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.")
|
||||
(SETQ TODO (COPY-CIRCLE INPUT)) (* ;
|
||||
"Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.")
|
||||
[COND
|
||||
[[AND (OR (STRINGP (CAR INPUT))
|
||||
(CL:SYMBOLP (CAR INPUT)))
|
||||
@@ -260,14 +259,13 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN *CURRENT-EVENT*
|
||||
(CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
INPUT) (* ;
|
||||
" Overwrite the original input with the newly generated one.")
|
||||
" Overwrite the original input with the newly generated one.")
|
||||
(CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*)
|
||||
(LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*
|
||||
))))
|
||||
(LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*))))
|
||||
(GO RETRY) (* ; " could have generated a command")
|
||||
)
|
||||
((NIL :EVAL) (* ;
|
||||
" normal kind of command, just apply")
|
||||
" normal kind of command, just apply")
|
||||
[SETQ TODO `((CL:FUNCALL ',(COMMAND-ENTRY-FUNCTION COM)
|
||||
',INPUT
|
||||
',ENVIRONMENT]
|
||||
@@ -284,11 +282,11 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN *EXEC-MAKE-UNDOABLE-P*
|
||||
[if (CDR TODO)
|
||||
then (SETQ TODO (CONS (OR (CDR (ASSOC (CAR TODO)
|
||||
LISPXFNS))
|
||||
(CAR TODO))
|
||||
(CDR TODO)))
|
||||
LISPXFNS))
|
||||
(CAR TODO))
|
||||
(CDR TODO)))
|
||||
else (SETQ TODO (LIST (XCL::MAKE-UNDOABLE (CAR TODO)
|
||||
NIL])]
|
||||
NIL])]
|
||||
(AND ADD-TO-SPELLING-LIST (HISTORY-ADD-TO-SPELLING-LISTS TODO))
|
||||
(SETQ LISPXHIST *CURRENT-EVENT*)
|
||||
(DSPFONT PRINTOUTFONT T)
|
||||
@@ -301,8 +299,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
[SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:IF RETRYFLAG
|
||||
(LET ((HELPFLAG 'BREAK!))
|
||||
(DECLARE (CL:SPECIAL HELPFLAG
|
||||
))
|
||||
(DECLARE (CL:SPECIAL HELPFLAG))
|
||||
(CL:FUNCALL FUNCTION TODO
|
||||
ENVIRONMENT))
|
||||
(CL:FUNCALL FUNCTION TODO ENVIRONMENT))
|
||||
@@ -319,69 +316,66 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(for X in VALUES do (EXEC-PRINT X))
|
||||
VALUES))))
|
||||
|
||||
(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;
|
||||
"True of top level execs. Used for event number restarting and profile caching.")
|
||||
(XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM)))
|
||||
(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;
|
||||
"True of top level execs. Used for event number restarting and profile caching.")
|
||||
(XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM)))
|
||||
(* ; "Window for this exec, if any.")
|
||||
(XCL::TITLE NIL XCL::TITLE-SUPPLIED)(* ;
|
||||
"If given, specific title for this window.")
|
||||
((:COMMAND-TABLES *THIS-EXEC-COMMANDS*)
|
||||
(LIST *EXEC-COMMAND-TABLE*)) (* ;
|
||||
"List of hash tables to look up commands in.")
|
||||
XCL::ENVIRONMENT (* ;
|
||||
"Lexical environment to evaluate things in, default NIL.")
|
||||
XCL::PROMPT (* ;
|
||||
"Special prompt to use (optional).")
|
||||
((:FUNCTION XCL::FN)
|
||||
'EVAL-INPUT) (* ; "Function for processing input.")
|
||||
XCL::PROFILE (* ;
|
||||
"Optional profile, sets the exec's bindings.")
|
||||
XCL::ID (* ; "A handle on the exec.")
|
||||
&ALLOW-OTHER-KEYS (* ; "To catch obsolete calls")
|
||||
&AUX
|
||||
(*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
(XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))
|
||||
(XCL::TITLE NIL XCL::TITLE-SUPPLIED) (* ;
|
||||
"If given, specific title for this window.")
|
||||
((:COMMAND-TABLES *THIS-EXEC-COMMANDS*)
|
||||
(LIST *EXEC-COMMAND-TABLE*)) (* ;
|
||||
"List of hash tables to look up commands in.")
|
||||
XCL::ENVIRONMENT (* ;
|
||||
"Lexical environment to evaluate things in, default NIL.")
|
||||
XCL::PROMPT (* ; "Special prompt to use (optional).")
|
||||
((:FUNCTION XCL::FN)
|
||||
'EVAL-INPUT) (* ; "Function for processing input.")
|
||||
XCL::PROFILE (* ;
|
||||
"Optional profile, sets the exec's bindings.")
|
||||
XCL::ID (* ; "A handle on the exec.")
|
||||
&ALLOW-OTHER-KEYS (* ; "To catch obsolete calls")
|
||||
&AUX
|
||||
(*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
(XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))
|
||||
(* ;
|
||||
"The exec's cached profile (if entering from a hardreset).")
|
||||
)
|
||||
"The exec's cached profile (if entering from a hardreset).")
|
||||
)
|
||||
[CL:PROGV (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION CAR))
|
||||
[MAPCAR *PER-EXEC-VARIABLES* (FUNCTION (LAMBDA (XCL::X)
|
||||
(EVAL (CADR XCL::X]
|
||||
(CL:WHEN (OR (NULL XCL::TOP-LEVEL-P)
|
||||
(NULL XCL::PROFILE-CACHE)) (* ; "If not hardresetting...")
|
||||
(CL:WHEN XCL::PROFILE (* ;
|
||||
"then initialize the profile vars.")
|
||||
(CL:WHEN XCL::PROFILE (* ; "then initialize the profile vars.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE))
|
||||
(CL:WHEN XCL::PROMPT (* ;
|
||||
"If a special prompt was provided (as from the debugger)...")
|
||||
"If a special prompt was provided (as from the debugger)...")
|
||||
(CL:SETQ XCL:*EXEC-PROMPT* XCL::PROMPT) (* ; "...use it.")
|
||||
))
|
||||
(CL:WHEN XCL::TOP-LEVEL-P
|
||||
(CL:IF (NULL XCL::PROFILE-CACHE) (* ;
|
||||
"This was a new entry into top level exec.")
|
||||
"This was a new entry into top level exec.")
|
||||
(CL:SETF (XCL::GET-PROCESS-PROFILE (THIS.PROCESS))
|
||||
(XCL:SAVE-PROFILE (XCL:COPY-PROFILE "EXEC")))
|
||||
(* ;
|
||||
"...make a fresh cache and save bindings into it.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ;
|
||||
"...otherwise it was a HARDRESET.")
|
||||
"...make a fresh cache and save bindings into it.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ; "...otherwise it was a HARDRESET.")
|
||||
))
|
||||
(CL:WHEN XCL::WINDOW
|
||||
(COND
|
||||
((NOT XCL::TITLE-SUPPLIED) (* ;
|
||||
"If no title was supplied, set it to the default.")
|
||||
"If no title was supplied, set it to the default.")
|
||||
(XCL::EXEC-TITLE-FUNCTION XCL::WINDOW *EXEC-ID*))
|
||||
(XCL::TITLE (* ;
|
||||
"If a non-nil title was supplied, set the title to it.")
|
||||
"If a non-nil title was supplied, set the title to it.")
|
||||
(WINDOWPROP XCL::WINDOW 'TITLE XCL::TITLE)))
|
||||
(TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))
|
||||
(LET [(*CURRENT-EVENT* NIL) (* ;
|
||||
"the event being processed. Used by some commands")
|
||||
"the event being processed. Used by some commands")
|
||||
(XCL::OLD-DS (CL:IF XCL::WINDOW
|
||||
(TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))]
|
||||
(CL:LOOP (CL:FORMAT T "~&~%%") (* ;
|
||||
"newlines to notice that this is a new instance of the exec")
|
||||
"newlines to notice that this is a new instance of the exec")
|
||||
(PROG1 [ERSETQ (CL:LOOP (* ; "loop until errors out")
|
||||
(CL:SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT
|
||||
LISPXHISTORY *EXEC-ID*
|
||||
@@ -397,25 +391,24 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE (CL:SPECIAL LISPXHIST HELPCLOCK))
|
||||
(CL:UNLESS (CL:EQUAL XCL::ORIGINAL-INPUT
|
||||
'(NIL))
|
||||
(DO-EVENT XCL::ORIGINAL-INPUT
|
||||
XCL::ENVIRONMENT XCL::FN)
|
||||
(DO-EVENT XCL::ORIGINAL-INPUT XCL::ENVIRONMENT
|
||||
XCL::FN)
|
||||
(CL:WHEN XCL::TOP-LEVEL-P
|
||||
(* ; "Used to determine whether to cache the settings of the profile back into the process (for retrieval in case of hardreset).")
|
||||
(XCL::SAVE-CURRENT-EXEC-PROFILE)))]
|
||||
(CL:WHEN XCL::WINDOW (TTYDISPLAYSTREAM XCL::OLD-DS)))])
|
||||
|
||||
(CL:DEFUN EXEC-EVAL (FORM &OPTIONAL ENVIRONMENT &KEY (PROMPT ">")
|
||||
(ID "eval/")
|
||||
((:TYPE *CURRENT-EXEC-TYPE*)
|
||||
'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.")
|
||||
(ID "eval/")
|
||||
((:TYPE *CURRENT-EXEC-TYPE*)
|
||||
'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.")
|
||||
(LET ((*CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY ID PROMPT T))
|
||||
(LISPXHIST LISPXHIST)
|
||||
(HELPCLOCK 0)
|
||||
VALUES)
|
||||
(DECLARE (CL:SPECIAL *CURRENT-EVENT* LISPXHIST HELPCLOCK))
|
||||
(SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT
|
||||
*CURRENT-EVENT*)
|
||||
(LIST FORM))
|
||||
(SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
(LIST FORM))
|
||||
ENVIRONMENT)))
|
||||
(SETQ IT (CAR VALUES))
|
||||
(COND
|
||||
@@ -455,8 +448,8 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
`(EXEC-VALUE-OF ',EVENT-SPEC))
|
||||
|
||||
(CL:DEFUN ADD-EXEC (&KEY (XCL::PROFILE XCL:*PROFILE*)
|
||||
XCL::REGION XCL::TTY (EXEC 'EXEC)
|
||||
XCL::ID &ALLOW-OTHER-KEYS)
|
||||
XCL::REGION XCL::TTY (EXEC 'EXEC)
|
||||
XCL::ID &ALLOW-OTHER-KEYS)
|
||||
(LET* [(XCL::WINDOW (XCL::SETUP-EXEC-WINDOW (CREATEW XCL::REGION "Exec")))
|
||||
(XCL::HANDLE (ADD.PROCESS
|
||||
`[PROGN (TTYDISPLAYSTREAM ',XCL::WINDOW)
|
||||
@@ -465,7 +458,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
',XCL::WINDOW)
|
||||
,(CASE EXEC
|
||||
(EXEC `(EXEC :TOP-LEVEL-P T :PROFILE ',XCL::PROFILE :ID
|
||||
',XCL::ID))
|
||||
',XCL::ID))
|
||||
(T `(XCL::ENTER-EXEC-FUNCTION ',EXEC ',XCL::PROFILE
|
||||
',XCL::ID)))]
|
||||
'NAME
|
||||
@@ -483,21 +476,21 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
((AND (READP T)
|
||||
(SYNTAXP (PEEKCCODE T T)
|
||||
'EOL)) (* ;
|
||||
"Avoid picking up end of line as a NIL.")
|
||||
"Avoid picking up end of line as a NIL.")
|
||||
(READC T)))
|
||||
(SETQ LINE (LIST (EXEC-READ BUFFER-STRING)))
|
||||
TOP (COND
|
||||
((LISTP (CAR LINE)) (* ;
|
||||
"If we got a list, return right away--it's a standard EVAL form of input")
|
||||
"If we got a list, return right away--it's a standard EVAL form of input")
|
||||
(GO OUT)))
|
||||
LP (SETQ SPACEFLG NIL) (* ; "to distinguish between")
|
||||
(* ; "FOO (A B)")
|
||||
(* ; "FOO(A B)")
|
||||
(* ;
|
||||
"the latter has no space and returns right away")
|
||||
"the latter has no space and returns right away")
|
||||
LP1 (COND
|
||||
((NOT (READP T)) (* ;
|
||||
"nothing more in line buffer, so must have consumed last thing on the line")
|
||||
"nothing more in line buffer, so must have consumed last thing on the line")
|
||||
(GO OUT))
|
||||
((NULL (SETQ CHRCODE (PEEKCCODE T T))) (* ; "PEEKCCODE can return NIL when stream is at EOF. However, we already checked for READP before getting here.")
|
||||
(GO OUT))
|
||||
@@ -510,7 +503,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SHOULDNT))
|
||||
(AND (NULL (CDR LINE))
|
||||
(SETQ LINE (NCONC1 LINE NIL))) (* ;
|
||||
" A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called")
|
||||
" A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called")
|
||||
(GO OUT))
|
||||
((EQ CHRCODE (CHARCODE SPACE))
|
||||
(SETQ SPACEFLG T)
|
||||
@@ -523,7 +516,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SYNTAXP CHRCODE 'RIGHTBRACKET *READTABLE*)))
|
||||
(GO LP))
|
||||
((NOT SPACEFLG) (* ;
|
||||
"A list terminates the line if it is the second element on the line, not preceded by a space.")
|
||||
"A list terminates the line if it is the second element on the line, not preceded by a space.")
|
||||
|
||||
(* ;; "[JDS 1/12/88: This used to test (AND (NOT SPACEFLG) (READP T)), and loop if there were more input pending. This seems wrong, because when you type it should throw the carriage at once, and not depend on how fast you're typing. Further, when there's type-ahead, it's often followed by a SPACE, to prevent output pausing. With the old test here, that would hang up a final eval-quote form without executing it.]")
|
||||
|
||||
@@ -533,7 +526,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
OUT (RETURN (COND
|
||||
((AND (LISTP LINE)
|
||||
CTRLUFLG) (* ;
|
||||
"Edit interrupt during reading--forces structure editor use.")
|
||||
"Edit interrupt during reading--forces structure editor use.")
|
||||
(SETQ CTRLUFLG NIL)
|
||||
(LET ((*EDIT-INPUT-WITH-TTYIN* NIL))
|
||||
(FIX-FORM LINE)))
|
||||
@@ -553,7 +546,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ COM (GETHASH STR TABLE)))
|
||||
TABLE))))
|
||||
|
||||
(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990")
|
||||
(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990")
|
||||
(PROG (SCANBUF REST VAL NEW BODY ID AUX (CIRCLAR-FLAG NIL))
|
||||
(COND
|
||||
((NLISTP INPUT)
|
||||
@@ -580,9 +573,9 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ CIRCLAR-FLAG T)
|
||||
(RPLACD NEW (CDR ID)))
|
||||
(T [push REST (SETQ AUX (CONS (CADR NEW)
|
||||
(CDDR NEW]
|
||||
(CDDR NEW]
|
||||
(push SCANBUF (CONS (CDR NEW)
|
||||
AUX))
|
||||
AUX))
|
||||
(RPLACD NEW AUX)))
|
||||
(COND
|
||||
((NLISTP (CAR NEW)))
|
||||
@@ -591,9 +584,9 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ CIRCLAR-FLAG T)
|
||||
(RPLACA NEW (CDR ID)))
|
||||
(T [push REST (SETQ AUX (CONS (CAAR NEW)
|
||||
(CDAR NEW]
|
||||
(CDAR NEW]
|
||||
(push SCANBUF (CONS (CAR NEW)
|
||||
AUX))
|
||||
AUX))
|
||||
(RPLACA NEW AUX]
|
||||
(GO LP)))
|
||||
(DEFINEQ
|
||||
@@ -727,10 +720,10 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"List of command hash-tables for the current executive")
|
||||
|
||||
(DEFGLOBALVAR *EXEC-COMMAND-TABLE* (HASHARRAY 30 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL)
|
||||
"hash-table for top level exec commands")
|
||||
"hash-table for top level exec commands")
|
||||
|
||||
(DEFGLOBALVAR *DEBUGGER-COMMAND-TABLE* (HASHARRAY 20 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL)
|
||||
"string-equal hash-table for debugger commands")
|
||||
"string-equal hash-table for debugger commands")
|
||||
|
||||
(CL:DEFVAR *CURRENT-EXEC-TYPE* NIL
|
||||
"Rebound under Exec; if NIL, means use default")
|
||||
@@ -1337,7 +1330,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"Start an old-style LISPX window"])
|
||||
|
||||
(ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100)
|
||||
(GREETHIST))
|
||||
(GREETHIST))
|
||||
|
||||
|
||||
|
||||
@@ -1347,24 +1340,23 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEF-DEFINE-TYPE COMMANDS "Exec Commands")
|
||||
|
||||
(DEFDEFINER (DEFCOMMAND [:NAME (CL:LAMBDA (WHOLE)
|
||||
(LET ((NAME (CL:SECOND WHOLE)))
|
||||
(CL:IF (CL:CONSP NAME)
|
||||
(CAR NAME)
|
||||
NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV
|
||||
&BODY BODY)
|
||||
(LET ((NAME (CL:SECOND WHOLE)))
|
||||
(CL:IF (CL:CONSP NAME)
|
||||
(CAR NAME)
|
||||
NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV
|
||||
&BODY BODY)
|
||||
[LET ((COMMAND-LEVEL '*EXEC-COMMAND-TABLE*)
|
||||
(COMMAND-TYPE :EVAL)
|
||||
(PREFIX "exec-"))
|
||||
[if (LISTP NAME)
|
||||
then (SETQ NAME (PROG1 (CAR NAME)
|
||||
[for X in (CDR NAME)
|
||||
do (CL:ECASE X
|
||||
((:QUIET :HISTORY :INPUT :EVAL :MACRO) (SETQ
|
||||
COMMAND-TYPE
|
||||
X))
|
||||
((:DEBUGGER :BREAK)
|
||||
(SETQ COMMAND-LEVEL '*DEBUGGER-COMMAND-TABLE*)
|
||||
(SETQ PREFIX "break-")))])]
|
||||
[for X in (CDR NAME) do (CL:ECASE X
|
||||
((:QUIET :HISTORY :INPUT :EVAL :MACRO)
|
||||
(SETQ COMMAND-TYPE X))
|
||||
((:DEBUGGER :BREAK)
|
||||
(SETQ COMMAND-LEVEL
|
||||
'*DEBUGGER-COMMAND-TABLE*)
|
||||
(SETQ PREFIX "break-")))])]
|
||||
(LET* ((CMACRONAME (PACK* PREFIX NAME))
|
||||
(STRINGNAME (STRING NAME)))
|
||||
(CL:MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING)
|
||||
@@ -1397,32 +1389,32 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:FORMAT T " ~20Tto apply function to the arguments given~&~%%or one of:")
|
||||
(FOR X ON (REVERSE *THIS-EXEC-COMMANDS*)
|
||||
DO (LET (COMS)
|
||||
[MAPHASH (CAR X)
|
||||
#'(CL:LAMBDA (VAL KEY)
|
||||
(AND [NOT (SOME (CDR X)
|
||||
#'(CL:LAMBDA (TAB)
|
||||
(GETHASH KEY TAB]
|
||||
(PUSH COMS (LIST KEY VAL]
|
||||
(CL:MAPC #'[CL:LAMBDA (COM)
|
||||
(CL:FORMAT T "~&")
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CL:FORMAT T "~A " (CAR COM))
|
||||
(DSPFONT COMMENTFONT T)
|
||||
(PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM)))
|
||||
(DSPFONT DEFAULTFONT T)
|
||||
(LET [(DOC (CL:DOCUMENTATION (CAR COM)
|
||||
'COMMANDS]
|
||||
(CL:WHEN DOC
|
||||
(TAB 20 1 T)
|
||||
(CL:FORMAT T "~A" DOC))]
|
||||
(CL:SORT COMS #'CL:STRING< :KEY #'CAR])
|
||||
[MAPHASH (CAR X)
|
||||
#'(CL:LAMBDA (VAL KEY)
|
||||
(AND [NOT (SOME (CDR X)
|
||||
#'(CL:LAMBDA (TAB)
|
||||
(GETHASH KEY TAB]
|
||||
(PUSH COMS (LIST KEY VAL]
|
||||
(CL:MAPC #'[CL:LAMBDA (COM)
|
||||
(CL:FORMAT T "~&")
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CL:FORMAT T "~A " (CAR COM))
|
||||
(DSPFONT COMMENTFONT T)
|
||||
(PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM)))
|
||||
(DSPFONT DEFAULTFONT T)
|
||||
(LET [(DOC (CL:DOCUMENTATION (CAR COM)
|
||||
'COMMANDS]
|
||||
(CL:WHEN DOC
|
||||
(TAB 20 1 T)
|
||||
(CL:FORMAT T "~A" DOC))]
|
||||
(CL:SORT COMS #'CL:STRING< :KEY #'CAR])
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND ("??" :QUIET) (&REST EVENT-SPECS) "Show events specified EVENT-SPECS (or all events)"
|
||||
(IF (AND EVENT-SPECS (EQ (CAR EVENT-SPECS)
|
||||
':INPUT))
|
||||
':INPUT))
|
||||
THEN (PRINT-HISTORY LISPXHISTORY (CDR EVENT-SPECS)
|
||||
T)
|
||||
T)
|
||||
ELSE (PRINT-HISTORY LISPXHISTORY EVENT-SPECS))
|
||||
(CL:VALUES))
|
||||
|
||||
@@ -1435,21 +1427,19 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEFCOMMAND ("DIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME"
|
||||
[DODIR (CONS PATHNAME (MAPCAR KEYWORDS (FUNCTION (LAMBDA (CL:KEYWORD)
|
||||
(IF (CL:SYMBOLP CL:KEYWORD)
|
||||
THEN (CL:INTERN (CL:SYMBOL-NAME
|
||||
CL:KEYWORD)
|
||||
"INTERLISP")
|
||||
THEN (CL:INTERN (CL:SYMBOL-NAME CL:KEYWORD)
|
||||
"INTERLISP")
|
||||
ELSE CL:KEYWORD])
|
||||
|
||||
(DEFCOMMAND "DO-EVENTS" (&REST INPUTS &ENVIRONMENT ENV)
|
||||
"Execute the multiple events in INPUTS, using the environment ENV for all evaluations."
|
||||
[LET ((OUTER-EVENT (AND *CURRENT-EVENT* (COPY-EXEC-EVENT *CURRENT-EVENT*)))
|
||||
(* ;
|
||||
"DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")
|
||||
"DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")
|
||||
)
|
||||
(CL:WHEN OUTER-EVENT
|
||||
(CL:SETF (EXEC-EVENT-INPUT OUTER-EVENT)
|
||||
(CONS 'DO-EVENTS INPUTS)) (* ;
|
||||
"Each of these is fixed up below.")
|
||||
(CONS 'DO-EVENTS INPUTS)) (* ; "Each of these is fixed up below.")
|
||||
)
|
||||
(ERSETQ (CL:MAPL #'[CL:LAMBDA (INPUT)
|
||||
(LET ([TODO (CL:IF (EQ (CAR (LISTP (CAR INPUT)))
|
||||
@@ -1460,32 +1450,32 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO))
|
||||
(SETQ VALUES (DO-EVENT TODO ENV))
|
||||
(* ;
|
||||
"If it exists, *CURRENT-EVENT* gets smashed here.")
|
||||
"If it exists, *CURRENT-EVENT* gets smashed here.")
|
||||
(CL:WHEN OUTER-EVENT (* ; "If there is an outer event...")
|
||||
|
||||
(* ;;
|
||||
"Fix the outer event's list of inputs with the expanded input.")
|
||||
"Fix the outer event's list of inputs with the expanded input.")
|
||||
|
||||
(RPLACA INPUT (CAR (EXEC-EVENT-INPUT *CURRENT-EVENT*)))
|
||||
(CL:WHEN VALUES (* ;
|
||||
"If the last sub-event generated some values...")
|
||||
"If the last sub-event generated some values...")
|
||||
|
||||
(* ;;
|
||||
"Add the new values to the outer event's values.")
|
||||
"Add the new values to the outer event's values.")
|
||||
|
||||
[LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS
|
||||
OUTER-EVENT)
|
||||
[LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS
|
||||
OUTER-EVENT)
|
||||
'LISPXVALUES]
|
||||
(CL:IF OLD-VALUES
|
||||
(NCONC OLD-VALUES VALUES)
|
||||
(CL:SETF (EXEC-EVENT-PROPS OUTER-EVENT)
|
||||
(LIST* 'LISPXVALUES VALUES
|
||||
(EXEC-EVENT-PROPS
|
||||
OUTER-EVENT))))]))]
|
||||
(EXEC-EVENT-PROPS OUTER-EVENT))
|
||||
))]))]
|
||||
INPUTS))
|
||||
(CL:WHEN *CURRENT-EVENT* (* ; "If there was a current event...")
|
||||
(* ;
|
||||
"Smash saved values back from OUTER-EVENT.")
|
||||
"Smash saved values back from OUTER-EVENT.")
|
||||
(CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
(EXEC-EVENT-INPUT OUTER-EVENT))
|
||||
(CL:SETF (EXEC-EVENT-ID *CURRENT-EVENT*)
|
||||
@@ -1496,19 +1486,18 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(EXEC-EVENT-PROPS OUTER-EVENT)))]
|
||||
(SETQ *CURRENT-EVENT* NIL) (* ; "Keeps the DO-EVENT which is evaluating us from setting the event's results to (the result of evaluating) the NIL we return. This is alright since *CURRENT-EVENT* is already pointed to by the history list.")
|
||||
(CL:VALUES) (* ;
|
||||
"We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.")
|
||||
"We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.")
|
||||
)
|
||||
|
||||
(DEFCOMMAND ("FIX" :HISTORY) (&REST EVENT-SPEC) "Edit input for specified events"
|
||||
[APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT
|
||||
(FIND-HISTORY-EVENTS
|
||||
(OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY])
|
||||
[APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT (FIND-HISTORY-EVENTS
|
||||
(OR EVENT-SPEC
|
||||
'(-1))
|
||||
LISPXHISTORY])
|
||||
|
||||
(DEFCOMMAND "FORGET" (&REST EVENT-SPEC) "Erase UNDO information (for specified events)."
|
||||
(FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY) DO (UNDOLISPX2 EVENT T)
|
||||
FINALLY (CL:FORMAT T "Forgotten.~&"))
|
||||
LISPXHISTORY) DO (UNDOLISPX2 EVENT T) FINALLY (CL:FORMAT T "Forgotten.~&"))
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND "NAME" (COMMAND-NAME &OPTIONAL ARGUMENT-LIST &REST EVENT-SPEC)
|
||||
@@ -1517,8 +1506,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:PUSH ARGUMENT-LIST EVENT-SPEC)
|
||||
(SETQ ARGUMENT-LIST NIL))
|
||||
[LET [(EVENTS (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY))
|
||||
(ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST
|
||||
COLLECT (PACK* 'ARG I]
|
||||
(ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST COLLECT (PACK* 'ARG I]
|
||||
(CL:EVAL `(DEFCOMMAND (,COMMAND-NAME :HISTORY) ,ARGNAMES
|
||||
[SUBPAIR ',ARGNAMES (LIST ,@ARGNAMES)
|
||||
',(SUBPAIR ARGUMENT-LIST ARGNAMES (EVENTS-INPUT EVENTS)
|
||||
@@ -1536,7 +1524,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(DEFCOMMAND ("REDO" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified event(s)"
|
||||
(EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY)))
|
||||
LISPXHISTORY)))
|
||||
|
||||
(DEFCOMMAND ("REMEMBER" :EVAL) (&REST EVENT-SPEC)
|
||||
"Tell Manager to remember type-in from specified event(s)"
|
||||
@@ -1549,40 +1537,37 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEFCOMMAND "UNDO" (&REST EVENT-SPEC)
|
||||
"Undo side effects associated with the specified event (or last undoable one)"
|
||||
[FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT)))
|
||||
(RESULT (UNDOLISPX2 EVENT)))
|
||||
(CL:IF (LISTP INPUT)
|
||||
(SETQ INPUT (CAR INPUT)))
|
||||
(COND
|
||||
((NULL RESULT)
|
||||
(CL:FORMAT T
|
||||
"No undo info saved for ~A.~&"
|
||||
INPUT))
|
||||
((EQ RESULT 'already)
|
||||
(CL:FORMAT T "~A already undone.~&"
|
||||
INPUT))
|
||||
(T (CL:FORMAT T "~A undone.~&" INPUT]
|
||||
LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT)))
|
||||
(RESULT (UNDOLISPX2 EVENT)))
|
||||
(CL:IF (LISTP INPUT)
|
||||
(SETQ INPUT (CAR INPUT)))
|
||||
(COND
|
||||
((NULL RESULT)
|
||||
(CL:FORMAT T "No undo info saved for ~A.~&" INPUT))
|
||||
((EQ RESULT 'already)
|
||||
(CL:FORMAT T "~A already undone.~&" INPUT))
|
||||
(T (CL:FORMAT T "~A undone.~&" INPUT]
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND ("USE" :HISTORY) (&REST LINE) "USE <new> [FOR <old>] [IN <event-spec>]"
|
||||
|
||||
(* ;;
|
||||
"this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible")
|
||||
"this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible")
|
||||
|
||||
[PROG (EVENT-SPECS EXPR ARGS VARS (STATE 'VARS)
|
||||
LST TEM USE-ARGS GENLST)
|
||||
LP [COND
|
||||
([OR (NULL LST)
|
||||
(NULL (CDR LINE))
|
||||
(NULL (CASE-EQUALP (CAR LINE) (* ;
|
||||
"look for one of the special keywords")
|
||||
(NULL (CASE-EQUALP (CAR LINE) (* ;
|
||||
"look for one of the special keywords")
|
||||
(FOR (COND
|
||||
((EQ STATE 'VARS)
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'ARGS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
((EQ STATE 'VARS)
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'ARGS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
(AND (COND
|
||||
((EQ STATE 'EXPR)
|
||||
NIL)
|
||||
@@ -1590,30 +1575,30 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST)))
|
||||
((EQ STATE 'VARS)(* ;
|
||||
"E.g. user types USE A AND B following previous USE command.")
|
||||
"E.g. user types USE A AND B following previous USE command.")
|
||||
(SETQ VARS (NCONC1 VARS LST]
|
||||
(SETQ STATE 'VARS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
(IN (COND
|
||||
((AND (EQ STATE 'VARS)
|
||||
(NULL ARGS))
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T)
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T]
|
||||
((AND (EQ STATE 'VARS)
|
||||
(NULL ARGS))
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T)
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T]
|
||||
(SETQ LST (NCONC1 LST (COND
|
||||
(NIL (MEMBER (CAR LINE)
|
||||
TEM)
|
||||
|
||||
(* ;;
|
||||
"This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A")
|
||||
"This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A")
|
||||
|
||||
(LET ((TEMP (CONCAT "temp string")))
|
||||
(CL:PUSH (CONS (CAR LINE)
|
||||
@@ -1639,7 +1624,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(SETQ EXPR (MAPCAR (FIND-HISTORY-EVENTS EXPR LISPXHISTORY)
|
||||
(FUNCTION EXEC-EVENT-INPUT))) (* ;
|
||||
"EXPR is now a list of event inputs")
|
||||
"EXPR is now a list of event inputs")
|
||||
|
||||
(* ;; "at this point, VARS is a list of list of old things, the extra list corresponding to the clauses of an AND, e.g. ")
|
||||
|
||||
@@ -1651,60 +1636,68 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(IF (NULL ARGS)
|
||||
THEN [SETQ EXPR (FOR X IN EXPR
|
||||
JOIN (FOR VAR IN VARS
|
||||
COLLECT (IF (CL:CONSP (CAR X))
|
||||
THEN (CONS (CONS (CAR VAR)
|
||||
(CDAR X))
|
||||
(CDR X))
|
||||
ELSE (CONS (CAR VAR)
|
||||
(CDR X]
|
||||
JOIN (FOR VAR IN VARS
|
||||
COLLECT (IF (CL:CONSP (CAR X))
|
||||
THEN (CONS (CONS (CAR VAR)
|
||||
(CDAR X))
|
||||
(CDR X))
|
||||
ELSE (CONS (CAR VAR)
|
||||
(CDR X]
|
||||
ELSE (WHILE ARGS DO (SETQ EXPR (LISPXUSE1 (POP VARS)
|
||||
(POP ARGS)
|
||||
EXPR))
|
||||
FINALLY (COND
|
||||
(VARS (ERROR '"use what??" "" T)))
|
||||
[MAPC GENLST (FUNCTION (LAMBDA (X)
|
||||
(LISPXSUBST (CAR X)
|
||||
(CDR X)
|
||||
EXPR T]
|
||||
(POP ARGS)
|
||||
EXPR)) FINALLY (COND
|
||||
(VARS (ERROR '"use what??" "" T)))
|
||||
[MAPC GENLST (FUNCTION (LAMBDA (X)
|
||||
(LISPXSUBST
|
||||
(CAR X)
|
||||
(CDR X)
|
||||
EXPR T]
|
||||
|
||||
(* ;; "samples:")
|
||||
(* ;; "samples:")
|
||||
|
||||
(* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y")
|
||||
(* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y")
|
||||
|
||||
(* ;; " Equivalent to USE A C FOR X AND B D FOR Y")
|
||||
(* ;;
|
||||
" Equivalent to USE A C FOR X AND B D FOR Y")
|
||||
|
||||
(* ;; " USE A B C FOR D AND X Y Z FOR W means 3 operations:")
|
||||
(* ;;
|
||||
" USE A B C FOR D AND X Y Z FOR W means 3 operations:")
|
||||
|
||||
(* ;; " A for D and X for W in the first")
|
||||
(* ;;
|
||||
" A for D and X for W in the first")
|
||||
|
||||
(* ;; " B for D and Y for W in the second")
|
||||
(* ;;
|
||||
" B for D and Y for W in the second")
|
||||
|
||||
(* ;; " C for D and Z for W in the third")
|
||||
(* ;;
|
||||
" C for D and Z for W in the third")
|
||||
|
||||
(* ;; "USE A B C FOR D AND X FOR Y means 3 operations:")
|
||||
(* ;;
|
||||
"USE A B C FOR D AND X FOR Y means 3 operations:")
|
||||
|
||||
(* ;; " A for D and X for Y in first")
|
||||
(* ;; " A for D and X for Y in first")
|
||||
|
||||
(* ;; " B for D and X for Y in second, etc.")
|
||||
(* ;;
|
||||
" B for D and X for Y in second, etc.")
|
||||
|
||||
(* ;; "USE A B C FOR D AND X Y FOR Z causes error")
|
||||
(* ;;
|
||||
"USE A B C FOR D AND X Y FOR Z causes error")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.")
|
||||
(* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.")
|
||||
(* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.")
|
||||
|
||||
))
|
||||
))
|
||||
(RETURN (COND
|
||||
[(CDR EXPR)
|
||||
(CONS 'DO-EVENTS (for X in EXPR collect (COND
|
||||
((CDR X)
|
||||
(CONS 'EVENT X))
|
||||
(T (CAR X]
|
||||
((CDR X)
|
||||
(CONS 'EVENT X))
|
||||
(T (CAR X]
|
||||
(T (CAR EXPR])
|
||||
|
||||
(DEFCOMMAND "PP" (&OPTIONAL (NAME LASTWORD)
|
||||
@@ -1714,25 +1707,22 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "returned from if no definitions found")
|
||||
|
||||
(for TYPE in [OR TYPES [TYPESOF NAME NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE
|
||||
'EDITDEF)
|
||||
'NILL]
|
||||
(TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL
|
||||
[FUNCTION (LAMBDA (WORD)
|
||||
(TYPESOF
|
||||
WORD NIL
|
||||
'(FIELDS FILES)
|
||||
'CURRENT]
|
||||
NIL NIL NIL 'MUSTAPPROVE)
|
||||
(PROGN (CL:FORMAT *TERMINAL-IO*
|
||||
"No definitions found for ~S."
|
||||
NAME)
|
||||
(RETURN NIL]
|
||||
NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
(TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL
|
||||
[FUNCTION (LAMBDA (WORD)
|
||||
(TYPESOF WORD NIL
|
||||
'(FIELDS FILES)
|
||||
'CURRENT]
|
||||
NIL NIL NIL 'MUSTAPPROVE)
|
||||
(PROGN (CL:FORMAT *TERMINAL-IO*
|
||||
"No definitions found for ~S." NAME)
|
||||
(RETURN NIL]
|
||||
NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME)
|
||||
(SHOWDEF NAME TYPE)))
|
||||
(SHOWDEF NAME TYPE)))
|
||||
(CL:VALUES))
|
||||
|
||||
|
||||
@@ -1740,7 +1730,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "Arrange to use the correct compiler")
|
||||
|
||||
|
||||
(PUTPROPS CMLEXEC FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLEXEC FILETYPE :FAKE-COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA DIR)
|
||||
@@ -1751,22 +1741,22 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS CMLEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3978 4383 (XCL::EXEC-CLOSEFN 3978 . 4383)) (4385 4721 (XCL::EXEC-SHRINKFN 4385 . 4721))
|
||||
(4723 4963 (XCL::SETUP-EXEC-WINDOW 4723 . 4963)) (4965 5211 (XCL::EXEC-TITLE-FUNCTION 4965 . 5211)) (
|
||||
5213 8519 (FIX-FORM 5213 . 8519)) (8521 8641 (XCL::GET-PROCESS-PROFILE 8521 . 8641)) (8643 8924 (
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE 8643 . 8924)) (8926 9216 (XCL::SETF-GET-PROCESS-PROFILE 8926 . 9216)) (
|
||||
9218 9785 (XCL:SET-EXEC-TYPE 9218 . 9785)) (9787 9869 (XCL:SET-DEFAULT-EXEC-TYPE 9787 . 9869)) (9871
|
||||
10282 (XCL::ENTER-EXEC-FUNCTION 9871 . 10282)) (10357 16750 (DO-EVENT 10357 . 16750)) (16752 23543 (
|
||||
EXEC 16752 . 23543)) (23545 24886 (EXEC-EVAL 23545 . 24886)) (24888 25619 (PRINT-ALL-DOCUMENTATION
|
||||
24888 . 25619)) (25621 26063 (PRINT-DOCUMENTATION 25621 . 26063)) (26146 27230 (ADD-EXEC 26146 . 27230
|
||||
)) (27232 30828 (EXEC-READ-LINE 27232 . 30828)) (30899 31385 (FIND-EXEC-COMMAND 30899 . 31385)) (31387
|
||||
33285 (CIRCLAR-COPYER 31387 . 33285)) (33286 34240 (COPY-CIRCLE 33296 . 34238)) (34318 37623 (
|
||||
EXEC-READ 34328 . 37489) (DIR 37491 . 37621)) (39885 67019 (DO-APPLY-EVENT 39895 . 40457) (
|
||||
DO-HISTORY-SEARCH 40459 . 41916) (EVAL-INPUT 41918 . 47347) (EVENTS-INPUT 47349 . 48727) (EXEC-PRIN1
|
||||
48729 . 48905) (EXEC-VALUE-OF 48907 . 49246) (GET-NEXT-HISTORY-EVENT 49248 . 50743) (
|
||||
HISTORY-ADD-TO-SPELLING-LISTS 50745 . 51733) (HISTORY-NTH 51735 . 52485) (PRINT-HISTORY 52487 . 53108)
|
||||
(FIND-HISTORY-EVENTS 53110 . 58171) (PRINT-EVENT 58173 . 62394) (PRINT-EVENT-PROMPT 62396 . 63600) (
|
||||
PROCESS-EXEC-ID 63602 . 64547) (SEARCH-FOR-EVENT-NUMBER 64549 . 65177) (\PICK.EVALQT 65179 . 65690) (
|
||||
LISPXREPRINT 65692 . 67017)) (68199 68298 (EXEC-PRINT 68199 . 68298)) (68300 68565 (EXEC-FORMAT 68300
|
||||
. 68565)))))
|
||||
(FILEMAP (NIL (4002 4407 (XCL::EXEC-CLOSEFN 4002 . 4407)) (4409 4745 (XCL::EXEC-SHRINKFN 4409 . 4745))
|
||||
(4747 4987 (XCL::SETUP-EXEC-WINDOW 4747 . 4987)) (4989 5235 (XCL::EXEC-TITLE-FUNCTION 4989 . 5235)) (
|
||||
5237 8404 (FIX-FORM 5237 . 8404)) (8406 8526 (XCL::GET-PROCESS-PROFILE 8406 . 8526)) (8528 8809 (
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE 8528 . 8809)) (8811 9097 (XCL::SETF-GET-PROCESS-PROFILE 8811 . 9097)) (
|
||||
9099 9666 (XCL:SET-EXEC-TYPE 9099 . 9666)) (9668 9750 (XCL:SET-DEFAULT-EXEC-TYPE 9668 . 9750)) (9752
|
||||
10159 (XCL::ENTER-EXEC-FUNCTION 9752 . 10159)) (10234 16465 (DO-EVENT 10234 . 16465)) (16467 23064 (
|
||||
EXEC 16467 . 23064)) (23066 24317 (EXEC-EVAL 23066 . 24317)) (24319 25050 (PRINT-ALL-DOCUMENTATION
|
||||
24319 . 25050)) (25052 25494 (PRINT-DOCUMENTATION 25052 . 25494)) (25577 26652 (ADD-EXEC 25577 . 26652
|
||||
)) (26654 30264 (EXEC-READ-LINE 26654 . 30264)) (30335 30821 (FIND-EXEC-COMMAND 30335 . 30821)) (30823
|
||||
32709 (CIRCLAR-COPYER 30823 . 32709)) (32710 33664 (COPY-CIRCLE 32720 . 33662)) (33742 37047 (
|
||||
EXEC-READ 33752 . 36913) (DIR 36915 . 37045)) (39301 66435 (DO-APPLY-EVENT 39311 . 39873) (
|
||||
DO-HISTORY-SEARCH 39875 . 41332) (EVAL-INPUT 41334 . 46763) (EVENTS-INPUT 46765 . 48143) (EXEC-PRIN1
|
||||
48145 . 48321) (EXEC-VALUE-OF 48323 . 48662) (GET-NEXT-HISTORY-EVENT 48664 . 50159) (
|
||||
HISTORY-ADD-TO-SPELLING-LISTS 50161 . 51149) (HISTORY-NTH 51151 . 51901) (PRINT-HISTORY 51903 . 52524)
|
||||
(FIND-HISTORY-EVENTS 52526 . 57587) (PRINT-EVENT 57589 . 61810) (PRINT-EVENT-PROMPT 61812 . 63016) (
|
||||
PROCESS-EXEC-ID 63018 . 63963) (SEARCH-FOR-EVENT-NUMBER 63965 . 64593) (\PICK.EVALQT 64595 . 65106) (
|
||||
LISPXREPRINT 65108 . 66433)) (67615 67714 (EXEC-PRINT 67615 . 67714)) (67716 67981 (EXEC-FORMAT 67716
|
||||
. 67981)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,15 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "16-May-90 14:59:25" {DSK}<usr>local>lde>lispcore>sources>COMPARE.;2 12260
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS COMPARECOMS)
|
||||
(FILECREATED "29-Nov-2021 14:05:45" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;3 12592
|
||||
|
||||
previous date%: "20-Jan-87 12:44:37" {DSK}<usr>local>lde>lispcore>sources>COMPARE.;1)
|
||||
changes to%: (FNS COMPARE1)
|
||||
|
||||
previous date%: " 5-Nov-2021 20:53:09"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1987, 1990 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COMPARECOMS)
|
||||
@@ -31,9 +33,10 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
(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
|
||||
@@ -47,7 +50,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
(PROG NIL
|
||||
LP (RETURN (COND
|
||||
((NLISTP X)
|
||||
(OR (EQUAL X Y)
|
||||
(OR (EQUALALL X Y)
|
||||
(COMPAREFAIL X Y)))
|
||||
((NLISTP Y)
|
||||
(COMPAREFAIL X Y))
|
||||
@@ -58,7 +61,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
(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])
|
||||
|
||||
@@ -214,7 +217,11 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
(TERPRI STREAM])
|
||||
|
||||
(COMPAREPRINTN
|
||||
[LAMBDA (N SPACE FLG STREAM) (* ; "Edited 29-Dec-86 11:56 by jds")
|
||||
[LAMBDA (N SPACE FLG STREAM) (* ; "Edited 5-Nov-2021 20:53 by rmk:")
|
||||
(* ; "Edited 29-Dec-86 11:56 by jds")
|
||||
|
||||
(* ;; "RMK: Added STREAM to POSITION and LINELENGTH")
|
||||
|
||||
[COND
|
||||
((NEQ N 0)
|
||||
(COND
|
||||
@@ -223,9 +230,9 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
(SELECTQ N
|
||||
(1 (PRIN1 '& STREAM))
|
||||
(PROGN (COND
|
||||
((NOT (ILESSP (IPLUS (POSITION)
|
||||
((NOT (ILESSP (IPLUS (POSITION STREAM)
|
||||
7)
|
||||
(LINELENGTH)))
|
||||
(LINELENGTH NIL STREAM)))
|
||||
(TERPRI STREAM)))
|
||||
(PRIN1 '- STREAM)
|
||||
(PRIN2 N STREAM)
|
||||
@@ -299,7 +306,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
)
|
||||
(PUTPROPS COMPARE COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (823 11885 (COMPARELST 833 . 1095) (COMPARE1 1097 . 2506) (COMPAREPRINT 2508 . 3465) (
|
||||
COMPAREPRINT1 3467 . 7731) (COMPARELISTS 7733 . 9020) (COMPAREPRINTN 9022 . 9666) (COMPARENCHARS 9668
|
||||
. 10226) (COMPAREFAIL 10228 . 11355) (COMPAREMAX 11357 . 11594) (COUNTDOWN 11596 . 11883)))))
|
||||
(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.
148
sources/COREIO
148
sources/COREIO
@@ -1,14 +1,15 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED " 4-Oct-2018 14:13:06" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>COREIO.;4 55097
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (FNS \CORE.GETFILEINFO)
|
||||
(FILECREATED "22-Nov-2021 09:25:42" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;3 55023
|
||||
|
||||
previous date%: "28-Jun-99 16:15:28"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>COREIO.;3)
|
||||
changes to%: (FNS \CORE.SETFILEINFO)
|
||||
|
||||
previous date%: " 4-Oct-2018 14:13:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COREIO.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1981-1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT COREIOCOMS)
|
||||
@@ -16,7 +17,7 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
||||
(RPAQQ COREIOCOMS
|
||||
(
|
||||
|
||||
(* ;;; "Implementation of Core resident `files'")
|
||||
(* ;;; "Implementation of Core resident `files'")
|
||||
|
||||
(FNS \CORE.CLOSEFILE \CORE.DELETEFILE \CORE.DIRECTORYNAMEP \CORE.FINDPAGE \CORE.GENERATEFILES
|
||||
\CORE.NEXTFILEFN \CORE.FILEINFOFN \CORE.GETFILEHANDLE \CORE.GETFILEINFO
|
||||
@@ -611,7 +612,8 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
||||
STREAM])
|
||||
|
||||
(\CORE.SETFILEINFO
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEV) (* bvm%: "15-Jan-85 17:40")
|
||||
[LAMBDA (STREAM ATTRIBUTE VALUE DEV) (* ; "Edited 22-Nov-2021 09:25 by rmk:")
|
||||
(* bvm%: "15-Jan-85 17:40")
|
||||
(PROG ((INFOBLOCK (\CORE.GETINFOBLOCK STREAM 'OLD DEV)))
|
||||
(SELECTQ ATTRIBUTE
|
||||
(CREATIONDATE (SETQ VALUE (OR (IDATE VALUE)
|
||||
@@ -624,10 +626,20 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
||||
(replace IOFIBType of INFOBLOCK with VALUE))
|
||||
(EOL (replace COREEOLC of INFOBLOCK
|
||||
with (SELECTQ VALUE
|
||||
(CR CR.EOLC)
|
||||
(LF LF.EOLC)
|
||||
(CRLF CRLF.EOLC)
|
||||
(LISPERROR "ILLEGAL ARG" VALUE))))
|
||||
(CR CR.EOLC)
|
||||
(LF LF.EOLC)
|
||||
(CRLF CRLF.EOLC)
|
||||
(LISPERROR "ILLEGAL ARG" VALUE))))
|
||||
(CREATIONDATE (replace IOFIBCreationTime of INFOBLOCK
|
||||
with (IDATE VALUE)))
|
||||
(READDATE (replace IOFIBReadTime of INFOBLOCK
|
||||
with (IDATE VALUE)))
|
||||
(WRITEDATE (replace IOFIBWriteTime of INFOBLOCK
|
||||
with (IDATE VALUE)))
|
||||
(ICREATIONDATE (replace IOFIBCreationTime of INFOBLOCK
|
||||
with VALUE))
|
||||
(IREADDATE (replace IOFIBReadTime of INFOBLOCK with VALUE))
|
||||
(IWRITEDATE (replace IOFIBWriteTime of INFOBLOCK with VALUE))
|
||||
NIL])
|
||||
|
||||
(\CORE.GETNEXTBUFFER
|
||||
@@ -851,60 +863,48 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
||||
(RECORD CORE.PAGEENTRY (PAGENUMBER . PAGEPOINTER))
|
||||
|
||||
(DATATYPE COREFILEINFOBLK ((IOFIBCreationTime FIXP)
|
||||
(IOFIBReadTime FIXP)
|
||||
(IOFIBWriteTime FIXP)
|
||||
(IOFIBType POINTER)
|
||||
(IOFILEPAGES POINTER)
|
||||
(IOFILEFULLNAME POINTER)
|
||||
(IOEPAGE WORD)
|
||||
(IOEOFFSET WORD)
|
||||
(COREEOLC BITS 2)
|
||||
(IOFIBFileType WORD))
|
||||
IOFIBCreationTime _ (IDATE)
|
||||
IOFILEPAGES _ (LIST (create CORE.PAGEENTRY
|
||||
PAGENUMBER _ 0))
|
||||
COREEOLC _ CR.EOLC)
|
||||
(IOFIBReadTime FIXP)
|
||||
(IOFIBWriteTime FIXP)
|
||||
(IOFIBType POINTER)
|
||||
(IOFILEPAGES POINTER)
|
||||
(IOFILEFULLNAME POINTER)
|
||||
(IOEPAGE WORD)
|
||||
(IOEOFFSET WORD)
|
||||
(COREEOLC BITS 2)
|
||||
(IOFIBFileType WORD))
|
||||
IOFIBCreationTime _ (IDATE)
|
||||
IOFILEPAGES _ (LIST (create CORE.PAGEENTRY
|
||||
PAGENUMBER _ 0))
|
||||
COREEOLC _ CR.EOLC)
|
||||
|
||||
(RECORD CORESTREAM STREAM (SUBRECORD STREAM)
|
||||
[ACCESSFNS CORESTREAM ((INFOBLK (fetch F1 of DATUM)
|
||||
(replace F1 of DATUM with
|
||||
NEWVALUE))
|
||||
(COREPAGECACHE (fetch F10 of DATUM)
|
||||
(replace F10 of DATUM with
|
||||
NEWVALUE))
|
||||
(BEINGPRINTED (fetch IOBEINGPRINTED
|
||||
of (fetch INFOBLK
|
||||
of DATUM))
|
||||
(replace IOBEINGPRINTED
|
||||
of (fetch INFOBLK of DATUM)
|
||||
with NEWVALUE))
|
||||
(FILEPAGES (fetch IOFILEPAGES
|
||||
of (fetch INFOBLK
|
||||
of DATUM))
|
||||
(replace IOFILEPAGES
|
||||
of (fetch INFOBLK of DATUM)
|
||||
with NEWVALUE))
|
||||
(CreationTime (fetch IOFIBCreationTime
|
||||
of (fetch INFOBLK
|
||||
of DATUM))
|
||||
(replace IOFIBCreationTime
|
||||
of (fetch INFOBLK of DATUM)
|
||||
with NEWVALUE))
|
||||
(ReadTime (fetch IOFIBReadTime
|
||||
of (fetch INFOBLK
|
||||
of DATUM))
|
||||
(replace IOFIBReadTime
|
||||
of (fetch INFOBLK of DATUM)
|
||||
with NEWVALUE))
|
||||
(WriteTime (fetch IOFIBWriteTime
|
||||
of (fetch INFOBLK
|
||||
of DATUM))
|
||||
(replace IOFIBWriteTime
|
||||
of (fetch INFOBLK of DATUM)
|
||||
with NEWVALUE])
|
||||
[ACCESSFNS CORESTREAM ((INFOBLK (fetch F1 of DATUM)
|
||||
(replace F1 of DATUM with NEWVALUE))
|
||||
(COREPAGECACHE (fetch F10 of DATUM)
|
||||
(replace F10 of DATUM with NEWVALUE))
|
||||
(BEINGPRINTED (fetch IOBEINGPRINTED
|
||||
of (fetch INFOBLK of DATUM))
|
||||
(replace IOBEINGPRINTED
|
||||
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||
(FILEPAGES (fetch IOFILEPAGES
|
||||
of (fetch INFOBLK of DATUM))
|
||||
(replace IOFILEPAGES
|
||||
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||
(CreationTime (fetch IOFIBCreationTime
|
||||
of (fetch INFOBLK of DATUM))
|
||||
(replace IOFIBCreationTime
|
||||
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||
(ReadTime (fetch IOFIBReadTime
|
||||
of (fetch INFOBLK of DATUM))
|
||||
(replace IOFIBReadTime
|
||||
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||
(WriteTime (fetch IOFIBWriteTime
|
||||
of (fetch INFOBLK of DATUM))
|
||||
(replace IOFIBWriteTime
|
||||
of (fetch INFOBLK of DATUM) with NEWVALUE])
|
||||
|
||||
(ACCESSFNS COREDEVICE ((COREDIRECTORY (FETCH DEVICEINFO OF DATUM)
|
||||
(REPLACE DEVICEINFO OF DATUM WITH NEWVALUE))))
|
||||
(REPLACE DEVICEINFO OF DATUM WITH NEWVALUE))))
|
||||
|
||||
(RECORD COREGENFILESTATE (COREFILELST))
|
||||
)
|
||||
@@ -954,16 +954,16 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
||||
(PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1993 1999 2018))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1755 43279 (\CORE.CLOSEFILE 1765 . 2538) (\CORE.DELETEFILE 2540 . 4526) (
|
||||
\CORE.DIRECTORYNAMEP 4528 . 4789) (\CORE.FINDPAGE 4791 . 8020) (\CORE.GENERATEFILES 8022 . 10609) (
|
||||
\CORE.NEXTFILEFN 10611 . 11110) (\CORE.FILEINFOFN 11112 . 11341) (\CORE.GETFILEHANDLE 11343 . 13497) (
|
||||
\CORE.GETFILEINFO 13499 . 14462) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14464 . 16001) (\CORE.GETFILENAME
|
||||
16003 . 18292) (\CORE.GETINFOBLOCK 18294 . 20917) (\CORE.NAMESCAN 20919 . 22686) (\CORE.NAMESEGMENT
|
||||
22688 . 23125) (\CORE.OPENFILE 23127 . 26246) (\COREFILE.SETPARAMETERS 26248 . 28429) (
|
||||
\CORE.PACKFILENAME 28431 . 28826) (\CORE.RELEASEPAGES 28828 . 29429) (\CORE.SETFILEPTR 29431 . 30530)
|
||||
(\CORE.UPDATEOF 30532 . 32161) (\CORE.BACKFILEPTR 32163 . 34371) (\CORE.SETEOFPTR 34373 . 36242) (
|
||||
\CORE.SETACCESSTIME 36244 . 36869) (\CORE.SETFILEINFO 36871 . 38062) (\CORE.GETNEXTBUFFER 38064 .
|
||||
42020) (\CORE.UNPACKFILENAME 42022 . 43277)) (43280 46913 (COREDEVICE 43290 . 43461) (
|
||||
\CREATECOREDEVICE 43463 . 46911)) (46914 49215 (\NODIRCOREFDEV 46924 . 47521) (\NODIRCORE.OPENFILE
|
||||
47523 . 49213)))))
|
||||
(FILEMAP (NIL (1710 44229 (\CORE.CLOSEFILE 1720 . 2493) (\CORE.DELETEFILE 2495 . 4481) (
|
||||
\CORE.DIRECTORYNAMEP 4483 . 4744) (\CORE.FINDPAGE 4746 . 7975) (\CORE.GENERATEFILES 7977 . 10564) (
|
||||
\CORE.NEXTFILEFN 10566 . 11065) (\CORE.FILEINFOFN 11067 . 11296) (\CORE.GETFILEHANDLE 11298 . 13452) (
|
||||
\CORE.GETFILEINFO 13454 . 14417) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14419 . 15956) (\CORE.GETFILENAME
|
||||
15958 . 18247) (\CORE.GETINFOBLOCK 18249 . 20872) (\CORE.NAMESCAN 20874 . 22641) (\CORE.NAMESEGMENT
|
||||
22643 . 23080) (\CORE.OPENFILE 23082 . 26201) (\COREFILE.SETPARAMETERS 26203 . 28384) (
|
||||
\CORE.PACKFILENAME 28386 . 28781) (\CORE.RELEASEPAGES 28783 . 29384) (\CORE.SETFILEPTR 29386 . 30485)
|
||||
(\CORE.UPDATEOF 30487 . 32116) (\CORE.BACKFILEPTR 32118 . 34326) (\CORE.SETEOFPTR 34328 . 36197) (
|
||||
\CORE.SETACCESSTIME 36199 . 36824) (\CORE.SETFILEINFO 36826 . 39012) (\CORE.GETNEXTBUFFER 39014 .
|
||||
42970) (\CORE.UNPACKFILENAME 42972 . 44227)) (44230 47863 (COREDEVICE 44240 . 44411) (
|
||||
\CREATECOREDEVICE 44413 . 47861)) (47864 50165 (\NODIRCOREFDEV 47874 . 48471) (\NODIRCORE.OPENFILE
|
||||
48473 . 50163)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,16 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 7-Nov-91 18:15:13" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>EDITINTERFACE.;6| 38377
|
||||
|
||||
changes to%: (FUNCTIONS ED)
|
||||
(FILECREATED " 8-Dec-2021 18:25:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;29 47473
|
||||
|
||||
previous date%: " 5-Feb-91 11:44:57" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>EDITINTERFACE.;5|)
|
||||
:CHANGES-TO (FNS EDITDATE? EDITDATE)
|
||||
|
||||
:PREVIOUS-DATE " 8-Dec-2021 16:11:23"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;27)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1986-1988, 1990-1991 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT EDITINTERFACECOMS)
|
||||
@@ -33,7 +36,7 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(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")
|
||||
|
||||
|
||||
@@ -43,8 +46,12 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(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)
|
||||
@@ -93,8 +100,8 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
)
|
||||
|
||||
|
||||
(RPAQQ DUMMY-EDIT-FUNCTION-BODY [LAMBDA (ARGS ...)
|
||||
BODY])
|
||||
(RPAQQ DUMMY-EDIT-FUNCTION-BODY [LAMBDA (ARGS |...|)
|
||||
BODY])
|
||||
|
||||
(CL:DEFVAR *ED-OFFERS-PROPERTY-LIST* T
|
||||
"Controls whether ED offers property list as an editable aspect")
|
||||
@@ -102,7 +109,7 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(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.")
|
||||
|
||||
@@ -124,8 +131,7 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(CL:MEMBER :DISPLAY CL::OPTIONS)
|
||||
(CL:MEMBER 'DISPLAY CL::OPTIONS)))
|
||||
(CL::GIVEN-TYPES (for X inside CL::OPTIONS when (NEQ X T) bind TYPE
|
||||
when (CL:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T CL::NAME))
|
||||
collect TYPE))
|
||||
when (CL:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T CL::NAME)) collect TYPE))
|
||||
[CL::TYPES-WITH-DEFNS (TYPESOF CL::NAME CL::GIVEN-TYPES NIL
|
||||
(CL:IF (OR (CL:MEMBER :CURRENT CL::OPTIONS)
|
||||
(CL:MEMBER 'CURRENT CL::OPTIONS))
|
||||
@@ -138,9 +144,9 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
([AND (NULL CL::GIVEN-TYPES)
|
||||
(CL:SYMBOLP CL::NAME)
|
||||
(NOT (NULL *ED-OFFERS-PROPERTY-LIST*))
|
||||
(find X on (GETPROPLIST CL::NAME)
|
||||
by (CDDR X) suchthat (NULL (GET (CAR X)
|
||||
'PROPTYPE]
|
||||
(find X on (GETPROPLIST CL::NAME) by (CDDR X)
|
||||
suchthat (NULL (GET (CAR X)
|
||||
'PROPTYPE]
|
||||
|
||||
(* ;; "if we're supposed to offer PROPERTY-LIST as an edit type, and this name has a property list with other than system properties on it, then add IL:PROPERTY-LIST to the possible types.")
|
||||
|
||||
@@ -150,60 +156,55 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(CL:WHEN (CL:MEMBER 'PROPERTY-LIST CL::OPTIONS)
|
||||
|
||||
(* ;;
|
||||
"this will allow PROPERTY-LIST to be specified as a fake filepkg type by the user (caller)")
|
||||
"this will allow PROPERTY-LIST to be specified as a fake filepkg type by the user (caller)")
|
||||
|
||||
(CL:SETQ CL::POSSIBLE-TYPES '(PROPERTY-LIST)))
|
||||
[CL:SETQ TYPE (if (CL:MEMBER :NEW CL::OPTIONS)
|
||||
then
|
||||
(* ;; "if :NEW then install a blank definition first")
|
||||
|
||||
(* ;; "if :NEW then install a blank definition first")
|
||||
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME (OR CL::TYPES-WITH-DEFNS
|
||||
CL::GIVEN-TYPES)
|
||||
:NEW)
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME (OR CL::TYPES-WITH-DEFNS
|
||||
CL::GIVEN-TYPES)
|
||||
:NEW)
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
elseif (CDR CL::POSSIBLE-TYPES)
|
||||
then
|
||||
(* ;; "Many types were found/given. Ask the user which to use.")
|
||||
|
||||
(* ;; "Many types were found/given. Ask the user which to use.")
|
||||
|
||||
(if CL::FROM-DISPLAY
|
||||
then (OR (MENU (create MENU
|
||||
ITEMS _ CL::POSSIBLE-TYPES
|
||||
TITLE _ (CL:FORMAT NIL
|
||||
(if CL::FROM-DISPLAY
|
||||
then (OR (MENU (create MENU
|
||||
ITEMS _ CL::POSSIBLE-TYPES
|
||||
TITLE _ (CL:FORMAT NIL
|
||||
"Edit which definition of ~S ?"
|
||||
CL::NAME)))
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES)
|
||||
(CL:FORMAT NIL "Edit which ~A definition of ~S ? "
|
||||
CL::POSSIBLE-TYPES CL::NAME)
|
||||
CL::POSSIBLE-TYPES))
|
||||
CL::NAME)))
|
||||
(CL:RETURN-FROM ED NIL))
|
||||
else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES)
|
||||
(CL:FORMAT NIL "Edit which ~A definition of ~S ? "
|
||||
CL::POSSIBLE-TYPES CL::NAME)
|
||||
CL::POSSIBLE-TYPES))
|
||||
elseif (NOT (NULL CL::POSSIBLE-TYPES))
|
||||
then
|
||||
(* ;; "Exactly one type was found.")
|
||||
|
||||
(* ;; "Exactly one type was found.")
|
||||
|
||||
(if CL::FROM-DISPLAY
|
||||
then (* ; "prepare the prompt window")
|
||||
(TERPRI PROMPTWINDOW))
|
||||
(CL:FORMAT (if CL::FROM-DISPLAY
|
||||
then PROMPTWINDOW
|
||||
else T)
|
||||
"Editing ~A ~A ~S.~%%"
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
(CL:IF (EQ (CAR CL::POSSIBLE-TYPES)
|
||||
'PROPERTY-LIST)
|
||||
"of"
|
||||
"definition of")
|
||||
CL::NAME)
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
(if CL::FROM-DISPLAY
|
||||
then (* ; "prepare the prompt window")
|
||||
(TERPRI PROMPTWINDOW))
|
||||
(CL:FORMAT (if CL::FROM-DISPLAY
|
||||
then PROMPTWINDOW
|
||||
else T)
|
||||
"Editing ~A ~A ~S.~%%"
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
(CL:IF (EQ (CAR CL::POSSIBLE-TYPES)
|
||||
'PROPERTY-LIST)
|
||||
"of"
|
||||
"definition of")
|
||||
CL::NAME)
|
||||
(CAR CL::POSSIBLE-TYPES)
|
||||
else
|
||||
(* ;; "No types were found. Use the DefDefiner prototyping machinery.")
|
||||
|
||||
(* ;;
|
||||
"No types were found. Use the DefDefiner prototyping machinery.")
|
||||
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME CL::GIVEN-TYPES)
|
||||
(CL:RETURN-FROM ED NIL]
|
||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME CL::GIVEN-TYPES)
|
||||
(CL:RETURN-FROM ED NIL]
|
||||
(CL:IF (EQ TYPE 'PROPERTY-LIST)
|
||||
(EDITE (GETPROPLIST CL::NAME)
|
||||
NIL CL::NAME 'PROPLST NIL CL::OPTIONS)
|
||||
@@ -232,17 +233,16 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
PROTOTYPE-TYPE)
|
||||
(IF (AND NEW-DEFN-FLG TYPES-WITH-PROTOTYPES)
|
||||
THEN (IF (CDR TYPES-WITH-PROTOTYPES)
|
||||
THEN (CL:FORMAT T "Installing new definition for ~S~%%" NAME)
|
||||
ELSE (CL:FORMAT T "Installing new ~S definition for ~S~%%" (CAR
|
||||
TYPES-WITH-PROTOTYPES
|
||||
)
|
||||
NAME))
|
||||
THEN (CL:FORMAT T "Installing new definition for ~S~%%" NAME)
|
||||
ELSE (CL:FORMAT T "Installing new ~S definition for ~S~%%" (CAR TYPES-WITH-PROTOTYPES
|
||||
)
|
||||
NAME))
|
||||
ELSEIF (NULL REQUESTED-TYPES)
|
||||
THEN (CL:FORMAT T "~S has no definitions.~%%" NAME)
|
||||
ELSEIF (NULL (CDR REQUESTED-TYPES))
|
||||
THEN (CL:FORMAT T "~S has no ~A definition.~%%" NAME (CAR REQUESTED-TYPES))
|
||||
ELSE (CL:FORMAT T "~S has no definition of any of these types:~%% ~A~%%" NAME
|
||||
REQUESTED-TYPES))
|
||||
ELSE (CL:FORMAT T "~S has no definition of any of these types:~%% ~A~%%" NAME REQUESTED-TYPES
|
||||
))
|
||||
[IF (NULL TYPES-WITH-PROTOTYPES)
|
||||
THEN (CL:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL)
|
||||
ELSEIF (NULL (CDR TYPES-WITH-PROTOTYPES))
|
||||
@@ -258,13 +258,10 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(APPEND
|
||||
[FOR TYPE IN TYPES-WITH-PROTOTYPES
|
||||
COLLECT `(,TYPE '(:TYPE ,TYPE)
|
||||
"Displays a menu of definers for this type."
|
||||
(SUBITEMS ,@(FOR DEFINER IN (
|
||||
XCL::PROTOTYPE-DEFINERS-FOR-TYPE
|
||||
TYPE)
|
||||
COLLECT `(,DEFINER '(:DEFINER ,TYPE
|
||||
,DEFINER)
|
||||
,DEFINER-HELP-STRING]
|
||||
"Displays a menu of definers for this type."
|
||||
(SUBITEMS ,@(FOR DEFINER IN (XCL::PROTOTYPE-DEFINERS-FOR-TYPE TYPE)
|
||||
COLLECT `(,DEFINER '(:DEFINER ,TYPE ,DEFINER)
|
||||
,DEFINER-HELP-STRING]
|
||||
(LIST '("Don't make a dummy defn" NIL]
|
||||
(RESULT (MENU MENU)))
|
||||
(CL:ECASE (CL:FIRST RESULT)
|
||||
@@ -281,7 +278,7 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
(LIST '("Don't make a dummy defn" NIL]
|
||||
(IF DEFINER
|
||||
THEN (MAKE-AND-INSTALL PROTOTYPE-TYPE DEFINER)
|
||||
PROTOTYPE-TYPE
|
||||
PROTOTYPE-TYPE
|
||||
ELSE NIL])
|
||||
(DEFINEQ
|
||||
|
||||
@@ -630,61 +627,235 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
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])
|
||||
@@ -727,11 +898,23 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
|
||||
(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)
|
||||
@@ -745,10 +928,11 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
||||
)
|
||||
(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (14507 31290 (EDITDEF.FNS 14517 . 15853) (EDITF 15855 . 16735) (EDITFB 16737 . 17585) (
|
||||
EDITFNS 17587 . 18907) (EDITLOADFNS? 18909 . 22709) (EDITMODE 22711 . 24721) (EDITP 24723 . 25234) (
|
||||
EDITV 25236 . 25875) (DC 25877 . 26558) (DF 26560 . 27602) (DP 27604 . 28688) (DV 28690 . 29262) (
|
||||
EDITPROP 29264 . 29483) (EF 29485 . 29814) (EP 29816 . 29999) (EV 30001 . 30180) (EDITE 30182 . 31060)
|
||||
(EDITL 31062 . 31288)) (31640 37712 (NEW/EDITDATE 31650 . 31872) (FIXEDITDATE 31874 . 33716) (
|
||||
EDITDATE? 33718 . 34896) (EDITDATE 34898 . 35715) (SETINITIALS 35717 . 37710)))))
|
||||
(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.
255
sources/FASLOAD
255
sources/FASLOAD
@@ -1,11 +1,12 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL")
|
||||
(IL:FILECREATED "10-Jun-2021 18:26:43"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;8| 35584
|
||||
(DEFINE-FILE-INFO PACKAGE "FASL" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS READ-TEXT)
|
||||
(IL:FILECREATED "23-Nov-2021 12:29:28"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FASLOAD.;5| 34723
|
||||
|
||||
IL:|previous| IL:|date:| "17-Apr-2018 07:55:20"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
IL:|changes| IL:|to:| (IL:FNS CONVERT-FASL-DATE)
|
||||
|
||||
IL:|previous| IL:|date:| "23-Nov-2021 09:44:12"
|
||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FASLOAD.;2|)
|
||||
|
||||
|
||||
; Copyright (c) 1986-1992, 2018, 2021 by Venue & Xerox Corporation.
|
||||
@@ -14,14 +15,14 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(IL:RPAQQ IL:FASLOADCOMS
|
||||
(
|
||||
(IL:* IL:|;;| "FASL file loader.")
|
||||
(IL:* IL:|;;| "FASL file loader.")
|
||||
|
||||
|
||||
(IL:* IL:|;;| "THIS FILE IS DUPLICATED as ...<Lispcore>Sources> for the large-symbol version, and <Lispcore>Sources>2-byte> for the older 2-byte atom version. IF YOU CHANGE THIS COPY, CHANGE THE OTHER, AS WELL!")
|
||||
(IL:* IL:|;;| "THIS FILE IS DUPLICATED as ...<Lispcore>Sources> for the large-symbol version, and <Lispcore>Sources>2-byte> for the older 2-byte atom version. IF YOU CHANGE THIS COPY, CHANGE THE OTHER, AS WELL!")
|
||||
|
||||
(IL:COMS
|
||||
|
||||
(IL:* IL:|;;| "Common definitions.")
|
||||
(IL:* IL:|;;| "Common definitions.")
|
||||
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILES (NIL IL:SOURCE)
|
||||
IL:FASL-SUPPORT))
|
||||
@@ -33,26 +34,26 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(IL:FUNCTIONS TABLE-STATS))
|
||||
(IL:COMS
|
||||
|
||||
(IL:* IL:|;;| "Reader.")
|
||||
(IL:* IL:|;;| "Reader.")
|
||||
|
||||
(IL:COMS (IL:* IL:\; "Setting up the table")
|
||||
(IL:COMS (IL:* IL:\; "Setting up the table")
|
||||
(IL:STRUCTURES OPTABLE)
|
||||
(IL:FUNCTIONS MAKE-OPTABLE DEFINE-OPCODE-RANGE DEFINE-SINGLE-OPCODE
|
||||
ADD-OP-TRANSLATION OPCODE-SEQUENCE)
|
||||
(IL:* IL:\; "Opcode definers")
|
||||
(IL:* IL:\; "Opcode definers")
|
||||
(IL:FUNCTIONS DEFOP DEFRANGE))
|
||||
(IL:FUNCTIONS FASL-END-OF-BLOCK FASL-EXTENDED SETESCAPE UNIMPLEMENTED-OPCODE)
|
||||
(IL:VARIABLES *DEFAULT-OPTABLE* *CURRENT-OPTABLE* INITIAL-VALUE-TABLE-SIZE
|
||||
VALUE-TABLE-INCREMENT *VALUE-TABLE* *BLOCK-LEVEL* DEBUG-READER DEBUG-STREAM)
|
||||
|
||||
(IL:* IL:|;;| "The main reader functions:")
|
||||
(IL:* IL:|;;| "The main reader functions:")
|
||||
|
||||
(IL:FUNCTIONS PROCESS-FILE PROCESS-SEGMENT)
|
||||
(IL:FUNCTIONS WITH-OPTABLE CHECK-VERSION READ-TEXT PROCESS-BLOCK SKIP-TEXT
|
||||
NEXT-VALUE DO-OP NEW-VALUE-TABLE CLEAR-TABLE STORE-VALUE FETCH-VALUE
|
||||
COLLECT-LIST)
|
||||
|
||||
(IL:* IL:|;;| "FASL Opcode processors:")
|
||||
(IL:* IL:|;;| "FASL Opcode processors:")
|
||||
|
||||
(FASL-OPS FASL-SHORT-INTEGER FASL-NIL FASL-T FASL-INTEGER FASL-LARGE-INTEGER
|
||||
FASL-RATIO FASL-COMPLEX FASL-VECTOR FASL-CREATE-ARRAY FASL-INITIALIZE-ARRAY
|
||||
@@ -64,18 +65,18 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
FASL-FUNCALL FASL-BITMAP16 FASL-STRUCTURE))
|
||||
(XCL:OPTIMIZERS FIXUP-NTOFFSET)
|
||||
|
||||
(IL:* IL:|;;| "make sure there's some print function around so that you can load early.")
|
||||
(IL:* IL:|;;| "make sure there's some print function around so that you can load early.")
|
||||
|
||||
(IL:P (IL:MOVD? 'IL:PRIN1 'PRINC)
|
||||
(IL:MOVD? 'IL:TERPRI 'TERPRI))
|
||||
(IL:COMS
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files.")
|
||||
(IL:* IL:|;;|
|
||||
"ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files.")
|
||||
|
||||
(IL:FNS IL:FASL-FILEDATE CONVERT-FASL-DATE))
|
||||
|
||||
(IL:* IL:|;;| "Arrange for the correct compiler and makefile environment")
|
||||
(IL:* IL:|;;| "Arrange for the correct compiler and makefile environment")
|
||||
|
||||
(IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
|
||||
IL:FASLOAD)))
|
||||
@@ -143,7 +144,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
"End-of-data marker: if first byte of a segment, terminate processing")
|
||||
|
||||
(DEFCONSTANT VERSION-RANGE '(8 . 8)
|
||||
"Handles (car version-range) <= version <= (cdr version-range)")
|
||||
"Handles (car version-range) <= version <= (cdr version-range)")
|
||||
|
||||
(DEFCONSTANT CURRENT-VERSION 8)
|
||||
|
||||
@@ -183,13 +184,13 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFUN DEFINE-OPCODE-RANGE (NAME FIRST-OPCODE RANGE OFFSET TABLE)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"For implementation of DEFRANGE definer--define a range of opcodes having the same implementation.")
|
||||
(IL:* IL:|;;|
|
||||
"For implementation of DEFRANGE definer--define a range of opcodes having the same implementation.")
|
||||
|
||||
(LET ((PACKAGE (SYMBOL-PACKAGE NAME))
|
||||
(PNAME (SYMBOL-NAME NAME)))
|
||||
(DOTIMES (I RANGE) (IL:* IL:\;
|
||||
"Using IL:CONCAT here to minimize bootstrap woes")
|
||||
(DOTIMES (I RANGE) (IL:* IL:\;
|
||||
"Using IL:CONCAT here to minimize bootstrap woes")
|
||||
(DEFINE-SINGLE-OPCODE NAME (+ I FIRST-OPCODE)
|
||||
TABLE
|
||||
(INTERN (IL:CONCAT PNAME (+ I OFFSET))
|
||||
@@ -197,7 +198,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFUN DEFINE-SINGLE-OPCODE (NAME OPCODE TABLE TRANS-NAME)
|
||||
|
||||
(IL:* IL:|;;| "For implementation of DEFOP definer -- define NAME to be a fasl op numbered OPCODE in TABLE. NAME is the name of both the opcode as a FASL::FASL-OPS and the function implementing the opcode. TRANS-NAME is a name to associate with the opcode in the OPNAMES slot of the table (it is a generated name when we are called from DEFRANGE).")
|
||||
(IL:* IL:|;;| "For implementation of DEFOP definer -- define NAME to be a fasl op numbered OPCODE in TABLE. NAME is the name of both the opcode as a FASL::FASL-OPS and the function implementing the opcode. TRANS-NAME is a name to associate with the opcode in the OPNAMES slot of the table (it is a generated name when we are called from DEFRANGE).")
|
||||
|
||||
(SETF (ELT (OPTABLE-VECTOR TABLE)
|
||||
OPCODE)
|
||||
@@ -213,7 +214,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(OPTABLE-OPNAMES TABLE)))))
|
||||
|
||||
(DEFUN OPCODE-SEQUENCE (OPNAME &OPTIONAL (TABLE *DEFAULT-OPTABLE*)
|
||||
&AUX ENTRY)
|
||||
&AUX ENTRY)
|
||||
(COND
|
||||
((NULL TABLE)
|
||||
NIL)
|
||||
@@ -229,8 +230,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
|
||||
(XCL:DEFDEFINER DEFOP FASL-OPS (IL:NAME (OPCODE &KEY (INDIRECT 0)
|
||||
(TABLE '*DEFAULT-OPTABLE*))
|
||||
&BODY BODY)
|
||||
(TABLE '*DEFAULT-OPTABLE*))
|
||||
&BODY BODY)
|
||||
(IF (ZEROP INDIRECT)
|
||||
`(PROGN (DEFUN ,IL:NAME (STREAM OPCODE)
|
||||
,@BODY)
|
||||
@@ -245,8 +246,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
,@BODY))))
|
||||
|
||||
(XCL:DEFDEFINER DEFRANGE FASL-OPS (IL:NAME (FIRST-OPCODE &KEY (INDIRECT 0)
|
||||
(TABLE '*DEFAULT-OPTABLE*))
|
||||
RANGE OFFSET &BODY BODY)
|
||||
(TABLE '*DEFAULT-OPTABLE*))
|
||||
RANGE OFFSET &BODY BODY)
|
||||
(IF (ZEROP INDIRECT)
|
||||
`(PROGN (DEFUN ,IL:NAME (STREAM OPCODE)
|
||||
,@BODY)
|
||||
@@ -298,11 +299,11 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
|
||||
(DEFUN PROCESS-FILE (STREAM &KEY (TEXT-FN (AND *LOAD-VERBOSE* #'(LAMBDA (TEXT)
|
||||
(PRINC TEXT)
|
||||
(TERPRI))))
|
||||
(ITEM-FN NIL))
|
||||
(PRINC TEXT)
|
||||
(TERPRI))))
|
||||
(ITEM-FN NIL))
|
||||
|
||||
(IL:* IL:|;;;| "Calls FASL:PROCESS-SEGMENT with the approriate arguments for each segment in the file. The stream should be positioned at the beginning.")
|
||||
(IL:* IL:|;;;| "Calls FASL:PROCESS-SEGMENT with the approriate arguments for each segment in the file. The stream should be positioned at the beginning.")
|
||||
|
||||
(UNLESS (EQL (IL:BIN STREAM)
|
||||
SIGNATURE)
|
||||
@@ -310,8 +311,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(LET ((IL:FILEPKGFLG NIL)
|
||||
(IL:DFNFLG T)
|
||||
(IL:LISPXHIST NIL)
|
||||
(IL:ADDSPELLFLG NIL)) (IL:* IL:\;
|
||||
"Bind these so that LOADing a FASL file is like LOADing SYSLOAD.")
|
||||
(IL:ADDSPELLFLG NIL)) (IL:* IL:\;
|
||||
"Bind these so that LOADing a FASL file is like LOADing SYSLOAD.")
|
||||
(DECLARE (SPECIAL IL:FILEPKGFLG IL:DFNFLG IL:LISPXHIST IL:ADDSPELLFLG))
|
||||
(IF (< (CHECK-VERSION STREAM)
|
||||
5)
|
||||
@@ -346,9 +347,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFUN READ-TEXT (STREAM)
|
||||
|
||||
(IL:* IL:|;;| "RMK: This really should be doing READCCODE to read the bytes, but that fails because this string is not delimited by quotes, rather it has 255 as the end marker. 255 is the XCCS characterset shift, will presumably do something else in Unicode.")
|
||||
(IL:* IL:|;;| "RMK: This really should be doing READCCODE to read the bytes, but that fails because this string is not delimited by quotes, rather it has 255 as the end marker. 255 is the XCCS characterset shift, will presumably do something else in Unicode.")
|
||||
|
||||
(IL:* IL:|;;| "Any reason not to print the string as a string?")
|
||||
(IL:* IL:|;;| "Any reason not to print the string as a string?")
|
||||
|
||||
(DO ((RESULT (MAKE-ARRAY 512 :ELEMENT-TYPE 'CHARACTER :ADJUSTABLE T :FILL-POINTER 0))
|
||||
(BYTE (IL:BIN STREAM)
|
||||
@@ -362,10 +363,10 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT*
|
||||
(CATCH 'FASL-BLOCK-FINISHED
|
||||
(WITH-OPTABLE OPTABLE (DO ((*VALUE-TABLE* (NEW-VALUE-TABLE))
|
||||
VAL)
|
||||
()
|
||||
(SETF VAL (DO-OP STREAM 0))
|
||||
(WHEN ITEM-FN (FUNCALL ITEM-FN VAL)))))))
|
||||
VAL)
|
||||
()
|
||||
(SETF VAL (DO-OP STREAM 0))
|
||||
(WHEN ITEM-FN (FUNCALL ITEM-FN VAL)))))))
|
||||
|
||||
(DEFUN SKIP-TEXT (STREAM)
|
||||
(DO ((BYTE (IL:BIN STREAM)
|
||||
@@ -400,8 +401,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFUN STORE-VALUE (OBJ &OPTIONAL (TABLE *VALUE-TABLE*))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"This may want to change to another representation if we can't make VECTOR-PUSH-EXTEND fast enough.")
|
||||
(IL:* IL:|;;|
|
||||
"This may want to change to another representation if we can't make VECTOR-PUSH-EXTEND fast enough.")
|
||||
|
||||
(VECTOR-PUSH-EXTEND OBJ TABLE VALUE-TABLE-INCREMENT)
|
||||
OBJ)
|
||||
@@ -416,7 +417,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(WHEN DOTTED (DECF NELTS))
|
||||
(LET ((RESULT (IL:|to| NELTS IL:|collect| (DO-OP STREAM))))
|
||||
|
||||
(IL:* IL:|;;| "Assume dotted and other than a simple cons is rare.")
|
||||
(IL:* IL:|;;| "Assume dotted and other than a simple cons is rare.")
|
||||
|
||||
(WHEN DOTTED
|
||||
(SETF (CDR (LAST RESULT))
|
||||
@@ -518,17 +519,17 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFOP FASL-FAT-STRING (141)
|
||||
|
||||
(IL:* IL:|;;| "Read a string of specified length that has been encoded in standard NS format.")
|
||||
(IL:* IL:|;;| "Read a string of specified length that has been encoded in standard NS format.")
|
||||
|
||||
(LET* ((NCHARS (NEXT-VALUE))
|
||||
(STRING (IL:ALLOCSTRING NCHARS)))
|
||||
(IL:ACCESS-CHARSET STREAM 0) (IL:* IL:\;
|
||||
"Make sure we're in charset zero")
|
||||
(IL:ACCESS-CHARSET STREAM 0) (IL:* IL:\;
|
||||
"Make sure we're in charset zero")
|
||||
(UNWIND-PROTECT
|
||||
(DOTIMES (I NCHARS STRING)
|
||||
(SETF (SVREF STRING I)
|
||||
(CODE-CHAR (IL:READCCODE STREAM)))) (IL:* IL:\;
|
||||
"Restore charset zero, in case anyone cares")
|
||||
(CODE-CHAR (IL:READCCODE STREAM)))) (IL:* IL:\;
|
||||
"Restore charset zero, in case anyone cares")
|
||||
(IL:ACCESS-CHARSET STREAM 0))))
|
||||
|
||||
(DEFOP FASL-CHARACTER (142)
|
||||
@@ -571,7 +572,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFOP FASL-DCODE (150)
|
||||
|
||||
(IL:* IL:|;;;| "DIRE WARNING!!! Be sure you have your pointy hat with lots of stars on if you're going to muck around with this code. Due to unfortunately unavoidable performance requirements, this code duplicates D-ASSEM:INTERN-DCODE. If you make a change here, you should probably change the corresponding code there.")
|
||||
(IL:* IL:|;;;| "DIRE WARNING!!! Be sure you have your pointy hat with lots of stars on if you're going to muck around with this code. Due to unfortunately unavoidable performance requirements, this code duplicates D-ASSEM:INTERN-DCODE. If you make a change here, you should probably change the corresponding code there.")
|
||||
|
||||
(LET ((OVERHEADBYTES (* (IL:FETCH (IL:FNHEADER IL:OVERHEADWORDS) IL:OF T)
|
||||
IL:BYTESPERWORD))
|
||||
@@ -583,24 +584,21 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(IL:\\BINS STREAM RAW-CODE START-PC CODE-LEN)
|
||||
(IL:REPLACE (IL:FNHEADER IL:STARTPC) IL:OF RAW-CODE IL:WITH START-PC))
|
||||
|
||||
(IL:* IL:|;;| "Set up the free variable lookup name table.")
|
||||
(IL:* IL:|;;| "Set up the free variable lookup name table.")
|
||||
|
||||
(DO* ((I 0 (1+ I))
|
||||
(INDEX OVERHEADBYTES (+ INDEX (IL:CONSTANT (IL:BYTESPERNAMEENTRY))))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"NTSIZE and NTBYTESIZE the sizes of half the table in words and bytes resp.")
|
||||
(IL:* IL:|;;|
|
||||
"NTSIZE and NTBYTESIZE the sizes of half the table in words and bytes resp.")
|
||||
|
||||
(NTSIZE (IL:CEIL (1+ (IL:UNFOLD NT-COUNT (IL:CONSTANT (IL:WORDSPERNAMEENTRY))))
|
||||
IL:WORDSPERQUAD))
|
||||
(NTBYTESIZE (* NTSIZE IL:BYTESPERWORD))
|
||||
PFI OFFSET NAME FVAROFFSET)
|
||||
((>= I NT-COUNT)
|
||||
(IL:REPLACE (IL:FNHEADER IL:FVAROFFSET) IL:OF RAW-CODE IL:WITH (OR
|
||||
FVAROFFSET
|
||||
0))
|
||||
(IL:REPLACE (IL:FNHEADER IL:NTSIZE) IL:OF RAW-CODE IL:WITH
|
||||
(IF (ZEROP NT-COUNT)
|
||||
(IL:REPLACE (IL:FNHEADER IL:FVAROFFSET) IL:OF RAW-CODE IL:WITH (OR FVAROFFSET 0))
|
||||
(IL:REPLACE (IL:FNHEADER IL:NTSIZE) IL:OF RAW-CODE IL:WITH (IF (ZEROP NT-COUNT)
|
||||
0
|
||||
NTSIZE)))
|
||||
(SETF PFI (IL:BIN STREAM))
|
||||
@@ -614,32 +612,30 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(= PFI D-ASSEM:+FVAR-CODE+))
|
||||
(SETF FVAROFFSET (FLOOR INDEX IL:BYTESPERWORD))))
|
||||
|
||||
(IL:* IL:|;;| "Fill in the fixed-size fields at the front of the block.")
|
||||
(IL:* IL:|;;| "Fill in the fixed-size fields at the front of the block.")
|
||||
|
||||
(LET ((FRAME-NAME (NEXT-VALUE)))
|
||||
(IL:UNINTERRUPTABLY
|
||||
(IL:\\ADDREF FRAME-NAME)
|
||||
(IL:REPLACE (IL:FNHEADER IL:\#FRAMENAME) IL:OF RAW-CODE IL:WITH
|
||||
FRAME-NAME)))
|
||||
(IL:REPLACE (IL:FNHEADER IL:\#FRAMENAME) IL:OF RAW-CODE IL:WITH FRAME-NAME)))
|
||||
(LET ((NLOCALS (IL:BIN STREAM))
|
||||
(NFREEVARS (IL:BIN STREAM)))
|
||||
(IL:REPLACE (IL:FNHEADER IL:NLOCALS) IL:OF RAW-CODE IL:WITH NLOCALS)
|
||||
(IL:REPLACE (IL:FNHEADER IL:PV) IL:OF RAW-CODE
|
||||
IL:WITH (1- (CEILING (+ NLOCALS NFREEVARS)
|
||||
IL:CELLSPERQUAD))))
|
||||
(IL:REPLACE (IL:FNHEADER IL:PV) IL:OF RAW-CODE IL:WITH (1- (CEILING (+ NLOCALS NFREEVARS
|
||||
)
|
||||
IL:CELLSPERQUAD))))
|
||||
(IL:REPLACE (IL:FNHEADER IL:ARGTYPE) IL:OF RAW-CODE IL:WITH (IL:BIN STREAM))
|
||||
(IL:REPLACE (IL:FNHEADER IL:NA) IL:OF RAW-CODE IL:WITH (NEXT-VALUE))
|
||||
(SETF CLOSURE-INFO (NEXT-VALUE))
|
||||
(IL:REPLACE (IL:FNHEADER IL:CLOSUREP) IL:OF RAW-CODE IL:WITH (EQ CLOSURE-INFO
|
||||
:CLOSURE))
|
||||
(IL:REPLACE (IL:FNHEADER IL:CLOSUREP) IL:OF RAW-CODE IL:WITH (EQ CLOSURE-INFO :CLOSURE))
|
||||
(IL:REPLACE (IL:FNHEADER IL:FIXED) IL:OF RAW-CODE IL:WITH T)
|
||||
|
||||
(IL:* IL:|;;| "Fill in debugging info. It goes into the spare cell just before the code: it's -3 instead of -bytespercell to right-justify the pointer in the cell. Aren't you glad I told you this?")
|
||||
(IL:* IL:|;;| "Fill in debugging info. It goes into the spare cell just before the code: it's -3 instead of -bytespercell to right-justify the pointer in the cell. Aren't you glad I told you this?")
|
||||
|
||||
(D-ASSEM:FIXUP-PTR RAW-CODE (- START-PC (IL:BIG-VMEM-CODE 4 3))
|
||||
(NEXT-VALUE))
|
||||
|
||||
(IL:* IL:|;;| "Do fixups")
|
||||
(IL:* IL:|;;| "Do fixups")
|
||||
|
||||
(DO ((FN-FIXUP-COUNT (NEXT-VALUE))
|
||||
(I 0 (1+ I))
|
||||
@@ -674,15 +670,15 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(D-ASSEM:FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
|
||||
(IL:\\RESOLVE.TYPENUMBER VALUE)))
|
||||
|
||||
(IL:* IL:|;;| "Finally, wrap this up in a closure-object if requested.")
|
||||
(IL:* IL:|;;| "Finally, wrap this up in a closure-object if requested.")
|
||||
|
||||
(IF (EQ CLOSURE-INFO :FUNCTION)
|
||||
(IL:MAKE-COMPILED-CLOSURE RAW-CODE NIL)
|
||||
RAW-CODE)))
|
||||
|
||||
(DEFOP FASL-LOCAL-FN-FIXUPS (151)
|
||||
(LET ((PASS-THROUGH (NEXT-VALUE))) (IL:* IL:\;
|
||||
"This will typically correspond to the DCODE that had the fixups, but can be anything.")
|
||||
(LET ((PASS-THROUGH (NEXT-VALUE))) (IL:* IL:\;
|
||||
"This will typically correspond to the DCODE that had the fixups, but can be anything.")
|
||||
(DO ((FIXUP-COUNT (NEXT-VALUE))
|
||||
(I 0 (IL:ADD1 I))
|
||||
CODE-TO-FIX OFFSET VALUE)
|
||||
@@ -701,8 +697,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
,THING))))
|
||||
(IF (EQ CODE-TO-FIX VALUE)
|
||||
(LET ((CODE (GET-CODE CODE-TO-FIX)))
|
||||
(D-ASSEM:FIXUP-PTR-NO-REF CODE (IL:IPLUS (IL:FETCH (IL:FNHEADER
|
||||
IL:STARTPC)
|
||||
(D-ASSEM:FIXUP-PTR-NO-REF CODE (IL:IPLUS (IL:FETCH (IL:FNHEADER IL:STARTPC)
|
||||
IL:OF CODE)
|
||||
OFFSET)
|
||||
VALUE))
|
||||
@@ -740,7 +735,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFOP FASL-BITMAP16 (158)
|
||||
|
||||
(IL:* IL:|;;;| "Load an Interlisp BITMAP.")
|
||||
(IL:* IL:|;;;| "Load an Interlisp BITMAP.")
|
||||
|
||||
(LET* ((WIDTH (NEXT-VALUE))
|
||||
(HEIGHT (NEXT-VALUE))
|
||||
@@ -753,32 +748,29 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
(DEFOP FASL-STRUCTURE (159)
|
||||
|
||||
(IL:* IL:|;;;| "Load a DEFSTRUCT-defined structure instance.")
|
||||
(IL:* IL:|;;;| "Load a DEFSTRUCT-defined structure instance.")
|
||||
|
||||
(IL:CREATE-STRUCTURE (CONS (NEXT-VALUE)
|
||||
(NEXT-VALUE))))
|
||||
|
||||
(XCL:DEFOPTIMIZER FIXUP-NTOFFSET (RAW-CODE OFFSET TYPE VALUE &ENVIRONMENT IL:ENV)
|
||||
|
||||
(IL:* IL:|;;| "Do the fixups for a name-table offset entry, given a code block, the NTOffset's offset within the codeblock, and the variable type and FVAR offset.")
|
||||
(IL:* IL:|;;| "Do the fixups for a name-table offset entry, given a code block, the NTOffset's offset within the codeblock, and the variable type and FVAR offset.")
|
||||
|
||||
(COND
|
||||
((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE IL:ENV)
|
||||
)
|
||||
(COND
|
||||
((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE IL:ENV))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"3-byte case; the nametable entry is a full cell.")
|
||||
(IL:* IL:|;;| "3-byte case; the nametable entry is a full cell.")
|
||||
|
||||
`(PROGN (D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET ,TYPE)
|
||||
(D-ASSEM:FIXUP-WORD ,RAW-CODE (+ ,OFFSET
|
||||
IL:BYTESPERWORD)
|
||||
,VALUE)))
|
||||
(T
|
||||
(IL:* IL:|;;| "Old nametable case, it's just a word.")
|
||||
`(PROGN (D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET ,TYPE)
|
||||
(D-ASSEM:FIXUP-WORD ,RAW-CODE (+ ,OFFSET IL:BYTESPERWORD
|
||||
)
|
||||
,VALUE)))
|
||||
(T
|
||||
(IL:* IL:|;;| "Old nametable case, it's just a word.")
|
||||
|
||||
`(D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET (IL:IPLUS
|
||||
,TYPE
|
||||
,VALUE)))))
|
||||
`(D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET (IL:IPLUS ,TYPE
|
||||
,VALUE)))))
|
||||
|
||||
|
||||
|
||||
@@ -791,18 +783,20 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files."
|
||||
)
|
||||
(IL:* IL:|;;| "ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files.")
|
||||
|
||||
(IL:DEFINEQ
|
||||
|
||||
(IL:FASL-FILEDATE
|
||||
(IL:LAMBDA (STREAM IL:CFLG) (IL:* IL:\; "Edited 17-Feb-89 11:25 by jds")
|
||||
(IL:LAMBDA (STREAM IL:CFLG) (IL:* IL:\;
|
||||
"Edited 23-Nov-2021 08:26 by rmk:")
|
||||
(IL:* IL:\;
|
||||
"CFLG IS T FOR COMPILED FILES")
|
||||
"Edited 17-Feb-89 11:25 by jds")
|
||||
(IL:* IL:\;
|
||||
"CFLG IS T FOR COMPILED FILES")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"If STREAM is open on a FASL file, returns the FILEDATE for that file. Otherwise, returns NIL.")
|
||||
"If STREAM is open on a FASL file, returns the FILEDATE for that file. Otherwise, returns NIL.")
|
||||
|
||||
(IL:* IL:|;;| "Used in FILEDATE; kept a separate function because FILEDATE is defined before the FASL package is loaded.")
|
||||
|
||||
@@ -810,36 +804,39 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
((EQL (IL:BIN STREAM)
|
||||
SIGNATURE) (IL:* IL:\; " \"Aha, a Dfasl file\"")
|
||||
(IL:SETFILEPTR STREAM 0)
|
||||
(IL:SETQ IL:VALUE (CONVERT-FASL-DATE (PROCESS-FILE STREAM :TEXT-FN
|
||||
#'(IL:LAMBDA (IL:X)
|
||||
(IL:RETFROM 'PROCESS-FILE IL:X))
|
||||
:ITEM-FN
|
||||
'IL:NILL)
|
||||
IL:CFLG))))))
|
||||
(CONVERT-FASL-DATE (PROCESS-FILE STREAM :TEXT-FN #'(IL:LAMBDA (IL:X)
|
||||
(IL:RETFROM 'PROCESS-FILE IL:X))
|
||||
:ITEM-FN
|
||||
'IL:NILL)
|
||||
IL:CFLG)))))
|
||||
|
||||
(CONVERT-FASL-DATE
|
||||
(IL:LAMBDA (IL:DATESTRING IL:CFLG) (IL:* IL:\; "Edited 17-Apr-2018 07:55 by rmk:")
|
||||
(IL:* IL:\;
|
||||
"Edited 23-Jan-89 13:55 by gadener")
|
||||
(IL:LAMBDA (IL:DATESTRING IL:CFLG) (IL:* IL:\; "Edited 23-Nov-2021 12:29 by rmk:")
|
||||
(IL:* IL:\; "Edited 17-Apr-2018 07:55 by rmk:")
|
||||
(IL:* IL:\; "Edited 23-Jan-89 13:55 by gadener")
|
||||
|
||||
(IL:* IL:|;;| "CONVERT-FASL-DATE takes the file text info from a DFASL file describing creation dates for source and compiled code and returns either one of these dates, depending on the value of CLFG, in da-mon-yr hr:mn:sc format.")
|
||||
(IL:* IL:|;;| "CONVERT-FASL-DATE takes the file text info from a DFASL file describing creation dates for source and compiled code and returns either one of these dates, depending on the value of CLFG, in da-mon-yr hr:mn:sc format.")
|
||||
|
||||
(IL:* IL:|;;| "")
|
||||
(IL:* IL:|;;| "")
|
||||
|
||||
(IL:* IL:|;;| "RMK: The SHORT-DATE-STRING has all of the information in the right order, most likely with 4-digit years too. But it seems to have spaces between the day and month and month and year, whereas (DATE) with the default format produces strings with hyphens. It also has comma-space after the year while (DATE) has just space. The month is also spelled out (April instead of Apr). But those differences don't seem to matter to IDATE, which is where comparisons should be done. I commented out all the junky code.")
|
||||
(IL:* IL:|;;| "RMK: 23-Nov-2021. Some DFASL files have a different date format, without the day before a comma and without a period at the end of the lines. It seems that the easiest thing is just to isolate the full date strings, stripping off the period at the end and then canonicalize the return date with (GDATE (IDATE )). IDATE in particular seems to recognize all the formats.")
|
||||
|
||||
(LET* ((IL:DATE-POS (IF IL:CFLG
|
||||
(IL:STRPOS "Source file created" IL:DATESTRING)
|
||||
(IL:STRPOS "FASL file created" IL:DATESTRING)))
|
||||
(IL:BEGIN-POS (IL:STRPOS "," IL:DATESTRING IL:DATE-POS))
|
||||
(IL:END-POS (IL:STRPOS "." IL:DATESTRING IL:DATE-POS))
|
||||
(IL:SHORT-DATE-STRING (IL:SUBSTRING IL:DATESTRING (+ IL:BEGIN-POS 2)
|
||||
(IL:SUB1 IL:END-POS)))
|
||||
IL:TEMP-DATE IL:DATE-RESULT)
|
||||
(IL:* IL:|;;| "")
|
||||
|
||||
(IL:* IL:|;;| "(SETQ TEMP-DATE (CONCAT (GNC SHORT-DATE-STRING) (GNC SHORT-DATE-STRING))) (if (EQUAL \" \" (SUBSTRING TEMP-DATE 2)) then (SETQ TEMP-DATE (CONCAT \" \" (GNC TEMP-DATE))) else (GNC SHORT-DATE-STRING)) (SETQ DATE-RESULT (CONCAT TEMP-DATE \"-\" (GNC SHORT-DATE-STRING) (GNC SHORT-DATE-STRING) (GNC SHORT-DATE-STRING) \"-\")) (SETQ TEMP-DATE (SUBSTRING SHORT-DATE-STRING (PLUS 3 (STRPOS \" \" SHORT-DATE-STRING)))) (SETQ DATE-RESULT (CONCAT DATE-RESULT (GNC TEMP-DATE) (GNC TEMP-DATE) \" \")) (GNC TEMP-DATE) (GNC TEMP-DATE) (if (LESSP (STRPOS \":\" TEMP-DATE) 3) then (CONCAT DATE-RESULT \"0\" TEMP-DATE) else (CONCAT DATE-RESULT TEMP-DATE))")
|
||||
(IL:* IL:\; "")
|
||||
IL:SHORT-DATE-STRING)))
|
||||
(IL:* IL:|;;|
|
||||
"END-POS is the end of the line that contains the key substring, last char could be period")
|
||||
|
||||
(LET* ((IL:DATE-SUFFIX (IL:SUBSTRING IL:DATESTRING (IL:STRPOS (IF IL:CFLG
|
||||
"FASL file created "
|
||||
"Source file created ")
|
||||
IL:DATESTRING 1 NIL NIL T)))
|
||||
(IL:END-POS (OR (IL:STRPOS (IL:CHARACTER (IL:CHARCODE EOL))
|
||||
IL:DATE-SUFFIX)
|
||||
(IL:SUB1 (IL:NCHARS IL:DATE-SUFFIX)))))
|
||||
(IL:GDATE (IL:IDATE (IL:SUBSTRING IL:DATE-SUFFIX 1 (IF (EQ (IL:CHARCODE \.)
|
||||
(IL:NTHCHARCODE IL:END-POS -1))
|
||||
(IL:SUB1 IL:END-POS 1)
|
||||
IL:END-POS)))))))
|
||||
)
|
||||
|
||||
|
||||
@@ -853,15 +850,15 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
||||
(IL:PUTPROPS IL:FASLOAD IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992
|
||||
2018 2021))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (6461 6877 (TABLE-STATS 6461 . 6877)) (7039 7318 (MAKE-OPTABLE 7039 . 7318)) (7320
|
||||
7963 (DEFINE-OPCODE-RANGE 7320 . 7963)) (7965 8515 (DEFINE-SINGLE-OPCODE 7965 . 8515)) (8517 8775 (
|
||||
ADD-OP-TRANSLATION 8517 . 8775)) (8777 9141 (OPCODE-SEQUENCE 8777 . 9141)) (10735 10901 (
|
||||
FASL-END-OF-BLOCK 10735 . 10901)) (10903 11024 (FASL-EXTENDED 10903 . 11024)) (11026 11151 (SETESCAPE
|
||||
11026 . 11151)) (11153 11249 (UNIMPLEMENTED-OPCODE 11153 . 11249)) (11610 12960 (PROCESS-FILE 11610 .
|
||||
12960)) (12962 13192 (PROCESS-SEGMENT 12962 . 13192)) (13297 13609 (CHECK-VERSION 13297 . 13609)) (
|
||||
13611 14272 (READ-TEXT 13611 . 14272)) (14274 14776 (PROCESS-BLOCK 14274 . 14776)) (14778 14917 (
|
||||
SKIP-TEXT 14778 . 14917)) (14972 15579 (DO-OP 14972 . 15579)) (15581 15682 (NEW-VALUE-TABLE 15581 .
|
||||
15682)) (15684 15783 (CLEAR-TABLE 15684 . 15783)) (15785 16039 (STORE-VALUE 15785 . 16039)) (16041
|
||||
16126 (FETCH-VALUE 16041 . 16126)) (16128 16656 (COLLECT-LIST 16128 . 16656)) (31623 35206 (
|
||||
IL:FASL-FILEDATE 31636 . 32797) (CONVERT-FASL-DATE 32799 . 35204)))))
|
||||
(IL:FILEMAP (NIL (6469 6885 (TABLE-STATS 6469 . 6885)) (7047 7326 (MAKE-OPTABLE 7047 . 7326)) (7328
|
||||
7975 (DEFINE-OPCODE-RANGE 7328 . 7975)) (7977 8527 (DEFINE-SINGLE-OPCODE 7977 . 8527)) (8529 8787 (
|
||||
ADD-OP-TRANSLATION 8529 . 8787)) (8789 9149 (OPCODE-SEQUENCE 8789 . 9149)) (10727 10893 (
|
||||
FASL-END-OF-BLOCK 10727 . 10893)) (10895 11016 (FASL-EXTENDED 10895 . 11016)) (11018 11143 (SETESCAPE
|
||||
11018 . 11143)) (11145 11241 (UNIMPLEMENTED-OPCODE 11145 . 11241)) (11602 12942 (PROCESS-FILE 11602 .
|
||||
12942)) (12944 13174 (PROCESS-SEGMENT 12944 . 13174)) (13279 13591 (CHECK-VERSION 13279 . 13591)) (
|
||||
13593 14254 (READ-TEXT 13593 . 14254)) (14256 14742 (PROCESS-BLOCK 14256 . 14742)) (14744 14883 (
|
||||
SKIP-TEXT 14744 . 14883)) (14938 15545 (DO-OP 14938 . 15545)) (15547 15648 (NEW-VALUE-TABLE 15547 .
|
||||
15648)) (15650 15749 (CLEAR-TABLE 15650 . 15749)) (15751 16006 (STORE-VALUE 15751 . 16006)) (16008
|
||||
16093 (FETCH-VALUE 16008 . 16093)) (16095 16623 (COLLECT-LIST 16095 . 16623)) (30975 34345 (
|
||||
IL:FASL-FILEDATE 30988 . 32271) (CONVERT-FASL-DATE 32273 . 34343)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
957
sources/FILEIO
957
sources/FILEIO
File diff suppressed because it is too large
Load Diff
Binary file not shown.
491
sources/FILEPKG
491
sources/FILEPKG
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "10-Oct-2021 20:36:54"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEPKG.;10 284821
|
||||
(FILECREATED " 2-Dec-2021 23:35:54" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;17 278911
|
||||
|
||||
changes to%: (FNS MAKEFILE)
|
||||
changes to%: (VARS FILEPKGCOMS)
|
||||
|
||||
previous date%: " 8-Oct-2021 23:56:39"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEPKG.;9)
|
||||
previous date%: " 1-Dec-2021 17:05:26"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;16)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -21,7 +20,7 @@ with the terms of said license.
|
||||
|
||||
(RPAQQ FILEPKGCOMS
|
||||
[(COMS (* ;
|
||||
"standard records for accessing file package type/command parts. Exported for PRETTY")
|
||||
"standard records for accessing file package type/command parts. Exported for PRETTY")
|
||||
(VARS FILEPKGTYPEPROPS)
|
||||
(EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
|
||||
(FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
|
||||
@@ -87,7 +86,7 @@ with the terms of said license.
|
||||
(MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
|
||||
(ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
|
||||
[COMS (* ;
|
||||
"functions for doing things and marking them changed and auxiliary functions")
|
||||
"functions for doing things and marking them changed and auxiliary functions")
|
||||
(FNS SAVEPUT)
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
|
||||
(CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
|
||||
@@ -95,7 +94,7 @@ with the terms of said license.
|
||||
(ADDVARS (LISPXFNS (PUT . SAVEPUT)
|
||||
(PUTPROP . SAVEPUT]
|
||||
(COMS (* ;
|
||||
"sub-functions for file package commands & types")
|
||||
"sub-functions for file package commands & types")
|
||||
(FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED
|
||||
MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS
|
||||
PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS
|
||||
@@ -109,7 +108,7 @@ with the terms of said license.
|
||||
LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS
|
||||
PRETTYPRINTYPEMACROS USERMACROS))
|
||||
(COMS (* ;
|
||||
"Define the commands below AFTER the various properties have been established.")
|
||||
"Define the commands below AFTER the various properties have been established.")
|
||||
(USERMACROS M))
|
||||
(COMS (* ; "GETDEF methods")
|
||||
(FNS RENAME CHANGECALLERS)
|
||||
@@ -117,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.")
|
||||
|
||||
@@ -211,99 +203,91 @@ with the terms of said license.
|
||||
(* ; "standard records for accessing file package type/command parts. Exported for PRETTY")
|
||||
|
||||
|
||||
(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED
|
||||
HASDEF EDITDEF CANFILEDEF FILEGETDEF))
|
||||
(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF
|
||||
EDITDEF CANFILEDEF FILEGETDEF))
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(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
|
||||
(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))
|
||||
(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]
|
||||
(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.)
|
||||
REMPROP on NILs.)
|
||||
(* NOTE%: PRETTCOM on PRETTY has
|
||||
open-coded access to the MACRO
|
||||
property.)
|
||||
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
|
||||
FILEPKGCONTENTS)))
|
||||
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]
|
||||
(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 ))))
|
||||
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])
|
||||
[ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
|
||||
(STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
|
||||
UNDOABLE
|
||||
(/PUTPROP DATUM 'FILE NEWVALUE])
|
||||
|
||||
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
|
||||
|
||||
@@ -956,12 +940,12 @@ compiling " T)
|
||||
(RPAQ? NILCOMS )
|
||||
|
||||
(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF
|
||||
FORMAT (REC . RC)
|
||||
(BREC . RC)
|
||||
(TC . C)
|
||||
(BC . C)
|
||||
(TCOMPL . C)
|
||||
(BCOMPL . C))
|
||||
FORMAT (REC . RC)
|
||||
(BREC . RC)
|
||||
(TC . C)
|
||||
(BC . C)
|
||||
(TCOMPL . C)
|
||||
(BCOMPL . C))
|
||||
|
||||
(RPAQ? MAKEFILEREMAKEFLG T)
|
||||
|
||||
@@ -2705,7 +2689,7 @@ compiling " T)
|
||||
)
|
||||
|
||||
(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
|
||||
(PUTPROP . SAVEPUT))
|
||||
(PUTPROP . SAVEPUT))
|
||||
|
||||
|
||||
|
||||
@@ -3119,14 +3103,14 @@ compiling " T)
|
||||
|
||||
|
||||
(ADDTOVAR USERMACROS
|
||||
(M NIL (MAKE FILE FILE))
|
||||
(M (X . Y)
|
||||
(E (MARKASCHANGED (COND ((LISTP 'X)
|
||||
(CAR 'X))
|
||||
(T 'X))
|
||||
'USERMACROS)
|
||||
T)
|
||||
(ORIGINAL (M X . Y)))
|
||||
(M NIL (MAKE FILE FILE)))
|
||||
(ORIGINAL (M X . Y))))
|
||||
|
||||
(ADDTOVAR EDITMACROS
|
||||
(M (X . Y)
|
||||
@@ -3272,11 +3256,15 @@ compiling " T)
|
||||
(DEFINEQ
|
||||
|
||||
(SHOWDEF
|
||||
[LAMBDA (NAME TYPE FILE) (* ; "Edited 16-Apr-2018 21:35 by rmk:")
|
||||
(* ;
|
||||
"prettyprint NAME as it would be dumped as a TYPE")
|
||||
[LAMBDA (NAME TYPE FILE) (* ; "Edited 26-Oct-2021 09:21 by rmk:")
|
||||
(* ; "Edited 16-Apr-2018 21:35 by rmk:")
|
||||
(* ;
|
||||
"prettyprint NAME as it would be dumped as a TYPE (in the current reader environment)")
|
||||
(RESETLST
|
||||
(PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
|
||||
(PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP (SOURCEFILENV (MAKE-READER-ENVIRONMENT
|
||||
|
||||
*DEFAULT-MAKEFILE-ENVIRONMENT*
|
||||
)))
|
||||
(DECLARE (SPECVARS . T))
|
||||
[AND FILE (NEQ FILE (OUTPUT))
|
||||
(if (SETQ FL (OPENP FILE 'OUTPUT))
|
||||
@@ -3955,7 +3943,9 @@ compiling " T)
|
||||
(RETURN TYPE])
|
||||
|
||||
(COMPAREDEFS
|
||||
[LAMBDA (NAME TYPE SOURCES) (* lmm " 4-Jul-85 14:37")
|
||||
[LAMBDA (NAME TYPE SOURCES) (* ; "Edited 8-Nov-2021 10:52 by rmk:")
|
||||
(* ; "Edited 30-Oct-2021 20:01 by rmk:")
|
||||
(* lmm " 4-Jul-85 14:37")
|
||||
(COND
|
||||
((AND (LISTP TYPE)
|
||||
(GETFILEPKGTYPE SOURCES NIL T))
|
||||
@@ -3969,41 +3959,45 @@ compiling " T)
|
||||
(MEMBER NAME (CDR (ASSOC TYPE
|
||||
(fetch TOBEDUMPED
|
||||
of (fetch FILEPROP
|
||||
of FILE]
|
||||
of FILE]
|
||||
(push SRCS 'CURRENT]
|
||||
(SETQ SRCS (for SRC in SRCS
|
||||
when (COND
|
||||
((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
|
||||
(fetch NULLDEF of TYPE))
|
||||
(OR [SOME DEFS (FUNCTION (LAMBDA (DP)
|
||||
(COMPARELST DEF (CDR DP]
|
||||
(push DEFS (CONS SRC DEF)))
|
||||
T)
|
||||
(T (PRINTOUT T "No " SRC " definition found for " NAME T)
|
||||
NIL)) collect SRC))
|
||||
(SETQ SRCS (for SRC in SRCS when (COND
|
||||
((NEQ [SETQ DEF (GETDEF NAME TYPE SRC
|
||||
'(NOERROR NOCOPY]
|
||||
(fetch NULLDEF of TYPE))
|
||||
(OR [SOME DEFS (FUNCTION (LAMBDA (DP)
|
||||
(COMPARELST DEF
|
||||
(CDR DP]
|
||||
(push DEFS (CONS SRC DEF)))
|
||||
T)
|
||||
(T (PRINTOUT T "No " SRC " definition found for " NAME
|
||||
T)
|
||||
NIL)) collect SRC))
|
||||
(RETURN (COND
|
||||
((NULL SRCS)
|
||||
'(no definitions found))
|
||||
((NULL (CDR SRCS))
|
||||
'(only one definition found))
|
||||
((CDR DEFS)
|
||||
[for S1 on (DREVERSE DEFS)
|
||||
[for S1 [FILECOL _ (IPLUS (NCHARS NAME)
|
||||
(CONSTANT (NCHARS " from "] on (DREVERSE DEFS)
|
||||
do (for S2 on (CDR S1) do (PRIN2 NAME T T)
|
||||
(AND (CAAR S1)
|
||||
(PRIN1 " from " T)
|
||||
(PRIN2 (CAAR S1)
|
||||
T T))
|
||||
(PRIN1 " and " T)
|
||||
(PRIN2 NAME T T)
|
||||
(COND
|
||||
((CAAR S2)
|
||||
(PRIN1 " from " T)
|
||||
(PRIN2 (CAAR S2)
|
||||
T T)))
|
||||
(PRIN1 " differ:" T)
|
||||
(TERPRI T)
|
||||
(COMPARELISTS (CDAR S1)
|
||||
(CDAR S2]
|
||||
(AND (CAAR S1)
|
||||
(PRIN1 " from " T)
|
||||
(PRIN2 (CAAR S1)
|
||||
T T))
|
||||
(TAB (IDIFFERENCE FILECOL (CONSTANT (NCHARS
|
||||
" and "
|
||||
)))
|
||||
NIL T)
|
||||
(PRIN1 " and " T)
|
||||
(COND
|
||||
((CAAR S2)
|
||||
(PRIN2 (CAAR S2)
|
||||
T T)))
|
||||
(TERPRI T)
|
||||
(COMPARELISTS (CDAR S1)
|
||||
(CDAR S2]
|
||||
'DIFFERENT)
|
||||
(T 'SAME])
|
||||
|
||||
@@ -4093,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."
|
||||
)
|
||||
@@ -4508,7 +4376,7 @@ compiling " T)
|
||||
(P (CONSTANTS . X])
|
||||
|
||||
(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
|
||||
(VARIABLES VARS CONSTANTS))
|
||||
(VARIABLES VARS CONSTANTS))
|
||||
|
||||
(RPAQ? SAVEDDEFS )
|
||||
|
||||
@@ -4971,10 +4839,10 @@ compiling " T)
|
||||
)
|
||||
|
||||
(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
|
||||
((Y "es")
|
||||
(N "o")
|
||||
(E . "verything")
|
||||
(F "ilemaps only
|
||||
((Y "es")
|
||||
(N "o")
|
||||
(E . "verything")
|
||||
(F "ilemaps only
|
||||
"))))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -5031,8 +4899,7 @@ compiling " T)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS
|
||||
MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS
|
||||
PRETTYDEFMACROS)
|
||||
MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS PRETTYDEFMACROS)
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
@@ -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 (20618 22323 (SEARCHPRETTYTYPELST 20628 . 21607) (PRETTYDEFMACROS 21609 . 22067) (
|
||||
FILEPKGCOMPROPS 22069 . 22321)) (23125 57943 (CLEANUP 23135 . 24523) (COMPILEFILES 24525 . 24801) (
|
||||
COMPILEFILES0 24803 . 25523) (CONTINUEDIT 25525 . 26945) (MAKEFILE 26947 . 39284) (FILECHANGES 39286
|
||||
. 41621) (FILEPKG.MERGECHANGES 41623 . 42446) (FILEPKG.CHANGEDFNS 42448 . 42760) (MAKEFILE1 42762 .
|
||||
46989) (COMPILE-FILE? 46991 . 48548) (MAKEFILES 48550 . 50243) (ADDFILE 50245 . 52766) (ADDFILE0 52768
|
||||
. 56904) (LISTFILES 56906 . 57941)) (58639 93879 (FILEPKGCHANGES 58649 . 59999) (GETFILEPKGTYPE 60001
|
||||
. 63074) (MARKASCHANGED 63076 . 64713) (FILECOMS 64715 . 65099) (WHEREIS 65101 . 66521) (
|
||||
SMASHFILECOMS 66523 . 66758) (FILEFNSLST 66760 . 66922) (FILECOMSLST 66924 . 67408) (UPDATEFILES 67410
|
||||
. 72710) (INFILECOMS? 72712 . 74615) (INFILECOMTAIL 74617 . 75757) (INFILECOMS 75759 . 75920) (
|
||||
INFILECOM 75922 . 86131) (INFILECOMSVALS 86133 . 86460) (INFILECOMSVAL 86462 . 87464) (INFILECOMSPROP
|
||||
87466 . 88295) (IFCPROPS 88297 . 89558) (IFCEXPRTYPE 89560 . 90071) (IFCPROPSCAN 90073 . 91126) (
|
||||
IFCDECLARE 91128 . 92439) (INFILEPAIRS 92441 . 92773) (INFILECOMSMACRO 92775 . 93877)) (93914 125334 (
|
||||
FILES? 93924 . 96117) (FILES?1 96119 . 96817) (FILES?PRINTLST 96819 . 97601) (ADDTOFILES? 97603 .
|
||||
108649) (ADDTOFILE 108651 . 109567) (WHATIS 109569 . 111545) (ADDTOCOMS 111547 . 113191) (ADDTOCOM
|
||||
113193 . 119740) (ADDTOCOM1 119742 . 120913) (ADDNEWCOM 120915 . 121965) (MAKENEWCOM 121967 . 123810)
|
||||
(DEFAULTMAKENEWCOM 123812 . 125332)) (125404 128221 (MERGEINSERT 125414 . 127757) (MERGEINSERT1 127759
|
||||
. 128219)) (128375 129732 (ADDTOFILEKEYLST 128385 . 129730)) (129849 140761 (DELFROMFILES 129859 .
|
||||
130709) (DELFROMCOMS 130711 . 132390) (DELFROMCOM 132392 . 138260) (DELFROMCOM1 138262 . 139059) (
|
||||
REMOVEITEM 139061 . 139935) (MOVETOFILE 139937 . 140759)) (140975 143344 (SAVEPUT 140985 . 143342)) (
|
||||
143469 151793 (UNMARKASCHANGED 143479 . 145187) (PREEDITFN 145189 . 147700) (POSTEDITPROPS 147702 .
|
||||
150203) (POSTEDITALISTS 150205 . 151791)) (151942 172496 (ALISTS.GETDEF 151952 . 152331) (
|
||||
ALISTS.WHENCHANGED 152333 . 152977) (CLEARCLISPARRAY 152979 . 154153) (EXPRESSIONS.WHENCHANGED 154155
|
||||
. 154529) (MAKEALISTCOMS 154531 . 155604) (MAKEFILESCOMS 155606 . 157043) (MAKELISPXMACROSCOMS 157045
|
||||
. 159063) (MAKEPROPSCOMS 159065 . 159763) (MAKEUSERMACROSCOMS 159765 . 161565) (PROPS.WHENCHANGED
|
||||
161567 . 162188) (FILEGETDEF.LISPXMACROS 162190 . 163632) (FILEGETDEF.ALISTS 163634 . 164253) (
|
||||
FILEGETDEF.RECORDS 164255 . 165186) (FILEGETDEF.PROPS 165188 . 165980) (FILEGETDEF.MACROS 165982 .
|
||||
167042) (FILEGETDEF.VARS 167044 . 167460) (FILEGETDEF.FNS 167462 . 168826) (FILEPKGCOMS.PUTDEF 168828
|
||||
. 171268) (FILES.PUTDEF 171270 . 172227) (VARS.PUTDEF 172229 . 172372) (FILES.WHENCHANGED 172374 .
|
||||
172494)) (174518 181951 (RENAME 174528 . 175929) (CHANGECALLERS 175931 . 181949)) (181952 229900 (
|
||||
SHOWDEF 181962 . 182755) (COPYDEF 182757 . 185231) (GETDEF 185233 . 187509) (GETDEFCOM 187511 . 188477
|
||||
) (GETDEFCOM0 188479 . 189825) (GETDEFCURRENT 189827 . 196247) (GETDEFERR 196249 . 197550) (
|
||||
GETDEFFROMFILE 197552 . 201832) (GETDEFSAVED 201834 . 202938) (PUTDEF 202940 . 203643) (EDITDEF 203645
|
||||
. 204622) (DEFAULT.EDITDEF 204624 . 207460) (EDITDEF.FILES 207462 . 207663) (LOADDEF 207665 . 207841)
|
||||
(DWIMDEF 207843 . 208697) (DELDEF 208699 . 211713) (DELFROMLIST 211715 . 212219) (HASDEF 212221 .
|
||||
218543) (GETFILEDEF 218545 . 219067) (SAVEDEF 219069 . 220728) (UNSAVEDEF 220730 . 221626) (
|
||||
COMPAREDEFS 221628 . 224930) (COMPARE 224932 . 225636) (TYPESOF 225638 . 229898)) (229967 235010 (
|
||||
FIXEDITDATE 229977 . 233480) (EDITDATE? 233482 . 235008)) (235429 244200 (FILEPKGCOM 235439 . 240372)
|
||||
(FILEPKGTYPE 240374 . 244198)) (256237 271169 (FINDCALLERS 256247 . 256762) (EDITCALLERS 256764 .
|
||||
264674) (EDITFROMFILE 264676 . 270484) (FINDATS 270486 . 270758) (LOOKIN 270760 . 271167)) (271170
|
||||
272897 (SEPRCASE 271180 . 272895)) (273414 278971 (IMPORTFILE 273424 . 274398) (IMPORTEVAL 274400 .
|
||||
275280) (IMPORTFILESCAN 275282 . 275703) (CHECKIMPORTS 275705 . 277041) (GATHEREXPORTS 277043 . 278381
|
||||
) (\DUMPEXPORTS 278383 . 278969)) (279309 281517 (CLEARFILEPKG 279319 . 281515)))))
|
||||
(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,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "17-Oct-2021 13:52:47"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;15 6457
|
||||
(FILECREATED "17-Oct-2021 16:06:59"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;17 6482
|
||||
|
||||
changes to%: (VARS EXPORTFILES)
|
||||
|
||||
previous date%: "17-Oct-2021 12:43:39"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;14)
|
||||
previous date%: "17-Oct-2021 13:52:47"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;16)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -72,7 +72,8 @@ Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation.
|
||||
(MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR
|
||||
LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY
|
||||
ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
|
||||
IMAGEIO PROC XCCS PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS LLETHER PUP UFS))
|
||||
IMAGEIO PROC XCCS PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS LLETHER PUP UFS
|
||||
DTDECLARE))
|
||||
|
||||
(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
|
||||
|
||||
|
||||
@@ -1,12 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "25-Sep-2021 20:58:07"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;4 79783
|
||||
|
||||
changes to%: (VARS IMAGEIOCOMS)
|
||||
(FNS \DISPLAYINIT \4DISPLAYINIT \8DISPLAYINIT \24DISPLAYINIT)
|
||||
(FILECREATED "30-Oct-2021 19:09:48" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>IMAGEIO.;7 80279
|
||||
|
||||
previous date%: " 2-Aug-2021 19:41:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;2)
|
||||
changes to%: (FNS \NOIMAGE.DSPFONT)
|
||||
|
||||
previous date%: "25-Sep-2021 20:58:07"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>IMAGEIO.;5)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -756,16 +755,20 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
IMDRAWPOINT _ (FUNCTION NILL])
|
||||
|
||||
(\NOIMAGE.DSPFONT
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 28-Oct-87 20:10 by jds")
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 30-Oct-2021 19:09 by rmk:")
|
||||
(* ; "Edited 28-Oct-87 20:10 by jds")
|
||||
|
||||
(* ;; "DSPFONT method for non-image streams: Put out font-change characters.")
|
||||
|
||||
(LET ((OLDFONT (ffetch IMAGEDATA of STREAM)))
|
||||
(* ;; "RMK: Save and restore CHARPOSITION")
|
||||
|
||||
(LET ((OLDFONT (ffetch (STREAM IMAGEDATA) of STREAM)))
|
||||
(PROG1 OLDFONT
|
||||
[AND (NEQ OLDFONT 0)
|
||||
(LET [(FONTN (OR (SMALLP FONT)
|
||||
(LET ([FONTN (OR (SMALLP FONT)
|
||||
(AND (type? FONTCLASS FONT)
|
||||
(fetch (FONTCLASS PRETTYFONT#) of FONT]
|
||||
CHARPOS)
|
||||
(COND
|
||||
((AND FONTN (NEQ FONTN OLDFONT))
|
||||
|
||||
@@ -773,9 +776,11 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(COND
|
||||
((NEQ FONTN 0)
|
||||
(SETQ CHARPOS (FFETCH (STREAM CHARPOSITION) OF STREAM))
|
||||
(\OUTCHAR STREAM (CONSTANT (CHCON1 FONTESCAPECHAR)))
|
||||
(\OUTCHAR STREAM FONTN)))
|
||||
(freplace IMAGEDATA of STREAM with FONTN])])
|
||||
(\OUTCHAR STREAM FONTN)
|
||||
(FREPLACE (STREAM CHARPOSITION) OF STREAM WITH CHARPOS)))
|
||||
(freplace (STREAM IMAGEDATA) of STREAM with FONTN])])
|
||||
|
||||
(\UNIMPIMAGEOP
|
||||
[LAMBDA (STREAM OP) (* rmk%: "26-Jun-84 13:28")
|
||||
@@ -904,7 +909,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR)
|
||||
BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1)
|
||||
BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1)
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -922,17 +927,18 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS IMAGEOP MACRO [ARGS (CONS 'SPREADAPPLY*
|
||||
(CONS (COND
|
||||
[(EQ (CAR (LISTP (CAR ARGS)))
|
||||
'QUOTE)
|
||||
(LIST 'fetch (LIST 'IMAGEOPS (CADAR ARGS))
|
||||
'of
|
||||
(LIST 'fetch '(STREAM IMAGEOPS)
|
||||
(PUTPROPS IMAGEOP MACRO [ARGS (CONS 'SPREADAPPLY* (CONS (COND
|
||||
[(EQ (CAR (LISTP (CAR ARGS)))
|
||||
'QUOTE)
|
||||
(LIST 'fetch (LIST 'IMAGEOPS (CADAR
|
||||
ARGS))
|
||||
'of
|
||||
(CADR ARGS]
|
||||
(T (HELP "IMAGEOP - OPNAME not quoted:" ARGS)))
|
||||
(CDDR ARGS])
|
||||
(LIST 'fetch '(STREAM IMAGEOPS)
|
||||
'of
|
||||
(CADR ARGS]
|
||||
(T (HELP "IMAGEOP - OPNAME not quoted:"
|
||||
ARGS)))
|
||||
(CDDR ARGS])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -1513,24 +1519,24 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS IMAGEIO COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1993 1994 1999 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3423 12180 (IMAGESTREAMP 3433 . 4265) (IMAGESTREAMTYPE 4267 . 4480) (IMAGESTREAMTYPEP
|
||||
4482 . 5117) (OPENIMAGESTREAM 5119 . 10073) (\GOOD.DASHLST 10075 . 12178)) (12215 14512 (
|
||||
DRAWDASHEDLINE 12225 . 14510)) (14513 21853 (DSPBACKCOLOR 14523 . 14895) (DSPBOTTOMMARGIN 14897 .
|
||||
15282) (DSPCOLOR 15284 . 15648) (DSPCLIPPINGREGION 15650 . 16355) (DSPRESET 16357 . 16637) (DSPFONT
|
||||
16639 . 17003) (DSPLEFTMARGIN 17005 . 17386) (DSPLINEFEED 17388 . 17688) (DSPOPERATION 17690 . 18067)
|
||||
(DSPRIGHTMARGIN 18069 . 18452) (DSPTOPMARGIN 18454 . 18833) (DSPSCALE 18835 . 19202) (DSPSPACEFACTOR
|
||||
19204 . 19597) (DSPXPOSITION 19599 . 19904) (DSPYPOSITION 19906 . 20211) (DSPROTATE 20213 . 20508) (
|
||||
DSPPUSHSTATE 20510 . 20756) (DSPPOPSTATE 20758 . 21001) (DSPDEFAULTSTATE 21003 . 21255) (DSPSCALE2
|
||||
21257 . 21548) (DSPTRANSLATE 21550 . 21851)) (21854 30655 (DSPNEWPAGE 21864 . 22556) (DRAWBETWEEN
|
||||
22558 . 23260) (DRAWCIRCLE 23262 . 23758) (DRAWARC 23760 . 24277) (DRAWCURVE 24279 . 24956) (
|
||||
DRAWELLIPSE 24958 . 25744) (DRAWLINE 25746 . 26136) (DRAWPOLYGON 26138 . 26593) (DRAWPOINT 26595 .
|
||||
27014) (FILLPOLYGON 27016 . 27582) (DRAWTO 27584 . 28002) (FILLCIRCLE 28004 . 28227) (MOVETO 28229 .
|
||||
28593) (RELDRAWTO 28595 . 29512) (BITMAPIMAGESIZE 29514 . 29685) (SCALEDBITBLT 29687 . 30653)) (30656
|
||||
37695 (\DRAWPOINT.GENERIC 30666 . 31013) (\DRAWPOLYGON.GENERIC 31015 . 33323) (\DRAWCIRCLE.GENERIC
|
||||
33325 . 34983) (\DRAWELLIPSE.GENERIC 34985 . 37693)) (37696 43082 (\IMAGEIOINIT 37706 . 41839) (
|
||||
\NOIMAGE.DSPFONT 41841 . 42916) (\UNIMPIMAGEOP 42918 . 43080)) (43205 46329 (INSURE.BRUSH 43215 .
|
||||
44589) (BRUSHP 44591 . 45381) (\POSSIBLECOLOR 45383 . 45934) (NEGSHADE 45936 . 46327)) (46885 47569 (
|
||||
DASHINGP 46895 . 47225) (INSURE.DASHING 47227 . 47567)) (58050 78596 (\DisplayEventFn 58060 . 58570) (
|
||||
\DISPLAYINIT 58572 . 64155) (\4DISPLAYINIT 64157 . 68858) (\8DISPLAYINIT 68860 . 73563) (
|
||||
\24DISPLAYINIT 73565 . 78337) (\DISPLAYSTREAMTYPEBPP 78339 . 78594)))))
|
||||
(FILEMAP (NIL (3343 12100 (IMAGESTREAMP 3353 . 4185) (IMAGESTREAMTYPE 4187 . 4400) (IMAGESTREAMTYPEP
|
||||
4402 . 5037) (OPENIMAGESTREAM 5039 . 9993) (\GOOD.DASHLST 9995 . 12098)) (12135 14432 (DRAWDASHEDLINE
|
||||
12145 . 14430)) (14433 21773 (DSPBACKCOLOR 14443 . 14815) (DSPBOTTOMMARGIN 14817 . 15202) (DSPCOLOR
|
||||
15204 . 15568) (DSPCLIPPINGREGION 15570 . 16275) (DSPRESET 16277 . 16557) (DSPFONT 16559 . 16923) (
|
||||
DSPLEFTMARGIN 16925 . 17306) (DSPLINEFEED 17308 . 17608) (DSPOPERATION 17610 . 17987) (DSPRIGHTMARGIN
|
||||
17989 . 18372) (DSPTOPMARGIN 18374 . 18753) (DSPSCALE 18755 . 19122) (DSPSPACEFACTOR 19124 . 19517) (
|
||||
DSPXPOSITION 19519 . 19824) (DSPYPOSITION 19826 . 20131) (DSPROTATE 20133 . 20428) (DSPPUSHSTATE 20430
|
||||
. 20676) (DSPPOPSTATE 20678 . 20921) (DSPDEFAULTSTATE 20923 . 21175) (DSPSCALE2 21177 . 21468) (
|
||||
DSPTRANSLATE 21470 . 21771)) (21774 30575 (DSPNEWPAGE 21784 . 22476) (DRAWBETWEEN 22478 . 23180) (
|
||||
DRAWCIRCLE 23182 . 23678) (DRAWARC 23680 . 24197) (DRAWCURVE 24199 . 24876) (DRAWELLIPSE 24878 . 25664
|
||||
) (DRAWLINE 25666 . 26056) (DRAWPOLYGON 26058 . 26513) (DRAWPOINT 26515 . 26934) (FILLPOLYGON 26936 .
|
||||
27502) (DRAWTO 27504 . 27922) (FILLCIRCLE 27924 . 28147) (MOVETO 28149 . 28513) (RELDRAWTO 28515 .
|
||||
29432) (BITMAPIMAGESIZE 29434 . 29605) (SCALEDBITBLT 29607 . 30573)) (30576 37615 (\DRAWPOINT.GENERIC
|
||||
30586 . 30933) (\DRAWPOLYGON.GENERIC 30935 . 33243) (\DRAWCIRCLE.GENERIC 33245 . 34903) (
|
||||
\DRAWELLIPSE.GENERIC 34905 . 37613)) (37616 43413 (\IMAGEIOINIT 37626 . 41759) (\NOIMAGE.DSPFONT 41761
|
||||
. 43247) (\UNIMPIMAGEOP 43249 . 43411)) (43536 46660 (INSURE.BRUSH 43546 . 44920) (BRUSHP 44922 .
|
||||
45712) (\POSSIBLECOLOR 45714 . 46265) (NEGSHADE 46267 . 46658)) (47216 47900 (DASHINGP 47226 . 47556)
|
||||
(INSURE.DASHING 47558 . 47898)) (58546 79092 (\DisplayEventFn 58556 . 59066) (\DISPLAYINIT 59068 .
|
||||
64651) (\4DISPLAYINIT 64653 . 69354) (\8DISPLAYINIT 69356 . 74059) (\24DISPLAYINIT 74061 . 78833) (
|
||||
\DISPLAYSTREAMTYPEBPP 78835 . 79090)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Oct-2021 23:57:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;3 90360
|
||||
(FILECREATED "26-Oct-2021 10:07:31"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;5 90395
|
||||
|
||||
changes to%: (VARS IOCHARCOMS)
|
||||
|
||||
previous date%: "24-Oct-2021 23:53:23"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;2)
|
||||
previous date%: "24-Oct-2021 23:57:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;4)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -46,7 +46,11 @@ Copyright (c) 1981-1988, 1990-1991, 2018, 2020 by Venue & Xerox Corporation.
|
||||
\OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
|
||||
(OPTIMIZERS DATEFORMAT)
|
||||
|
||||
(* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)")
|
||||
(* ;; "Default values for \BeginDST and \EndDST are set for (most places in) the U.S., 74 and 312 as of 2021.")
|
||||
|
||||
|
||||
(* ;;
|
||||
" Note: this might not be relevant to users with local time servers that do the right thing.")
|
||||
|
||||
(INITVARS (\TimeZoneComp 8)
|
||||
(\BeginDST 74)
|
||||
@@ -1322,10 +1326,15 @@ DONTCOPY
|
||||
|
||||
|
||||
(* ;;
|
||||
"Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)"
|
||||
"Default values for \BeginDST and \EndDST are set for (most places in) the U.S., 74 and 312 as of 2021."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;; " Note: this might not be relevant to users with local time servers that do the right thing.")
|
||||
|
||||
|
||||
(RPAQ? \TimeZoneComp 8)
|
||||
|
||||
(RPAQ? \BeginDST 74)
|
||||
@@ -1374,15 +1383,15 @@ DONTCOPY
|
||||
(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1991 2018 2020))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3448 7242 (CHCON 3458 . 4308) (UNPACK 4310 . 5204) (DCHCON 5206 . 6473) (DUNPACK 6475
|
||||
. 7240)) (7243 18758 (UALPHORDER 7253 . 7349) (ALPHORDER 7351 . 9154) (CONCAT 9156 . 9801) (
|
||||
CONCATCODES 9803 . 9989) (PACKC 9991 . 12594) (PACK 12596 . 13175) (PACK* 13177 . 14899) (\PACK.ITEM
|
||||
14901 . 15356) (STRPOS 15358 . 18756)) (18760 19049 (XCL:PACK 18760 . 19049)) (19051 19301 (XCL:PACK*
|
||||
19051 . 19301)) (20019 22410 (STRPOSL 20029 . 21655) (MAKEBITTABLE 21657 . 22408)) (22572 23049 (
|
||||
CASEARRAY 22582 . 22772) (UPPERCASEARRAY 22774 . 23047)) (23371 46973 (FILEPOS 23381 . 33293) (
|
||||
FFILEPOS 33295 . 44408) (\SETUP.FFILEPOS 44410 . 46971)) (47761 89008 (DATE 47771 . 47857) (DATEFORMAT
|
||||
47859 . 47951) (GDATE 47953 . 48064) (IDATE 48066 . 59737) (\IDATESCANTOKEN 59739 . 61018) (
|
||||
\IDATE-PARSE-MONTH 61020 . 64716) (\OUTDATE 64718 . 77466) (\OUTDATE-STRING 77468 . 78083) (\RPLRIGHT
|
||||
78085 . 78323) (\UNPACKDATE 78325 . 84116) (\PACKDATE 84118 . 87438) (\DTSCAN 87440 . 87582) (\ISDST?
|
||||
87584 . 88091) (\CHECKDSTCHANGE 88093 . 89006)))))
|
||||
(FILEMAP (NIL (3484 7278 (CHCON 3494 . 4344) (UNPACK 4346 . 5240) (DCHCON 5242 . 6509) (DUNPACK 6511
|
||||
. 7276)) (7279 18794 (UALPHORDER 7289 . 7385) (ALPHORDER 7387 . 9190) (CONCAT 9192 . 9837) (
|
||||
CONCATCODES 9839 . 10025) (PACKC 10027 . 12630) (PACK 12632 . 13211) (PACK* 13213 . 14935) (\PACK.ITEM
|
||||
14937 . 15392) (STRPOS 15394 . 18792)) (18796 19085 (XCL:PACK 18796 . 19085)) (19087 19337 (XCL:PACK*
|
||||
19087 . 19337)) (20055 22446 (STRPOSL 20065 . 21691) (MAKEBITTABLE 21693 . 22444)) (22608 23085 (
|
||||
CASEARRAY 22618 . 22808) (UPPERCASEARRAY 22810 . 23083)) (23407 47009 (FILEPOS 23417 . 33329) (
|
||||
FFILEPOS 33331 . 44444) (\SETUP.FFILEPOS 44446 . 47007)) (47797 89044 (DATE 47807 . 47893) (DATEFORMAT
|
||||
47895 . 47987) (GDATE 47989 . 48100) (IDATE 48102 . 59773) (\IDATESCANTOKEN 59775 . 61054) (
|
||||
\IDATE-PARSE-MONTH 61056 . 64752) (\OUTDATE 64754 . 77502) (\OUTDATE-STRING 77504 . 78119) (\RPLRIGHT
|
||||
78121 . 78359) (\UNPACKDATE 78361 . 84152) (\PACKDATE 84154 . 87474) (\DTSCAN 87476 . 87618) (\ISDST?
|
||||
87620 . 88127) (\CHECKDSTCHANGE 88129 . 89042)))))
|
||||
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.
@@ -1,37 +1,37 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "19-Jan-93 11:26:14" {DSK}<python>lde>lispcore>sources>WINDOWOBJ.;3 27891
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX)
|
||||
(FILECREATED "20-Dec-2021 23:47:45" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>WINDOWOBJ.;5 27781
|
||||
|
||||
previous date%: " 5-Jan-93 09:53:15" {DSK}<python>lde>lispcore>sources>WINDOWOBJ.;2)
|
||||
:CHANGES-TO (FNS COPYINSERT)
|
||||
|
||||
:PREVIOUS-DATE "18-Dec-2021 20:09:33"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>WINDOWOBJ.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1986-1987, 1990-1991, 1993 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT WINDOWOBJCOMS)
|
||||
|
||||
(RPAQQ WINDOWOBJCOMS [(COMS (* ;
|
||||
"Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.")
|
||||
(RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX)
|
||||
(FNS COPYINSERT IMAGEBOX IMAGEFNSCREATE IMAGEFNSP IMAGEOBJCREATE
|
||||
IMAGEOBJP IMAGEOBJPROP \IMAGEUSERPROP HPRINT.IMAGEOBJ
|
||||
COPYIMAGEOBJ READIMAGEOBJ WRITEIMAGEOBJ)
|
||||
(ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ)))
|
||||
(GLOBALVARS (IMAGEOBJTYPES NIL)
|
||||
(IMAGEOBJGETFNS NIL)))
|
||||
(COMS (* ;
|
||||
"For encapsulating unknown-type IMAGEOBJs.")
|
||||
(FNS ENCAPSULATEDOBJ.BUTTONEVENTINFN ENCAPSULATEDOBJ.PUTFN
|
||||
ENCAPSULATEDOBJ.DISPLAYFN ENCAPSULATEDOBJ.IMAGEBOXFN
|
||||
ENCAPSULATEDIMAGEFNS)
|
||||
(INITVARS ENCAPSULATEDIMAGEFNS)
|
||||
(GLOBALVARS ENCAPSULATEDIMAGEFNS))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
(ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA IMAGEOBJPROP])
|
||||
(RPAQQ WINDOWOBJCOMS
|
||||
[(COMS (* ;
|
||||
"Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.")
|
||||
(RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX)
|
||||
(FNS COPYINSERT IMAGEBOX IMAGEFNSCREATE IMAGEFNSP IMAGEOBJCREATE IMAGEOBJP IMAGEOBJPROP
|
||||
\IMAGEUSERPROP HPRINT.IMAGEOBJ COPYIMAGEOBJ READIMAGEOBJ WRITEIMAGEOBJ)
|
||||
(ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ)))
|
||||
(GLOBALVARS (IMAGEOBJTYPES NIL)
|
||||
(IMAGEOBJGETFNS NIL)))
|
||||
(COMS (* ;
|
||||
"For encapsulating unknown-type IMAGEOBJs.")
|
||||
(FNS ENCAPSULATEDOBJ.BUTTONEVENTINFN ENCAPSULATEDOBJ.PUTFN ENCAPSULATEDOBJ.DISPLAYFN
|
||||
ENCAPSULATEDOBJ.IMAGEBOXFN ENCAPSULATEDIMAGEFNS)
|
||||
(INITVARS ENCAPSULATEDIMAGEFNS)
|
||||
(GLOBALVARS ENCAPSULATEDIMAGEFNS))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA IMAGEOBJPROP])
|
||||
|
||||
|
||||
|
||||
@@ -40,35 +40,35 @@ Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All ri
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE IMAGEOBJ (OBJECTDATUM IMAGEOBJPLIST IMAGEOBJFNS)
|
||||
(SYSTEM))
|
||||
(SYSTEM))
|
||||
|
||||
(DATATYPE IMAGEFNS (DISPLAYFN (* ;
|
||||
"FN called to display the object's image")
|
||||
IMAGEBOXFN (* ; "To tell how big it is")
|
||||
PUTFN (* ; "To write it onto a file")
|
||||
GETFN (* ; "To read it back from the file")
|
||||
COPYFN (* ; "To make a copy of the object")
|
||||
BUTTONEVENTINFN (* ;
|
||||
"Called when the mouse goes down over the object")
|
||||
COPYBUTTONEVENTINFN (* ;
|
||||
"Called when the MIDDLE mouse button goes down over the object")
|
||||
WHENMOVEDFN (* ;
|
||||
"Called when the object is moved within a document or other environment")
|
||||
WHENINSERTEDFN (* ;
|
||||
"Called when the object is inserted into a context")
|
||||
WHENDELETEDFN (* ;
|
||||
"Called when the object is removed from a context")
|
||||
WHENCOPIEDFN (* ;
|
||||
"Called when the object is copied within a context")
|
||||
WHENOPERATEDONFN (* ;
|
||||
"Called when something interesting happens to the object")
|
||||
PREPRINTFN IMAGECLASSNAME (* ;
|
||||
"LITATOM unique name by which this kind of IMAGEOBJ is to be known to the world.")
|
||||
)
|
||||
(SYSTEM))
|
||||
(DATATYPE IMAGEFNS (DISPLAYFN (* ;
|
||||
"FN called to display the object's image")
|
||||
IMAGEBOXFN (* ; "To tell how big it is")
|
||||
PUTFN (* ; "To write it onto a file")
|
||||
GETFN (* ; "To read it back from the file")
|
||||
COPYFN (* ; "To make a copy of the object")
|
||||
BUTTONEVENTINFN (* ;
|
||||
"Called when the mouse goes down over the object")
|
||||
COPYBUTTONEVENTINFN (* ;
|
||||
"Called when the MIDDLE mouse button goes down over the object")
|
||||
WHENMOVEDFN (* ;
|
||||
"Called when the object is moved within a document or other environment")
|
||||
WHENINSERTEDFN (* ;
|
||||
"Called when the object is inserted into a context")
|
||||
WHENDELETEDFN (* ;
|
||||
"Called when the object is removed from a context")
|
||||
WHENCOPIEDFN (* ;
|
||||
"Called when the object is copied within a context")
|
||||
WHENOPERATEDONFN (* ;
|
||||
"Called when something interesting happens to the object")
|
||||
PREPRINTFN IMAGECLASSNAME (* ;
|
||||
"LITATOM unique name by which this kind of IMAGEOBJ is to be known to the world.")
|
||||
)
|
||||
(SYSTEM))
|
||||
|
||||
(RECORD IMAGEBOX (XSIZE YSIZE YDESC XKERN)
|
||||
(SYSTEM))
|
||||
(SYSTEM))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'IMAGEOBJ '(POINTER POINTER POINTER)
|
||||
@@ -98,7 +98,11 @@ Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All ri
|
||||
(DEFINEQ
|
||||
|
||||
(COPYINSERT
|
||||
[LAMBDA (IMAGEOBJ) (* ; "Edited 17-Sep-90 13:19 by jds")
|
||||
[LAMBDA (IMAGEOBJ)
|
||||
|
||||
(* ;; "Edited 20-Dec-2021 23:47 by rmk: IMAGEOBJ can now also be a list of objects in the COPYINSERTFN case")
|
||||
|
||||
(* ;; "Edited 17-Sep-90 13:19 by jds")
|
||||
|
||||
(* ;;; "inserts IMAGEOBJ into the window that currently has the tty. If this window has a COPYINSERTFN property, that is called, otherwise BKSYSBUF is called.")
|
||||
|
||||
@@ -106,22 +110,22 @@ Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All ri
|
||||
INSERTFN)
|
||||
(COND
|
||||
((SETQ INSERTFN (WINDOWPROP TTYW 'COPYINSERTFN))
|
||||
(APPLY* INSERTFN IMAGEOBJ TTYW))
|
||||
(for IMOBJ inside IMAGEOBJ do (APPLY* INSERTFN IMOBJ TTYW)))
|
||||
(T (* ;
|
||||
"IMAGEOBJ can be a list of things too.")
|
||||
"IMAGEOBJ can be a list of things too.")
|
||||
(for IMOBJ inside IMAGEOBJ
|
||||
do (BKSYSBUF (OR (COND
|
||||
[(IMAGEOBJP IMOBJ)
|
||||
(COND
|
||||
((SETQ INSERTFN (IMAGEOBJPROP IMOBJ 'PREPRINTFN))
|
||||
(APPLY* INSERTFN IMOBJ))
|
||||
(T (IMAGEOBJPROP IMOBJ 'OBJECTDATUM]
|
||||
(T IMOBJ))
|
||||
"")
|
||||
T
|
||||
(PROCESS.EVAL (TTY.PROCESS)
|
||||
'(GETREADTABLE)
|
||||
T])
|
||||
[(IMAGEOBJP IMOBJ)
|
||||
(COND
|
||||
((SETQ INSERTFN (IMAGEOBJPROP IMOBJ 'PREPRINTFN))
|
||||
(APPLY* INSERTFN IMOBJ))
|
||||
(T (IMAGEOBJPROP IMOBJ 'OBJECTDATUM]
|
||||
(T IMOBJ))
|
||||
"")
|
||||
T
|
||||
(PROCESS.EVAL (TTY.PROCESS)
|
||||
'(GETREADTABLE)
|
||||
T])
|
||||
|
||||
(IMAGEBOX
|
||||
[LAMBDA (OBJ STREAM MODE) (* jds " 8-Feb-84 10:48")
|
||||
@@ -527,11 +531,11 @@ Either delete this image object or load its support files." IMAGEOBJ)
|
||||
)
|
||||
(PUTPROPS WINDOWOBJ COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (5088 21106 (COPYINSERT 5098 . 6542) (IMAGEBOX 6544 . 6724) (IMAGEFNSCREATE 6726 . 7921)
|
||||
(IMAGEFNSP 7923 . 8164) (IMAGEOBJCREATE 8166 . 8711) (IMAGEOBJP 8713 . 8954) (IMAGEOBJPROP 8956 .
|
||||
14848) (\IMAGEUSERPROP 14850 . 15444) (HPRINT.IMAGEOBJ 15446 . 16035) (COPYIMAGEOBJ 16037 . 16780) (
|
||||
READIMAGEOBJ 16782 . 19752) (WRITEIMAGEOBJ 19754 . 21104)) (21320 27527 (
|
||||
ENCAPSULATEDOBJ.BUTTONEVENTINFN 21330 . 22466) (ENCAPSULATEDOBJ.PUTFN 22468 . 23583) (
|
||||
ENCAPSULATEDOBJ.DISPLAYFN 23585 . 25198) (ENCAPSULATEDOBJ.IMAGEBOXFN 25200 . 26088) (
|
||||
ENCAPSULATEDIMAGEFNS 26090 . 27525)))))
|
||||
(FILEMAP (NIL (4895 20996 (COPYINSERT 4905 . 6432) (IMAGEBOX 6434 . 6614) (IMAGEFNSCREATE 6616 . 7811)
|
||||
(IMAGEFNSP 7813 . 8054) (IMAGEOBJCREATE 8056 . 8601) (IMAGEOBJP 8603 . 8844) (IMAGEOBJPROP 8846 .
|
||||
14738) (\IMAGEUSERPROP 14740 . 15334) (HPRINT.IMAGEOBJ 15336 . 15925) (COPYIMAGEOBJ 15927 . 16670) (
|
||||
READIMAGEOBJ 16672 . 19642) (WRITEIMAGEOBJ 19644 . 20994)) (21210 27417 (
|
||||
ENCAPSULATEDOBJ.BUTTONEVENTINFN 21220 . 22356) (ENCAPSULATEDOBJ.PUTFN 22358 . 23473) (
|
||||
ENCAPSULATEDOBJ.DISPLAYFN 23475 . 25088) (ENCAPSULATEDOBJ.IMAGEBOXFN 25090 . 25978) (
|
||||
ENCAPSULATEDIMAGEFNS 25980 . 27415)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
30
sources/XCCS
30
sources/XCCS
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
|
||||
(FILECREATED "13-Aug-2021 14:08:48" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;48 13416
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "10-Sep-2021 19:49:22" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;47 13404
|
||||
|
||||
changes to%: (FNS \XCCSBACKCCODE \XCCSOUTCHAR)
|
||||
changes to%: (FNS \CREATE.XCCS.EXTERNALFORMAT)
|
||||
|
||||
previous date%: " 8-Aug-2021 12:56:55"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;45)
|
||||
previous date%: "13-Aug-2021 14:08:48"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;46)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT XCCSCOMS)
|
||||
@@ -210,9 +210,9 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\CREATE.XCCS.EXTERNALFORMAT
|
||||
[LAMBDA (NAME EOL) (* ; "Edited 1-Aug-2021 23:13 by rmk:")
|
||||
[LAMBDA (NAME EOL) (* ; "Edited 10-Sep-2021 19:49 by rmk:")
|
||||
|
||||
(* ;;; "Create the :XCCS external format. Stream's EOL overrides the (vacuous) default here")
|
||||
(* ;;; "Create the :XCCS external format. Stream's EOL overrides the (vacuous) default here")
|
||||
|
||||
(CL:UNLESS NAME (SETQ NAME :XCCS))
|
||||
(CL:UNLESS EOL
|
||||
@@ -222,7 +222,7 @@
|
||||
(FUNCTION \XCCSBACKCCODE)
|
||||
(FUNCTION \XCCSOUTCHAR)
|
||||
(FUNCTION \XCCSFORMATBYTESTREAM)
|
||||
EOL])
|
||||
EOL T])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -268,9 +268,9 @@
|
||||
|
||||
(PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM)
|
||||
|
||||
(* ;; "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented")
|
||||
(* ;
|
||||
"note that neq is ok since charsets are known to be SMALLP's")
|
||||
(* ;; "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented")
|
||||
(* ;
|
||||
"note that neq is ok since charsets are known to be SMALLP's")
|
||||
(NEQ (fetch CHARSET of STREAM)
|
||||
\NORUNCODE)))
|
||||
)
|
||||
@@ -290,8 +290,8 @@
|
||||
(\CREATE.XCCS.EXTERNALFORMAT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1333 1562 (ACCESS-CHARSET 1343 . 1560)) (1563 10431 (\XCCSINCCODE 1573 . 4345) (
|
||||
\XCCSPEEKCCODE 4347 . 6883) (\XCCSOUTCHAR 6885 . 9105) (\XCCSBACKCCODE 9107 . 10102) (
|
||||
\XCCSFORMATBYTESTREAM 10104 . 10429)) (10432 10988 (\CREATE.XCCS.EXTERNALFORMAT 10442 . 10986)) (10989
|
||||
11820 (\NSIN.24BITENCODING.ERROR 10999 . 11818)))))
|
||||
(FILEMAP (NIL (1319 1548 (ACCESS-CHARSET 1329 . 1546)) (1549 10417 (\XCCSINCCODE 1559 . 4331) (
|
||||
\XCCSPEEKCCODE 4333 . 6869) (\XCCSOUTCHAR 6871 . 9091) (\XCCSBACKCCODE 9093 . 10088) (
|
||||
\XCCSFORMATBYTESTREAM 10090 . 10415)) (10418 10976 (\CREATE.XCCS.EXTERNALFORMAT 10428 . 10974)) (10977
|
||||
11808 (\NSIN.24BITENCODING.ERROR 10987 . 11806)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user