Compare commits
21 Commits
medley-211
...
medley-211
| Author | SHA1 | Date | |
|---|---|---|---|
|
3d8066b7e8 | ||
|
b303e0affa | ||
|
|
869b3a2e32 | ||
|
|
f19d9cc5e2 | ||
|
237f3aa6bf | ||
|
|
89a8fe183d | ||
|
|
8266980c22 | ||
|
|
c385039c42 | ||
|
|
1ff0018772 | ||
|
|
6611f96702 | ||
|
|
824e0f20b2 | ||
|
|
d479ef2ef9 | ||
|
|
98aa15455e | ||
|
|
ca069578c3 | ||
|
|
23731b05d1 | ||
|
ab4800054e | ||
|
|
b1634ef140 | ||
|
76a2235636 | ||
|
|
7c65b47fba | ||
|
|
a315e6926f | ||
|
|
1c9c1da257 |
50
.github/workflows/buildDocker.yml
vendored
50
.github/workflows/buildDocker.yml
vendored
@@ -7,10 +7,6 @@ name: Build Medley Docker image
|
|||||||
on:
|
on:
|
||||||
workflow_dispatch:
|
workflow_dispatch:
|
||||||
|
|
||||||
# push:
|
|
||||||
# branches:
|
|
||||||
# - master
|
|
||||||
|
|
||||||
# Jobs that compose this workflow
|
# Jobs that compose this workflow
|
||||||
jobs:
|
jobs:
|
||||||
# Job to build the docker image
|
# Job to build the docker image
|
||||||
@@ -21,27 +17,34 @@ jobs:
|
|||||||
- name: Checkout
|
- name: Checkout
|
||||||
uses: actions/checkout@v2
|
uses: actions/checkout@v2
|
||||||
|
|
||||||
|
# Get the Medley Release Information
|
||||||
|
- name: Get Medley Release Information
|
||||||
|
id: medley_version
|
||||||
|
uses: abatilo/release-info-action@v1.3.0
|
||||||
|
with:
|
||||||
|
owner: Interlisp
|
||||||
|
repo: medley
|
||||||
|
|
||||||
|
# Get the Maiko Release Information
|
||||||
|
- name: Get Maiko Release Information
|
||||||
|
id: maiko_version
|
||||||
|
uses: abatilo/release-info-action@v1.3.0
|
||||||
|
with:
|
||||||
|
owner: Interlisp
|
||||||
|
repo: maiko
|
||||||
|
|
||||||
# Setup needed environment variables
|
# Setup needed environment variables
|
||||||
- name: Prepare
|
- name: Prepare
|
||||||
id: prep
|
id: prep
|
||||||
run: |
|
run: |
|
||||||
DOCKER_IMAGE=interlisp/${GITHUB_REPOSITORY#*/}
|
DOCKERHUB_ACCOUNT=interlisp
|
||||||
|
DOCKER_IMAGE=${DOCKERHUB_ACCOUNT}/${GITHUB_REPOSITORY#*/}
|
||||||
VERSION=latest
|
VERSION=latest
|
||||||
SHORTREF=${GITHUB_SHA::8}
|
MAIKO_RELEASE=${{ steps.maiko_version.outputs.latest_tag }}
|
||||||
|
MEDLEY_RELEASE=${{ steps.medley_version.outputs.latest_tag }}
|
||||||
# If this is git tag, use the tag name as a docker tag
|
|
||||||
if [[ $GITHUB_REF == refs/tags/* ]]; then
|
|
||||||
VERSION=${GITHUB_REF#refs/tags/}
|
|
||||||
fi
|
|
||||||
TAGS="${DOCKER_IMAGE}:${VERSION},${DOCKER_IMAGE}:${SHORTREF}"
|
|
||||||
|
|
||||||
# If the VERSION looks like medley followed by a date, assume that
|
|
||||||
# this is the most recent version of the image and also
|
|
||||||
# tag it 'latest'.
|
|
||||||
if [[ $VERSION =~ ^medley-[0-9]{1,6}.$ ]]; then
|
|
||||||
TAGS="$TAGS,${DOCKER_IMAGE}:latest"
|
|
||||||
fi
|
|
||||||
|
|
||||||
|
TAGS="${DOCKER_IMAGE}:${MEDLEY_RELEASE},${DOCKER_IMAGE}:${VERSION},${DOCKER_IMAGE}:${MAIKO_RELEASE}"
|
||||||
|
|
||||||
# Set output parameters.
|
# Set output parameters.
|
||||||
echo ::set-output name=tags::${TAGS}
|
echo ::set-output name=tags::${TAGS}
|
||||||
echo ::set-output name=docker_image::${DOCKER_IMAGE}
|
echo ::set-output name=docker_image::${DOCKER_IMAGE}
|
||||||
@@ -57,6 +60,15 @@ jobs:
|
|||||||
latest: true
|
latest: true
|
||||||
fileName: "*"
|
fileName: "*"
|
||||||
|
|
||||||
|
# Download Maiko Release Assets
|
||||||
|
- name: Download Release Assets
|
||||||
|
uses: robinraju/release-downloader@v1.2
|
||||||
|
with:
|
||||||
|
repository: Interlisp/maiko
|
||||||
|
token: ${{ secrets.GITHUB_TOKEN }}
|
||||||
|
latest: true
|
||||||
|
fileName: "*"
|
||||||
|
|
||||||
# Setup Docker Machine Emulation environment
|
# Setup Docker Machine Emulation environment
|
||||||
- name: Set up QEMU
|
- name: Set up QEMU
|
||||||
uses: docker/setup-qemu-action@master
|
uses: docker/setup-qemu-action@master
|
||||||
|
|||||||
43
.github/workflows/buildLoadup.yml
vendored
43
.github/workflows/buildLoadup.yml
vendored
@@ -27,24 +27,37 @@ jobs:
|
|||||||
- name: Checkout Medley
|
- name: Checkout Medley
|
||||||
uses: actions/checkout@v2
|
uses: actions/checkout@v2
|
||||||
|
|
||||||
- name: Get the latest Maiko Release
|
# Get Maiko release information, retrieves the name of the latest
|
||||||
uses: actions/checkout@v2
|
# release. Used to download the correct Maiko release
|
||||||
|
- name: Get Maiko Release Information
|
||||||
|
id: latest_version
|
||||||
|
uses: abatilo/release-info-action@v1.3.0
|
||||||
with:
|
with:
|
||||||
repository: interlisp/maiko
|
owner: Interlisp
|
||||||
path: maiko
|
repo: maiko
|
||||||
|
|
||||||
|
# Download Maiko Release Assets
|
||||||
|
- name: Download Release Assets
|
||||||
|
uses: robinraju/release-downloader@v1.2
|
||||||
|
with:
|
||||||
|
repository: Interlisp/maiko
|
||||||
|
token: ${{ secrets.GITHUB_TOKEN }}
|
||||||
|
latest: true
|
||||||
|
fileName: "${{ steps.latest_version.outputs.latest_tag }}-linux.x86_64.tgz"
|
||||||
|
|
||||||
- name: install compiler
|
- name: Untar Maiko Release
|
||||||
run: sudo apt-get update && sudo apt-get install -y make clang libx11-dev gcc x11vnc xvfb
|
run: |
|
||||||
|
tar -xvzf "${{ steps.latest_version.outputs.latest_tag }}-linux.x86_64.tgz"
|
||||||
|
|
||||||
- name: install vnc
|
- name: install vnc
|
||||||
run: sudo apt-get install -y tightvncserver
|
run: sudo apt-get update && sudo apt-get install -y tightvncserver
|
||||||
|
|
||||||
- name: Compile Maiko
|
|
||||||
working-directory: maiko/bin
|
|
||||||
run: ./makeright x && ./makeright init
|
|
||||||
|
|
||||||
- name: Build Loadout
|
- name: Build Loadout
|
||||||
run: pwd && Xvnc -once -geometry 1280x720 :0 & DISPLAY=:0 PATH="/maiko:$PATH" scripts/loadup-all.sh
|
run: |
|
||||||
|
Xvnc -geometry 1280x720 :0 &
|
||||||
|
export DISPLAY=":0"
|
||||||
|
PATH="$PWD/maiko:$PATH"
|
||||||
|
scripts/loadup-all.sh
|
||||||
|
|
||||||
- name: Build release tar get libs
|
- name: Build release tar get libs
|
||||||
run: |
|
run: |
|
||||||
@@ -66,7 +79,7 @@ jobs:
|
|||||||
--exclude "*~" --exclude "*#*" \
|
--exclude "*~" --exclude "*#*" \
|
||||||
medley/docs/dinfo \
|
medley/docs/dinfo \
|
||||||
medley/docs/Documentation\ Tools \
|
medley/docs/Documentation\ Tools \
|
||||||
medley/greetfiles/SIMPLE-INIT \
|
medley/greetfiles \
|
||||||
medley/run-medley \
|
medley/run-medley \
|
||||||
medley/scripts \
|
medley/scripts \
|
||||||
medley/fonts/displayfonts \
|
medley/fonts/displayfonts \
|
||||||
@@ -81,13 +94,13 @@ jobs:
|
|||||||
|
|
||||||
- name: Release notes
|
- name: Release notes
|
||||||
run: |
|
run: |
|
||||||
sed s/'$tag'/$tag/g < release-notes.md > tmp/release-notes.md &&
|
sed s/'$tag'/$tag/g < release-notes.md > tmp/release-notes.md
|
||||||
ls tmp && env
|
|
||||||
|
|
||||||
- name: push the release
|
- name: push the release
|
||||||
uses: ncipollo/release-action@v1.8.10
|
uses: ncipollo/release-action@v1.8.10
|
||||||
with:
|
with:
|
||||||
artifacts: tmp/${{ env.tag }}-loadups.tgz,tmp/${{ env.tag }}-runtime.tgz
|
artifacts: tmp/${{ env.tag }}-loadups.tgz,tmp/${{ env.tag }}-runtime.tgz
|
||||||
tag: ${{ env.tag }}
|
tag: ${{ env.tag }}
|
||||||
|
draft: true
|
||||||
bodyfile: tmp/release-notes.md
|
bodyfile: tmp/release-notes.md
|
||||||
token: ${{ secrets.GITHUB_TOKEN }}
|
token: ${{ secrets.GITHUB_TOKEN }}
|
||||||
@@ -1,10 +1,14 @@
|
|||||||
# How to build a medley release
|
# How to build a medley release
|
||||||
|
|
||||||
Originally done only with shell scripts:
|
Originally done only with shell scripts:
|
||||||
|
```
|
||||||
./scripts/loadup-all.sh
|
./scripts/loadup-all.sh
|
||||||
|
```
|
||||||
|
to make the loadups
|
||||||
|
```
|
||||||
./scripts/loadup-and-release.sh
|
./scripts/loadup-and-release.sh
|
||||||
|
```
|
||||||
|
to go on to make the tgz files and release them
|
||||||
|
|
||||||
# Using github actions
|
# Using github actions
|
||||||
|
|
||||||
|
|||||||
@@ -1,4 +1,4 @@
|
|||||||
FROM interlisp/maiko:latest
|
FROM ubuntu:focal
|
||||||
ARG BUILD_DATE
|
ARG BUILD_DATE
|
||||||
LABEL name="Medley"
|
LABEL name="Medley"
|
||||||
# LABEL tags=${tags}
|
# LABEL tags=${tags}
|
||||||
|
|||||||
29
README.md
29
README.md
@@ -125,16 +125,25 @@ files.
|
|||||||
|
|
||||||
Each directory should have a README.md, but briefly
|
Each directory should have a README.md, but briefly
|
||||||
|
|
||||||
- docs -- Documentation files (either PDFs or online help)
|
* BUILDING.md -- instructions on how to make your own loadups
|
||||||
- fonts -- raster fonts (or font widths) in various resolutions for display, postscript, interpress, press formats
|
* clos -- early implementation of Common Lisp Object System
|
||||||
- greetfiles -- various configuration setups
|
* CLTL2 -- files submitted to bring Medley up to the conformance to "Common Lisp, the Language" 2nd edition. Not enough to conform to the ANSII standard lisp.
|
||||||
- internal -- These _were_ internal to Venue; now internal/library and internal/test
|
* Dockerfile -- used when building Docker containers with Medley
|
||||||
- library -- packages that were supported (30 years ago)
|
* docs -- Documentation files (either PDFs or online help; see medley/wiki)
|
||||||
- lispusers -- packages that were only half supported (ditto)
|
* fonts -- raster fonts (or font widths) in various resolutions for display, postscript, interpress, press formats
|
||||||
- loadups -- has sysouts and other builds
|
* greetfiles -- various configuration setups
|
||||||
- scripts -- some scripts for fixing up things
|
* internal -- These _were_ internal to Venue; now internal/library and internal/test
|
||||||
- sources -- sources for Interlisp and Common Lisp implementations
|
* library -- packages that were supported (30 years ago)
|
||||||
- unicode -- data files for support of XCCS to and from Unicode mappings
|
* lispusers -- User contributed packages that were only half supported (ditto)
|
||||||
|
* loadups -- has sysouts and other builds plus a few remnants
|
||||||
|
* obsolete -- files we should remove from the repo
|
||||||
|
* rooms -- implementation of ROOMS window / desktop manager
|
||||||
|
* run-medley -- script to enhance the options of running medley
|
||||||
|
* scripts -- some scripts for fixing up things
|
||||||
|
* sources -- sources for Interlisp and Common Lisp implementations
|
||||||
|
* unicode -- data files for support of XCCS to and from Unicode mappings
|
||||||
|
|
||||||
plus
|
plus
|
||||||
Dockerfile, and scripts for building and running medley
|
Dockerfile, and scripts for building and running medley
|
||||||
|
tmp directory for use during build processes
|
||||||
|
|
||||||
|
|||||||
11
docs/README.md
Normal file
11
docs/README.md
Normal file
@@ -0,0 +1,11 @@
|
|||||||
|
This directory has:
|
||||||
|
|
||||||
|
* dinfo -- files for HelpSys man command Interlisp Reference Manual
|
||||||
|
* Documentation Tools -- should be moved into Library
|
||||||
|
|
||||||
|
* Various conversions of Medley legacy documentation
|
||||||
|
|
||||||
|
Needs to be cleaned up. Putting PDF files in the repo doesn't seem right;
|
||||||
|
we can make PS and PDF files as part of building a loadup
|
||||||
|
|
||||||
|
|
||||||
16
fonts/README.md
Normal file
16
fonts/README.md
Normal file
@@ -0,0 +1,16 @@
|
|||||||
|
# Fonts
|
||||||
|
|
||||||
|
These are a not-very-well curated directories of fonts.
|
||||||
|
|
||||||
|
"adobe" -- display versions of Postscript's fonts
|
||||||
|
palatino 8 9 10 12 14 18
|
||||||
|
"altofonts" -- random remnants of fonts used with Alto
|
||||||
|
"big" -- supposedly bigger fonts but turned out not (see #482)
|
||||||
|
"displayfonts" -- separated into directories by charset
|
||||||
|
"ipfonts" -- fonts (or font width information for Xeorx Interpress file format.
|
||||||
|
"other" -- random fonts associated with lispusers packages and not available elsewhere.
|
||||||
|
"postscriptfonts" -- fonts for postscript
|
||||||
|
"press" -- fonts for the older-than-interpress "press" format.
|
||||||
|
|
||||||
|
"xeroxprivate" -- ?? Seems like junk
|
||||||
|
|
||||||
60
greetfiles/MEDLEYDIR-INIT
Normal file
60
greetfiles/MEDLEYDIR-INIT
Normal file
@@ -0,0 +1,60 @@
|
|||||||
|
(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
|
||||||
|
|
||||||
|
changes to%: (VARS MEDLEYDIR-INITCOMS)
|
||||||
|
|
||||||
|
previous date%: "14-Nov-2021 22:10:37" {DSK}<home>larry>medley>greetfiles>medleydir-INIT.;1)
|
||||||
|
|
||||||
|
|
||||||
|
(PRETTYCOMPRINT MEDLEYDIR-INITCOMS)
|
||||||
|
|
||||||
|
(RPAQQ MEDLEYDIR-INITCOMS
|
||||||
|
((P (LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
|
||||||
|
"")
|
||||||
|
"/sources/MEDLEYDIR.LCOM")))
|
||||||
|
(FILES BACKGROUND-YIELD)
|
||||||
|
(VARS (FILING.ENUMERATION.DEPTH 1)
|
||||||
|
[LOGINDIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
|
||||||
|
(UNIX-GETENV "HOME"]
|
||||||
|
[USERGREETFILES `((,LOGINDIR "INIT" COM)
|
||||||
|
(,LOGINDIR "INIT"]
|
||||||
|
(COPYRIGHTSRESERVED NIL))
|
||||||
|
[P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
|
||||||
|
(FNS INTERLISPMODE)))
|
||||||
|
|
||||||
|
(LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
|
||||||
|
"")
|
||||||
|
"/sources/MEDLEYDIR.LCOM"))
|
||||||
|
|
||||||
|
(FILESLOAD BACKGROUND-YIELD)
|
||||||
|
|
||||||
|
(RPAQQ FILING.ENUMERATION.DEPTH 1)
|
||||||
|
|
||||||
|
(RPAQ LOGINDIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
|
||||||
|
(UNIX-GETENV "HOME"))))
|
||||||
|
|
||||||
|
(RPAQ USERGREETFILES `((,LOGINDIR "INIT" COM)
|
||||||
|
(,LOGINDIR "INIT")))
|
||||||
|
|
||||||
|
(RPAQQ COPYRIGHTSRESERVED NIL)
|
||||||
|
|
||||||
|
(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE))
|
||||||
|
(DEFINEQ
|
||||||
|
|
||||||
|
(INTERLISPMODE
|
||||||
|
[LAMBDA (OLD?) (* N.H.Briggs " 2-Feb-88 14:26")
|
||||||
|
(PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
|
||||||
|
then "OLD-INTERLISP-T"
|
||||||
|
else "INTERLISP")))
|
||||||
|
(XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
|
||||||
|
then "OLD-INTERLISP-T"
|
||||||
|
else "INTERLISP"))
|
||||||
|
(SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
|
||||||
|
then "OLD-INTERLISP-FILE"
|
||||||
|
else "INTERLISP")
|
||||||
|
:PACKAGE "INTERLISP"])
|
||||||
|
)
|
||||||
|
(DECLARE%: DONTCOPY
|
||||||
|
(FILEMAP (NIL (1455 2280 (INTERLISPMODE 1465 . 2278)))))
|
||||||
|
STOP
|
||||||
BIN
greetfiles/MEDLEYDIR-INIT.LCOM
Normal file
BIN
greetfiles/MEDLEYDIR-INIT.LCOM
Normal file
Binary file not shown.
10
greetfiles/README.md
Normal file
10
greetfiles/README.md
Normal file
@@ -0,0 +1,10 @@
|
|||||||
|
# medley/greetfiles
|
||||||
|
|
||||||
|
This directory is somewhat vestigal -- it originally was used to hold 'initialization' files for everyone. Medley repo has only two:
|
||||||
|
|
||||||
|
NOGREET -- file to set as "system init" when doing loadups that don't want any personalization.
|
||||||
|
|
||||||
|
SIMPLE-INIT -- system init for git-directory relative directory structure.
|
||||||
|
Contains INTERLISPMODE.
|
||||||
|
|
||||||
|
|
||||||
@@ -1,4 +0,0 @@
|
|||||||
lldb ../../maiko/darwin.386/ldeinit
|
|
||||||
|
|
||||||
break set -n error
|
|
||||||
run ./INIT.DLINIT -INIT -NF
|
|
||||||
@@ -1,13 +1,12 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||||
|
|
||||||
(FILECREATED "16-Oct-2021 15:04:31"
|
(FILECREATED "23-Nov-2021 12:17:08"
|
||||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;13| 261677
|
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>FILEBROWSER.;21| 261024
|
||||||
|
|
||||||
|changes| |to:| (VARS FILEBROWSERCOMS)
|
|changes| |to:| (FNS FB.FIX-DIRECTORY-DATES)
|
||||||
(FNS FB.GETWINDOW FB.SET.BROWSER.TITLE FB.DATE)
|
|
||||||
|
|
||||||
|previous| |date:| "19-Sep-2021 18:08:05"
|
|previous| |date:| "29-Oct-2021 21:19:42"
|
||||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>FILEBROWSER.;10|)
|
|{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>FILEBROWSER.;20|)
|
||||||
|
|
||||||
|
|
||||||
; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation.
|
; Copyright (c) 1983-1991, 1993-1994, 1999-2001, 2021 by Venue & Xerox Corporation.
|
||||||
@@ -180,8 +179,7 @@ You specify how many versions to keep.")))
|
|||||||
(* \; "Setup")
|
(* \; "Setup")
|
||||||
(FNS FB.STARTUP FB.MAKERIGIDWINDOW)
|
(FNS FB.STARTUP FB.MAKERIGIDWINDOW)
|
||||||
(FNS FB.PRINTFN FB.COPYFN))
|
(FNS FB.PRINTFN FB.COPYFN))
|
||||||
(COMS (* \;
|
(COMS (* \; "commands and major subfunctions")
|
||||||
"commands and major subfunctions")
|
|
||||||
(FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY
|
(FNS FB.MENU.WHENSELECTEDFN FB.COMMANDSELECTEDFN FB.SUBITEMP FB.MAKE.BROWSER.BUSY
|
||||||
FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON)
|
FB.FINISH.COMMAND FB.HANDLE.ABORT.BUTTON)
|
||||||
(FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES
|
(FNS FB.DELETECOMMAND FB.DELVERCOMMAND FB.IS.NOT.SUBDIRECTORY.ITEM FB.DELVER.FILES
|
||||||
@@ -293,9 +291,9 @@ You specify how many versions to keep.")))
|
|||||||
(RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))
|
(RPAQ? FB.DEFAULT.INFO '(SIZE CREATIONDATE AUTHOR))
|
||||||
|
|
||||||
(APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT)
|
(APPENDTOVAR FONTVARS (FB.ICONFONT LITTLEFONT)
|
||||||
(FB.BROWSERFONT DEFAULTFONT)
|
(FB.BROWSERFONT DEFAULTFONT)
|
||||||
(FB.PROMPTFONT LITTLEFONT)
|
(FB.PROMPTFONT LITTLEFONT)
|
||||||
(FB.BROWSER.DIRECTORY.FONT BOLDFONT))
|
(FB.BROWSER.DIRECTORY.FONT BOLDFONT))
|
||||||
|
|
||||||
|
|
||||||
(* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.")
|
(* |;;| "FONTSET fills in the variables in FONTVARS for us, so do it.")
|
||||||
@@ -396,27 +394,25 @@ You specify how many versions to keep.")))
|
|||||||
))
|
))
|
||||||
|
|
||||||
(RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files")
|
(RPAQQ FB.VERSION.MENU.ITEMS (("1" 1 "Keep only one version of the files")
|
||||||
("2" 2 "Keep two versions of the files")
|
("2" 2 "Keep two versions of the files")
|
||||||
("3" 3 "Keep three versions of the files")
|
("3" 3 "Keep three versions of the files")
|
||||||
("4" 4 "Keep four versions of the files")
|
("4" 4 "Keep four versions of the files")
|
||||||
("Other" :NUMBER "Select number of versions to keep")))
|
("Other" :NUMBER "Select number of versions to keep")))
|
||||||
|
|
||||||
(RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE
|
(RPAQQ FB.CLOSE.MENU.ITEMS (("Expunge deleted files" 'EXPUNGE
|
||||||
"Erases all files still marked 'deleted'")
|
"Erases all files still marked 'deleted'")
|
||||||
("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files.
|
("Don't expunge" 'NOEXPUNGE "Proceeds (closes or updates browser) without expunging deleted files.
|
||||||
Your deletions are thus ignored.")))
|
Your deletions are thus ignored.")))
|
||||||
|
|
||||||
(RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL
|
(RPAQQ FB.DEPTH.MENU.ITEMS (("Global default" :GLOBAL
|
||||||
"Set depth using the global default (FILING.ENUMERATION.DEPTH)"
|
"Set depth using the global default (FILING.ENUMERATION.DEPTH)")
|
||||||
)
|
("Infinite" T
|
||||||
("Infinite" T
|
"Set depth to infinity, i.e., enumerate all levels of directory")
|
||||||
"Set depth to infinity, i.e., enumerate all levels of directory"
|
("1" 1
|
||||||
)
|
|
||||||
("1" 1
|
|
||||||
"Set depth to 1, i.e., enumerate just the top level of the directory"
|
"Set depth to 1, i.e., enumerate just the top level of the directory"
|
||||||
)
|
)
|
||||||
("2" 2 "Set depth to 2")
|
("2" 2 "Set depth to 2")
|
||||||
("Other" :NUMBER "Set depth to some other finite depth")))
|
("Other" :NUMBER "Set depth to some other finite depth")))
|
||||||
|
|
||||||
(RPAQQ FB.INFO.MENU.ITEMS
|
(RPAQQ FB.INFO.MENU.ITEMS
|
||||||
((|Length| LENGTH "Toggles Length display")
|
((|Length| LENGTH "Toggles Length display")
|
||||||
@@ -458,20 +454,21 @@ Your deletions are thus ignored.")))
|
|||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(FB
|
(FB
|
||||||
(NLAMBDA PATTERN (* \; "Edited 26-Feb-88 13:50 by bvm")
|
(NLAMBDA PATTERN (* \; "Edited 29-Oct-2021 21:18 by rmk:")
|
||||||
|
(* \; "Edited 26-Feb-88 13:50 by bvm")
|
||||||
|
|
||||||
(* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...")
|
(* |;;;| "FILEBROWSER entry from top-level exec: FB PATTERN ... PROPS ...")
|
||||||
|
|
||||||
(DESTRUCTURING-BIND (PAT . PROPS)
|
(DESTRUCTURING-BIND (PAT . PROPS)
|
||||||
(NLAMBDA.ARGS PATTERN)
|
(NLAMBDA.ARGS PATTERN)
|
||||||
(LET (OPTIONS)
|
(LET (OPTIONS)
|
||||||
(|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL))
|
(|for| TAIL |on| PROPS |when| (AND (CL:KEYWORDP (CAR TAIL))
|
||||||
(CDR TAIL))
|
(CDR TAIL))
|
||||||
|do| (* \;
|
|do| (* \;
|
||||||
"Interpret keyword tail of attributes as OPTIONS.")
|
"Interpret keyword tail of attributes as OPTIONS.")
|
||||||
(RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL)))))
|
(RETURN (SETQ PROPS (LDIFF PROPS (SETQ OPTIONS TAIL)))))
|
||||||
(ADD.PROCESS `(,(FUNCTION FILEBROWSER)
|
(ADD.PROCESS `(,(FUNCTION FILEBROWSER)
|
||||||
',PAT
|
',(OR PAT '*)
|
||||||
',PROPS
|
',PROPS
|
||||||
',OPTIONS)
|
',OPTIONS)
|
||||||
'NAME
|
'NAME
|
||||||
@@ -2061,13 +2058,18 @@ Your deletions are thus ignored.")))
|
|||||||
(FB.UPDATEBROWSERITEMS BROWSER)))))
|
(FB.UPDATEBROWSERITEMS BROWSER)))))
|
||||||
|
|
||||||
(FB.FIX-DIRECTORY-DATES
|
(FB.FIX-DIRECTORY-DATES
|
||||||
(LAMBDA (BROWSER) (* \; "Edited 21-Aug-2021 23:33 by rmk:")
|
(LAMBDA (BROWSER) (* \; "Edited 23-Nov-2021 12:15 by rmk:")
|
||||||
|
(* \; "Edited 21-Aug-2021 23:33 by rmk:")
|
||||||
|
|
||||||
|
(* |;;|
|
||||||
|
"FILEDATE returns the source-file date of a compiled file. We have to call with CFLG T to be sure.")
|
||||||
|
|
||||||
(FOR F FD CHANGE IN (FILDIR (FETCH (FILEBROWSER PATTERN) OF BROWSER))
|
(FOR F FD CHANGE IN (FILDIR (FETCH (FILEBROWSER PATTERN) OF BROWSER))
|
||||||
WHEN (SETQ FD (FILEDATE F)) UNLESS (IEQP (SETQ FD (IDATE FD))
|
WHEN (SETQ FD (OR (FILEDATE F T)
|
||||||
(GETFILEINFO F 'ICREATIONDATE))
|
(FILEDATE F))) UNLESS (IEQP (SETQ FD (IDATE FD))
|
||||||
|
(GETFILEINFO F 'ICREATIONDATE))
|
||||||
DO (SETQ CHANGE T)
|
DO (SETQ CHANGE T)
|
||||||
(SETFILEINFO F 'ICREATIONDATE FD) FINALLY (CL:WHEN CHANGE (FB.UPDATECOMMAND
|
(SETFILEINFO F 'ICREATIONDATE FD) FINALLY (CL:WHEN CHANGE (FB.UPDATECOMMAND BROWSER)))))
|
||||||
BROWSER)))))
|
|
||||||
|
|
||||||
(FB.MAYBE.EXPUNGE
|
(FB.MAYBE.EXPUNGE
|
||||||
(LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:")
|
(LAMBDA (BROWSER COMMAND) (* \; "Edited 22-Feb-2021 12:33 by rmk:")
|
||||||
@@ -3821,120 +3823,117 @@ then click Recompute"))))
|
|||||||
|
|
||||||
(RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE))
|
(RECORD INFOFIELD (INFONAME INFOLABEL INFOWIDTH INFOFORMAT INFOPROTOTYPE))
|
||||||
|
|
||||||
(DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file")
|
(DATATYPE FBFILEDATA ((FILENAME POINTER) (* \; "Full name of this file")
|
||||||
(FILEINFO POINTER) (* \; "Plist of attributes")
|
(FILEINFO POINTER) (* \; "Plist of attributes")
|
||||||
(VERSIONLESSNAME POINTER) (* \; "FILENAME sans version")
|
(VERSIONLESSNAME POINTER) (* \; "FILENAME sans version")
|
||||||
(DIRECTORYP FLAG) (* \; "True if it's a directory line")
|
(DIRECTORYP FLAG) (* \; "True if it's a directory line")
|
||||||
(HASDIRPREFIX FLAG) (* \;
|
(HASDIRPREFIX FLAG) (* \;
|
||||||
"True if it has a directory prefix beyond that in common to all the files")
|
"True if it has a directory prefix beyond that in common to all the files")
|
||||||
(DIRECTORYFILEP FLAG) (* \;
|
(DIRECTORYFILEP FLAG) (* \;
|
||||||
"True if the \"file\" in this item is actually a subdirectory")
|
"True if the \"file\" in this item is actually a subdirectory")
|
||||||
(SIZE POINTER) (* \; "Size of file, for stats")
|
(SIZE POINTER) (* \; "Size of file, for stats")
|
||||||
(FILEDEPTH BYTE) (* \;
|
(FILEDEPTH BYTE) (* \;
|
||||||
"Number of levels of subdirectory beneath the main pattern--zero for files at that level")
|
"Number of levels of subdirectory beneath the main pattern--zero for files at that level")
|
||||||
(SORTVALUE POINTER) (* \;
|
(SORTVALUE POINTER) (* \;
|
||||||
"Cached value by which we are sorting the dir.")
|
"Cached value by which we are sorting the dir.")
|
||||||
(SUBDIREND WORD) (* \;
|
(SUBDIREND WORD) (* \;
|
||||||
"Index of last char in subdirectory, or zero if HASDIRPREFIX is false")
|
"Index of last char in subdirectory, or zero if HASDIRPREFIX is false")
|
||||||
(STARTOFPNAME WORD) (* \;
|
(STARTOFPNAME WORD) (* \;
|
||||||
"Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name")
|
"Start of name for printing purposes. Same as STARTOFNAME when browser sorted by name")
|
||||||
(VERSION WORD) (* \; "Version, or zero if none")
|
(VERSION WORD) (* \; "Version, or zero if none")
|
||||||
(STARTOFNAME WORD) (* \;
|
(STARTOFNAME WORD) (* \;
|
||||||
"Index beyond all directory fields")
|
"Index beyond all directory fields")
|
||||||
DUMMY)
|
DUMMY)
|
||||||
(ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME
|
(ACCESSFNS FBFILEDATA ((PRINTNAME (SUBSTRING (FETCH (FBFILEDATA FILENAME)
|
||||||
)
|
OF DATUM)
|
||||||
OF DATUM)
|
(FETCH (FBFILEDATA STARTOFPNAME)
|
||||||
(FETCH (FBFILEDATA STARTOFPNAME
|
OF DATUM)))
|
||||||
) OF DATUM)))
|
(SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA FILENAME)
|
||||||
(SUBDIRECTORY (SUBSTRING (FETCH (FBFILEDATA
|
OF DATUM)
|
||||||
FILENAME)
|
1
|
||||||
OF DATUM)
|
(FETCH (FBFILEDATA SUBDIREND)
|
||||||
1
|
OF DATUM))))))
|
||||||
(FETCH (FBFILEDATA SUBDIREND
|
|
||||||
) OF
|
|
||||||
DATUM))))))
|
|
||||||
|
|
||||||
(DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;
|
(DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG) (* \;
|
||||||
"True if we don't want separate subdirectory lines -- subdirs then included in name")
|
"True if we don't want separate subdirectory lines -- subdirs then included in name")
|
||||||
(NSPATTERN? FLAG) (* \; "True if host is an ns host")
|
(NSPATTERN? FLAG) (* \; "True if host is an ns host")
|
||||||
(SHOWUNDELETED? FLAG) (* \;
|
(SHOWUNDELETED? FLAG) (* \;
|
||||||
"True if counter window should show `Undeleted' rather than `Total' counts")
|
"True if counter window should show `Undeleted' rather than `Total' counts")
|
||||||
(PATTERNPARSED? FLAG) (* \;
|
(PATTERNPARSED? FLAG) (* \;
|
||||||
"True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid")
|
"True if PREPAREDPATTERN, NAMESTART, DIRECTORYSTART are valid")
|
||||||
(SORTBYDATE FLAG) (* \;
|
(SORTBYDATE FLAG) (* \;
|
||||||
"True if SORTATTRIBUTE is one of the date attributes")
|
"True if SORTATTRIBUTE is one of the date attributes")
|
||||||
(FBREADY FLAG) (* \; "False while FB is enumerating.")
|
(FBREADY FLAG) (* \; "False while FB is enumerating.")
|
||||||
(ABORTING FLAG) (* \;
|
(ABORTING FLAG) (* \;
|
||||||
"True if enumeration is being aborted")
|
"True if enumeration is being aborted")
|
||||||
(FIXEDTITLE FLAG) (* \; "True if caller supplied title")
|
(FIXEDTITLE FLAG) (* \; "True if caller supplied title")
|
||||||
(FBCOMPUTEDDEPTH BYTE) (* \;
|
(FBCOMPUTEDDEPTH BYTE) (* \;
|
||||||
"Depth at the time we enumerated directory (zero for infinite)")
|
"Depth at the time we enumerated directory (zero for infinite)")
|
||||||
(FBDISPLAYEDDEPTH BYTE) (* \;
|
(FBDISPLAYEDDEPTH BYTE) (* \;
|
||||||
"Depth we are currently displaying (zero for infinite)")
|
"Depth we are currently displaying (zero for infinite)")
|
||||||
(TABLEBROWSER POINTER) (* \;
|
(TABLEBROWSER POINTER) (* \;
|
||||||
"Pointer to TABLEBROWSER object controlling the browser")
|
"Pointer to TABLEBROWSER object controlling the browser")
|
||||||
(BROWSERWINDOW POINTER) (* \; "Main window")
|
(BROWSERWINDOW POINTER) (* \; "Main window")
|
||||||
(COUNTERWINDOW POINTER) (* \;
|
(COUNTERWINDOW POINTER) (* \;
|
||||||
"Window that counts files, pages, deletions")
|
"Window that counts files, pages, deletions")
|
||||||
(HEADINGWINDOW POINTER) (* \;
|
(HEADINGWINDOW POINTER) (* \;
|
||||||
"Window with headings for browser columns")
|
"Window with headings for browser columns")
|
||||||
(INFOMENUW POINTER) (* \;
|
(INFOMENUW POINTER) (* \;
|
||||||
"Window containing choices for info to be displayed, or NIL if none yet")
|
"Window containing choices for info to be displayed, or NIL if none yet")
|
||||||
(PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW")
|
(PROMPTWINDOW POINTER) (* \; "GETPROMPTWINDOW BROWSERWINDOW")
|
||||||
(INFODISPLAYED POINTER) (* \;
|
(INFODISPLAYED POINTER) (* \;
|
||||||
"List of attribute specs to be displayed")
|
"List of attribute specs to be displayed")
|
||||||
(PATTERN POINTER) (* \;
|
(PATTERN POINTER) (* \;
|
||||||
"Directory pattern being enumerated")
|
"Directory pattern being enumerated")
|
||||||
(PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same")
|
(PREPAREDPATTERN POINTER) (* \; "DIRECTORY.MATCH.SETUP of same")
|
||||||
(SEEWINDOW POINTER) (* \;
|
(SEEWINDOW POINTER) (* \;
|
||||||
"Primary window used by FAST SEE command")
|
"Primary window used by FAST SEE command")
|
||||||
(BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW")
|
(BROWSERFONT POINTER) (* \; "Font of BROWSERWINDOW")
|
||||||
(SORTBY POINTER) (* \;
|
(SORTBY POINTER) (* \;
|
||||||
"Sorting function or NIL for default sort")
|
"Sorting function or NIL for default sort")
|
||||||
(NAMESTART WORD) (* \;
|
(NAMESTART WORD) (* \;
|
||||||
"Index of first character in file name beyond the common prefix shared by all")
|
"Index of first character in file name beyond the common prefix shared by all")
|
||||||
(DIRECTORYSTART WORD) (* \;
|
(DIRECTORYSTART WORD) (* \;
|
||||||
"Index of first character of directory in file names")
|
"Index of first character of directory in file names")
|
||||||
(INFOSTART WORD) (* \;
|
(INFOSTART WORD) (* \;
|
||||||
"X position in browser where first col of info is displayed")
|
"X position in browser where first col of info is displayed")
|
||||||
(NAMEOVERHEAD WORD) (* \;
|
(NAMEOVERHEAD WORD) (* \;
|
||||||
"This plus width of name gives is how much to allow before INFOSTART")
|
"This plus width of name gives is how much to allow before INFOSTART")
|
||||||
(OVERFLOWSPACING WORD) (* \;
|
(OVERFLOWSPACING WORD) (* \;
|
||||||
"Increment between sizes considered for INFOSTART")
|
"Increment between sizes considered for INFOSTART")
|
||||||
(DIGITWIDTH WORD)
|
(DIGITWIDTH WORD)
|
||||||
(TOTALFILES WORD) (* \;
|
(TOTALFILES WORD) (* \;
|
||||||
"Total number of files, deleted files, pages, deleted pages at the moment")
|
"Total number of files, deleted files, pages, deleted pages at the moment")
|
||||||
(DELETEDFILES WORD)
|
(DELETEDFILES WORD)
|
||||||
(TOTALPAGES POINTER)
|
(TOTALPAGES POINTER)
|
||||||
(DELETEDPAGES POINTER)
|
(DELETEDPAGES POINTER)
|
||||||
(PAGECOUNT? POINTER) (* \;
|
(PAGECOUNT? POINTER) (* \;
|
||||||
"True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages")
|
"True if INFOCHOICES includes SIZE or LENGTH, so that we can count pages")
|
||||||
(COUNTERPOSITIONS POINTER) (* \;
|
(COUNTERPOSITIONS POINTER) (* \;
|
||||||
"List of pairs (left right) describing regions where the values of the counters are displayed")
|
"List of pairs (left right) describing regions where the values of the counters are displayed")
|
||||||
(COUNTERPAGESTRING POINTER) (* \;
|
(COUNTERPAGESTRING POINTER) (* \;
|
||||||
"String to print after file/page count")
|
"String to print after file/page count")
|
||||||
(OVERFLOWWIDTHS POINTER) (* \;
|
(OVERFLOWWIDTHS POINTER) (* \;
|
||||||
"List of (xpos occurrences) describing files whose names exceed default INFOSTART")
|
"List of (xpos occurrences) describing files whose names exceed default INFOSTART")
|
||||||
(INFOMENUCHOICES POINTER) (* \;
|
(INFOMENUCHOICES POINTER) (* \;
|
||||||
"Selections user has made in Info window, not necessarily the info currently displayed")
|
"Selections user has made in Info window, not necessarily the info currently displayed")
|
||||||
(UPDATEPROC POINTER) (* \;
|
(UPDATEPROC POINTER) (* \;
|
||||||
"Process doing an Update (Recompute)")
|
"Process doing an Update (Recompute)")
|
||||||
(DEFAULTDIR POINTER) (* \;
|
(DEFAULTDIR POINTER) (* \;
|
||||||
"Default directory for destination of Copy/Rename")
|
"Default directory for destination of Copy/Rename")
|
||||||
(SORTATTRIBUTE POINTER) (* \;
|
(SORTATTRIBUTE POINTER) (* \;
|
||||||
"Attribute being sorted on, or NIL if by name")
|
"Attribute being sorted on, or NIL if by name")
|
||||||
(SORTMENU POINTER)
|
(SORTMENU POINTER)
|
||||||
(FBLOCK POINTER) (* \;
|
(FBLOCK POINTER) (* \;
|
||||||
"Lock acquired by filebrowser operations")
|
"Lock acquired by filebrowser operations")
|
||||||
(SORTINDEX WORD) (* \;
|
(SORTINDEX WORD) (* \;
|
||||||
"Index (zero-based) in file info of the sort attribute")
|
"Index (zero-based) in file info of the sort attribute")
|
||||||
(SIZEINDEX WORD) (* \; "Index of size attribute")
|
(SIZEINDEX WORD) (* \; "Index of size attribute")
|
||||||
(FBDEPTH POINTER) (* \;
|
(FBDEPTH POINTER) (* \;
|
||||||
"Enumeration depth, or NIL for default")
|
"Enumeration depth, or NIL for default")
|
||||||
(ABORTWINDOW POINTER) (* \;
|
(ABORTWINDOW POINTER) (* \;
|
||||||
"Dotted pair of (abortwindow . menuw) for this browser's abort window.")
|
"Dotted pair of (abortwindow . menuw) for this browser's abort window.")
|
||||||
DUMMY))
|
DUMMY))
|
||||||
)
|
)
|
||||||
|
|
||||||
(/DECLAREDATATYPE 'FBFILEDATA
|
(/DECLAREDATATYPE 'FBFILEDATA
|
||||||
@@ -4022,25 +4021,24 @@ then click Recompute"))))
|
|||||||
(DECLARE\: EVAL@COMPILE
|
(DECLARE\: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS NULL.VERSIONP MACRO ((V)
|
(PUTPROPS NULL.VERSIONP MACRO ((V)
|
||||||
(EQ V 0)))
|
(EQ V 0)))
|
||||||
|
|
||||||
(PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA)
|
(PUTPROPS NULL.DIRECTORYP MACRO ((FILEDATA)
|
||||||
(EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA)
|
(EQ (FETCH (FBFILEDATA SUBDIREND) OF FILEDATA)
|
||||||
0)))
|
0)))
|
||||||
|
|
||||||
(PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2)
|
(PUTPROPS EQ.DIRECTORYP MACRO (OPENLAMBDA (FD1 FD2)
|
||||||
(STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of|
|
(STRING-EQUAL (|fetch| (FBFILEDATA FILENAME) |of| FD1)
|
||||||
FD1)
|
(|fetch| (FBFILEDATA FILENAME) |of| FD2)
|
||||||
(|fetch| (FBFILEDATA FILENAME) |of| FD2)
|
:END1
|
||||||
:END1
|
(|fetch| (FBFILEDATA SUBDIREND) |of| FD1)
|
||||||
(|fetch| (FBFILEDATA SUBDIREND) |of| FD1)
|
:END2
|
||||||
:END2
|
(|fetch| (FBFILEDATA SUBDIREND) |of| FD2))))
|
||||||
(|fetch| (FBFILEDATA SUBDIREND) |of| FD2))))
|
|
||||||
|
|
||||||
(PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR)
|
(PUTPROPS NULL.FIELDP MACRO (OPENLAMBDA (STR)
|
||||||
(OR (NULL STR)
|
(OR (NULL STR)
|
||||||
(EQ (NCHARS STR)
|
(EQ (NCHARS STR)
|
||||||
0))))
|
0))))
|
||||||
)
|
)
|
||||||
|
|
||||||
(DECLARE\: DOEVAL@COMPILE DONTCOPY
|
(DECLARE\: DOEVAL@COMPILE DONTCOPY
|
||||||
@@ -4133,67 +4131,67 @@ then click Recompute"))))
|
|||||||
(ADDTOVAR SYSTEMRECLST
|
(ADDTOVAR SYSTEMRECLST
|
||||||
|
|
||||||
(DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG)
|
(DATATYPE FILEBROWSER ((NOSUBDIRECTORIES FLAG)
|
||||||
(NSPATTERN? FLAG)
|
(NSPATTERN? FLAG)
|
||||||
(SHOWUNDELETED? FLAG)
|
(SHOWUNDELETED? FLAG)
|
||||||
(PATTERNPARSED? FLAG)
|
(PATTERNPARSED? FLAG)
|
||||||
(SORTBYDATE FLAG)
|
(SORTBYDATE FLAG)
|
||||||
(FBREADY FLAG)
|
(FBREADY FLAG)
|
||||||
(ABORTING FLAG)
|
(ABORTING FLAG)
|
||||||
(FIXEDTITLE FLAG)
|
(FIXEDTITLE FLAG)
|
||||||
(FBCOMPUTEDDEPTH BYTE)
|
(FBCOMPUTEDDEPTH BYTE)
|
||||||
(FBDISPLAYEDDEPTH BYTE)
|
(FBDISPLAYEDDEPTH BYTE)
|
||||||
(TABLEBROWSER POINTER)
|
(TABLEBROWSER POINTER)
|
||||||
(BROWSERWINDOW POINTER)
|
(BROWSERWINDOW POINTER)
|
||||||
(COUNTERWINDOW POINTER)
|
(COUNTERWINDOW POINTER)
|
||||||
(HEADINGWINDOW POINTER)
|
(HEADINGWINDOW POINTER)
|
||||||
(INFOMENUW POINTER)
|
(INFOMENUW POINTER)
|
||||||
(PROMPTWINDOW POINTER)
|
(PROMPTWINDOW POINTER)
|
||||||
(INFODISPLAYED POINTER)
|
(INFODISPLAYED POINTER)
|
||||||
(PATTERN POINTER)
|
(PATTERN POINTER)
|
||||||
(PREPAREDPATTERN POINTER)
|
(PREPAREDPATTERN POINTER)
|
||||||
(SEEWINDOW POINTER)
|
(SEEWINDOW POINTER)
|
||||||
(BROWSERFONT POINTER)
|
(BROWSERFONT POINTER)
|
||||||
(SORTBY POINTER)
|
(SORTBY POINTER)
|
||||||
(NAMESTART WORD)
|
(NAMESTART WORD)
|
||||||
(DIRECTORYSTART WORD)
|
(DIRECTORYSTART WORD)
|
||||||
(INFOSTART WORD)
|
(INFOSTART WORD)
|
||||||
(NAMEOVERHEAD WORD)
|
(NAMEOVERHEAD WORD)
|
||||||
(OVERFLOWSPACING WORD)
|
(OVERFLOWSPACING WORD)
|
||||||
(DIGITWIDTH WORD)
|
(DIGITWIDTH WORD)
|
||||||
(TOTALFILES WORD)
|
(TOTALFILES WORD)
|
||||||
(DELETEDFILES WORD)
|
(DELETEDFILES WORD)
|
||||||
(TOTALPAGES POINTER)
|
(TOTALPAGES POINTER)
|
||||||
(DELETEDPAGES POINTER)
|
(DELETEDPAGES POINTER)
|
||||||
(PAGECOUNT? POINTER)
|
(PAGECOUNT? POINTER)
|
||||||
(COUNTERPOSITIONS POINTER)
|
(COUNTERPOSITIONS POINTER)
|
||||||
(COUNTERPAGESTRING POINTER)
|
(COUNTERPAGESTRING POINTER)
|
||||||
(OVERFLOWWIDTHS POINTER)
|
(OVERFLOWWIDTHS POINTER)
|
||||||
(INFOMENUCHOICES POINTER)
|
(INFOMENUCHOICES POINTER)
|
||||||
(UPDATEPROC POINTER)
|
(UPDATEPROC POINTER)
|
||||||
(DEFAULTDIR POINTER)
|
(DEFAULTDIR POINTER)
|
||||||
(SORTATTRIBUTE POINTER)
|
(SORTATTRIBUTE POINTER)
|
||||||
(SORTMENU POINTER)
|
(SORTMENU POINTER)
|
||||||
(FBLOCK POINTER)
|
(FBLOCK POINTER)
|
||||||
(SORTINDEX WORD)
|
(SORTINDEX WORD)
|
||||||
(SIZEINDEX WORD)
|
(SIZEINDEX WORD)
|
||||||
(FBDEPTH POINTER)
|
(FBDEPTH POINTER)
|
||||||
(ABORTWINDOW POINTER)
|
(ABORTWINDOW POINTER)
|
||||||
DUMMY))
|
DUMMY))
|
||||||
|
|
||||||
(DATATYPE FBFILEDATA ((FILENAME POINTER)
|
(DATATYPE FBFILEDATA ((FILENAME POINTER)
|
||||||
(FILEINFO POINTER)
|
(FILEINFO POINTER)
|
||||||
(VERSIONLESSNAME POINTER)
|
(VERSIONLESSNAME POINTER)
|
||||||
(DIRECTORYP FLAG)
|
(DIRECTORYP FLAG)
|
||||||
(HASDIRPREFIX FLAG)
|
(HASDIRPREFIX FLAG)
|
||||||
(DIRECTORYFILEP FLAG)
|
(DIRECTORYFILEP FLAG)
|
||||||
(SIZE POINTER)
|
(SIZE POINTER)
|
||||||
(FILEDEPTH BYTE)
|
(FILEDEPTH BYTE)
|
||||||
(SORTVALUE POINTER)
|
(SORTVALUE POINTER)
|
||||||
(SUBDIREND WORD)
|
(SUBDIREND WORD)
|
||||||
(STARTOFPNAME WORD)
|
(STARTOFPNAME WORD)
|
||||||
(VERSION WORD)
|
(VERSION WORD)
|
||||||
(STARTOFNAME WORD)
|
(STARTOFNAME WORD)
|
||||||
DUMMY))
|
DUMMY))
|
||||||
)
|
)
|
||||||
(DECLARE\: DONTEVAL@LOAD DOCOPY
|
(DECLARE\: DONTEVAL@LOAD DOCOPY
|
||||||
|
|
||||||
@@ -4201,10 +4199,10 @@ then click Recompute"))))
|
|||||||
|
|
||||||
|
|
||||||
(ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW)
|
(ADDTOVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (HARDCOPYIMAGEW.TOFILE . HARDCOPYIMAGEW)
|
||||||
(HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW))
|
(HARDCOPYIMAGEW.TOPRINTER . HARDCOPYIMAGEW))
|
||||||
|
|
||||||
(ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER)
|
(ADDTOVAR |BackgroundMenuCommands| ("FileBrowser" '(FILEBROWSER)
|
||||||
"Opens a filebrowser window; prompts for pattern"))
|
"Opens a filebrowser window; prompts for pattern"))
|
||||||
|
|
||||||
|
|
||||||
(RPAQQ |BackgroundMenu| NIL)
|
(RPAQQ |BackgroundMenu| NIL)
|
||||||
@@ -4220,51 +4218,51 @@ then click Recompute"))))
|
|||||||
(PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
(PUTPROPS FILEBROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990
|
||||||
1991 1993 1994 1999 2000 2001 2021))
|
1991 1993 1994 1999 2000 2001 2021))
|
||||||
(DECLARE\: DONTCOPY
|
(DECLARE\: DONTCOPY
|
||||||
(FILEMAP (NIL (28719 51355 (FB 28729 . 29685) (FB.COPYBINARYCOMMAND 29687 . 30033) (FB.COPYTEXTCOMMAND
|
(FILEMAP (NIL (28447 51200 (FB 28457 . 29530) (FB.COPYBINARYCOMMAND 29532 . 29878) (FB.COPYTEXTCOMMAND
|
||||||
30035 . 30377) (FILEBROWSER 30379 . 43485) (FB.TABLEBROWSER 43487 . 43704) (FB.SELECTEDFILES 43706 .
|
29880 . 30222) (FILEBROWSER 30224 . 43330) (FB.TABLEBROWSER 43332 . 43549) (FB.SELECTEDFILES 43551 .
|
||||||
44343) (FB.FETCHFILENAME 44345 . 44737) (FB.DIRECTORYP 44739 . 45067) (FB.PROMPTWPRINT 45069 . 46115)
|
44188) (FB.FETCHFILENAME 44190 . 44582) (FB.DIRECTORYP 44584 . 44912) (FB.PROMPTWPRINT 44914 . 45960)
|
||||||
(FB.PROMPTW.FORMAT 46117 . 46854) (FB.PROMPTFORINPUT 46856 . 49108) (FB.YES-OR-NO-P 49110 . 50144) (
|
(FB.PROMPTW.FORMAT 45962 . 46699) (FB.PROMPTFORINPUT 46701 . 48953) (FB.YES-OR-NO-P 48955 . 49989) (
|
||||||
FB.ALLOW.ABORT 50146 . 51000) (\\FB.HARDCOPY.TOFILE.EXTENSION 51002 . 51353)) (51379 52332 (FB.STARTUP
|
FB.ALLOW.ABORT 49991 . 50845) (\\FB.HARDCOPY.TOFILE.EXTENSION 50847 . 51198)) (51224 52177 (FB.STARTUP
|
||||||
51389 . 51904) (FB.MAKERIGIDWINDOW 51906 . 52330)) (52333 57705 (FB.PRINTFN 52343 . 57496) (FB.COPYFN
|
51234 . 51749) (FB.MAKERIGIDWINDOW 51751 . 52175)) (52178 57550 (FB.PRINTFN 52188 . 57341) (FB.COPYFN
|
||||||
57498 . 57703)) (57755 63797 (FB.MENU.WHENSELECTEDFN 57765 . 58123) (FB.COMMANDSELECTEDFN 58125 .
|
57343 . 57548)) (57600 63642 (FB.MENU.WHENSELECTEDFN 57610 . 57968) (FB.COMMANDSELECTEDFN 57970 .
|
||||||
59664) (FB.SUBITEMP 59666 . 60101) (FB.MAKE.BROWSER.BUSY 60103 . 60841) (FB.FINISH.COMMAND 60843 .
|
59509) (FB.SUBITEMP 59511 . 59946) (FB.MAKE.BROWSER.BUSY 59948 . 60686) (FB.FINISH.COMMAND 60688 .
|
||||||
62808) (FB.HANDLE.ABORT.BUTTON 62810 . 63795)) (63798 69314 (FB.DELETECOMMAND 63808 . 64089) (
|
62653) (FB.HANDLE.ABORT.BUTTON 62655 . 63640)) (63643 69159 (FB.DELETECOMMAND 63653 . 63934) (
|
||||||
FB.DELVERCOMMAND 64091 . 67284) (FB.IS.NOT.SUBDIRECTORY.ITEM 67286 . 67467) (FB.DELVER.FILES 67469 .
|
FB.DELVERCOMMAND 63936 . 67129) (FB.IS.NOT.SUBDIRECTORY.ITEM 67131 . 67312) (FB.DELVER.FILES 67314 .
|
||||||
68558) (FB.DELETE.FILE 68560 . 69312)) (69315 70640 (FB.UNDELETECOMMAND 69325 . 69610) (
|
68403) (FB.DELETE.FILE 68405 . 69157)) (69160 70485 (FB.UNDELETECOMMAND 69170 . 69455) (
|
||||||
FB.UNDELETEALLCOMMAND 69612 . 69891) (FB.UNDELETE.FILE 69893 . 70638)) (70641 94822 (FB.COPYCOMMAND
|
FB.UNDELETEALLCOMMAND 69457 . 69736) (FB.UNDELETE.FILE 69738 . 70483)) (70486 94667 (FB.COPYCOMMAND
|
||||||
70651 . 70920) (FB.RENAMECOMMAND 70922 . 71197) (FB.COPY/RENAME.COMMAND 71199 . 72122) (
|
70496 . 70765) (FB.RENAMECOMMAND 70767 . 71042) (FB.COPY/RENAME.COMMAND 71044 . 71967) (
|
||||||
FB.COPY/RENAME.ONE 72124 . 74446) (FB.COPY/RENAME.MANY 74448 . 80668) (FB.MERGE.DIRECTORIES 80670 .
|
FB.COPY/RENAME.ONE 71969 . 74291) (FB.COPY/RENAME.MANY 74293 . 80513) (FB.MERGE.DIRECTORIES 80515 .
|
||||||
81088) (FB.GREATEST.PREFIX 81090 . 82446) (FB.MAYBE.INSERT.FILE 82448 . 89888) (FB.GET.NEW.FILE.SPEC
|
80933) (FB.GREATEST.PREFIX 80935 . 82291) (FB.MAYBE.INSERT.FILE 82293 . 89733) (FB.GET.NEW.FILE.SPEC
|
||||||
89890 . 93721) (FB.CANONICAL.DIRECTORY 93723 . 94820)) (94823 102607 (FB.HARDCOPYCOMMAND 94833 . 95963
|
89735 . 93566) (FB.CANONICAL.DIRECTORY 93568 . 94665)) (94668 102452 (FB.HARDCOPYCOMMAND 94678 . 95808
|
||||||
) (FB.HARDCOPY.TOFILE 95965 . 102605)) (102608 112485 (FB.EDITCOMMAND 102618 . 103419) (
|
) (FB.HARDCOPY.TOFILE 95810 . 102450)) (102453 112330 (FB.EDITCOMMAND 102463 . 103264) (
|
||||||
FB.EDITCOMMAND.ONEFILE 103421 . 106701) (FB.EDITLISPFILE 106703 . 107742) (FB.BROWSECOMMAND 107744 .
|
FB.EDITCOMMAND.ONEFILE 103266 . 106546) (FB.EDITLISPFILE 106548 . 107587) (FB.BROWSECOMMAND 107589 .
|
||||||
112483)) (112486 124279 (FB.FASTSEECOMMAND 112496 . 115946) (FB.FASTSEE.ONEFILE 115948 . 118977) (
|
112328)) (112331 124124 (FB.FASTSEECOMMAND 112341 . 115791) (FB.FASTSEE.ONEFILE 115793 . 118822) (
|
||||||
FB.SEEFULLFN 118979 . 123110) (FB.SEEBUTTONFN 123112 . 124277)) (124280 126026 (FB.LOADCOMMAND 124290
|
FB.SEEFULLFN 118824 . 122955) (FB.SEEBUTTONFN 122957 . 124122)) (124125 125871 (FB.LOADCOMMAND 124135
|
||||||
. 124797) (FB.COMPILECOMMAND 124799 . 125337) (FB.OPERATE.ON.FILES 125339 . 126024)) (126027 173598 (
|
. 124642) (FB.COMPILECOMMAND 124644 . 125182) (FB.OPERATE.ON.FILES 125184 . 125869)) (125872 173645 (
|
||||||
FB.UPDATECOMMAND 126037 . 126262) (FB.FIX-DIRECTORY-DATES 126264 . 126871) (FB.MAYBE.EXPUNGE 126873 .
|
FB.UPDATECOMMAND 125882 . 126107) (FB.FIX-DIRECTORY-DATES 126109 . 126918) (FB.MAYBE.EXPUNGE 126920 .
|
||||||
127868) (FB.UPDATEBROWSERITEMS 127870 . 141085) (FB.DATE 141087 . 141662) (FB.ADJUST.DATE.WIDTH 141664
|
127915) (FB.UPDATEBROWSERITEMS 127917 . 141132) (FB.DATE 141134 . 141709) (FB.ADJUST.DATE.WIDTH 141711
|
||||||
. 144632) (FB.SET.BROWSER.TITLE 144634 . 145570) (FB.MAYBE.WIDEN.NAMES 145572 . 147691) (
|
. 144679) (FB.SET.BROWSER.TITLE 144681 . 145617) (FB.MAYBE.WIDEN.NAMES 145619 . 147738) (
|
||||||
FB.SET.DEFAULT.NAME.WIDTH 147693 . 149057) (FB.CREATE.FILEBUCKET 149059 . 156279) (
|
FB.SET.DEFAULT.NAME.WIDTH 147740 . 149104) (FB.CREATE.FILEBUCKET 149106 . 156326) (
|
||||||
FB.CHECK.NAME.LENGTH 156281 . 158702) (FB.ADD.FILEGROUP 158704 . 160231) (FB.INSERT.DIRECTORY 160233
|
FB.CHECK.NAME.LENGTH 156328 . 158749) (FB.ADD.FILEGROUP 158751 . 160278) (FB.INSERT.DIRECTORY 160280
|
||||||
. 160471) (FB.MAKE.SUBDIRECTORY.ITEM 160473 . 161882) (FB.ADD.FILE 161884 . 162497) (FB.INSERT.FILE
|
. 160518) (FB.MAKE.SUBDIRECTORY.ITEM 160520 . 161929) (FB.ADD.FILE 161931 . 162544) (FB.INSERT.FILE
|
||||||
162499 . 165911) (FB.ANALYZE.PATTERN 165913 . 171177) (FB.CANONICALIZE.PATTERN 171179 . 172491) (
|
162546 . 165958) (FB.ANALYZE.PATTERN 165960 . 171224) (FB.CANONICALIZE.PATTERN 171226 . 172538) (
|
||||||
FB.GETALLFILEINFO 172493 . 173596)) (173599 181758 (FB.SORT.VERSIONS 173609 . 176380) (
|
FB.GETALLFILEINFO 172540 . 173643)) (173646 181805 (FB.SORT.VERSIONS 173656 . 176427) (
|
||||||
FB.DECREASING.VERSION 176382 . 177051) (FB.INCREASING.VERSION 177053 . 177674) (
|
FB.DECREASING.VERSION 176429 . 177098) (FB.INCREASING.VERSION 177100 . 177721) (
|
||||||
FB.NAMES.DECREASING.VERSION 177676 . 178711) (FB.NAMES.INCREASING.VERSION 178713 . 179710) (
|
FB.NAMES.DECREASING.VERSION 177723 . 178758) (FB.NAMES.INCREASING.VERSION 178760 . 179757) (
|
||||||
FB.DECREASING.NUMERIC.ATTR 179712 . 180392) (FB.INCREASING.NUMERIC.ATTR 180394 . 181068) (
|
FB.DECREASING.NUMERIC.ATTR 179759 . 180439) (FB.INCREASING.NUMERIC.ATTR 180441 . 181115) (
|
||||||
FB.ALPHABETIC.ATTR 181070 . 181756)) (181759 191601 (FB.SORTCOMMAND 181769 . 188599) (
|
FB.ALPHABETIC.ATTR 181117 . 181803)) (181806 191648 (FB.SORTCOMMAND 181816 . 188646) (
|
||||||
FB.INSERT.SUBDIRECTORIES 188601 . 189398) (FB.GET.SORT.MENU 189400 . 191599)) (191602 207691 (
|
FB.INSERT.SUBDIRECTORIES 188648 . 189445) (FB.GET.SORT.MENU 189447 . 191646)) (191649 207738 (
|
||||||
FB.EXPUNGECOMMAND 191612 . 194131) (FB.NEWPATTERNCOMMAND 194133 . 194531) (FB.NEWINFOCOMMAND 194533 .
|
FB.EXPUNGECOMMAND 191659 . 194178) (FB.NEWPATTERNCOMMAND 194180 . 194578) (FB.NEWINFOCOMMAND 194580 .
|
||||||
197299) (FB.DEPTHCOMMAND 197301 . 199076) (FB.SHAPECOMMAND 199078 . 202420) (FB.REMOVE.FILE 202422 .
|
197346) (FB.DEPTHCOMMAND 197348 . 199123) (FB.SHAPECOMMAND 199125 . 202467) (FB.REMOVE.FILE 202469 .
|
||||||
204243) (FB.COUNT.FILE.CHANGE 204245 . 205690) (FB.SETNEWPATTERN 205692 . 206862) (FB.GET.NEWPATTERN
|
204290) (FB.COUNT.FILE.CHANGE 204292 . 205737) (FB.SETNEWPATTERN 205739 . 206909) (FB.GET.NEWPATTERN
|
||||||
206864 . 207448) (FB.OPTIONSCOMMAND 207450 . 207689)) (207726 208713 (FB.GETWINDOW 207736 . 208711)) (
|
206911 . 207495) (FB.OPTIONSCOMMAND 207497 . 207736)) (207773 208760 (FB.GETWINDOW 207783 . 208758)) (
|
||||||
208714 209726 (FB.INFOMENU.SHADEINITIALSELECTIONS 208724 . 209371) (FB.INFO.ITEM.NAMED 209373 . 209724
|
208761 209773 (FB.INFOMENU.SHADEINITIALSELECTIONS 208771 . 209418) (FB.INFO.ITEM.NAMED 209420 . 209771
|
||||||
)) (209727 219193 (FB.MAKECOUNTERWINDOW 209737 . 211199) (FB.COUNTERW.REDISPLAYFN 211201 . 211788) (
|
)) (209774 219240 (FB.MAKECOUNTERWINDOW 209784 . 211246) (FB.COUNTERW.REDISPLAYFN 211248 . 211835) (
|
||||||
FB.UPDATE.COUNTERS 211790 . 213862) (FB.DISPLAY.COUNTERS 213864 . 218924) (FB.COUNTER.STRING 218926 .
|
FB.UPDATE.COUNTERS 211837 . 213909) (FB.DISPLAY.COUNTERS 213911 . 218971) (FB.COUNTER.STRING 218973 .
|
||||||
219191)) (219194 223837 (FB.MAKEHEADINGWINDOW 219204 . 220752) (FB.HEADINGW.REDISPLAYFN 220754 .
|
219238)) (219241 223884 (FB.MAKEHEADINGWINDOW 219251 . 220799) (FB.HEADINGW.REDISPLAYFN 220801 .
|
||||||
221020) (FB.HEADINGW.RESHAPEFN 221022 . 221398) (FB.HEADINGW.DISPLAY 221400 . 223835)) (223838 228021
|
221067) (FB.HEADINGW.RESHAPEFN 221069 . 221445) (FB.HEADINGW.DISPLAY 221447 . 223882)) (223885 228068
|
||||||
(FB.ICONFN 223848 . 224195) (FB.INFOMENU.WHENSELECTEDFN 224197 . 224927) (FB.CLOSEFN 224929 . 226132)
|
(FB.ICONFN 223895 . 224242) (FB.INFOMENU.WHENSELECTEDFN 224244 . 224974) (FB.CLOSEFN 224976 . 226179)
|
||||||
(FB.EXPUNGE?.MENU 226134 . 226546) (FB.AFTERCLOSEFN 226548 . 226909) (FB.CLOSE&EXPUNGE 226911 . 228019
|
(FB.EXPUNGE?.MENU 226181 . 226593) (FB.AFTERCLOSEFN 226595 . 226956) (FB.CLOSE&EXPUNGE 226958 . 228066
|
||||||
)) (228022 240080 (FB.HARDCOPY.DIRECTORY 228032 . 238389) (FB.HARDCOPY.PRINT.TITLE 238391 . 238717) (
|
)) (228069 240127 (FB.HARDCOPY.DIRECTORY 228079 . 238436) (FB.HARDCOPY.PRINT.TITLE 238438 . 238764) (
|
||||||
FB.HARDCOPY.MAXWIDTH 238719 . 240078)))))
|
FB.HARDCOPY.MAXWIDTH 238766 . 240125)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,11 +1,12 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(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"
|
changes to%: (FNS \TEXTMENU.START)
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;4)
|
|
||||||
|
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))
|
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
|
||||||
(FILES (LOADCOMP)
|
(FILES (LOADCOMP)
|
||||||
TEDITDCL))
|
TEDITDCL))
|
||||||
[COMS (* ; "Simple Menu Button support")
|
[COMS (* ; "Simple Menu Button support")
|
||||||
(FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN
|
(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
|
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
|
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))
|
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT))
|
||||||
(ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN]
|
(ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN]
|
||||||
[COMS
|
[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
|
(FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN
|
||||||
MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT)
|
MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT)
|
||||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (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
|
(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.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS
|
||||||
MB.NWAYBUTTON.ADDITEM)
|
MB.NWAYBUTTON.ADDITEM)
|
||||||
@@ -45,7 +46,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
|||||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT))
|
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT))
|
||||||
(ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN]
|
(ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN]
|
||||||
[COMS
|
[COMS
|
||||||
(* ;; "Two-state, toggling menu buttons.")
|
(* ;; "Two-state, toggling menu buttons.")
|
||||||
|
|
||||||
(FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN
|
(FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN
|
||||||
\TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT
|
\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))
|
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT))
|
||||||
(ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN]
|
(ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN]
|
||||||
[COMS
|
[COMS
|
||||||
(* ;; "Margin Setting and display")
|
(* ;; "Margin Setting and display")
|
||||||
|
|
||||||
(FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN
|
(FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN
|
||||||
MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK
|
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))
|
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT))
|
||||||
(ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN]
|
(ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN]
|
||||||
(COMS
|
(COMS
|
||||||
(* ;; "Text menu creation and support")
|
(* ;; "Text menu creation and support")
|
||||||
|
|
||||||
(FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN)
|
(FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN)
|
||||||
(BITMAPS TEXTMENUICON TEXTMENUICONMASK))
|
(BITMAPS TEXTMENUICON TEXTMENUICONMASK))
|
||||||
[COMS (* ; "TEdit-specific support")
|
[COMS (* ; "TEdit-specific support")
|
||||||
(FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN
|
(FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN
|
||||||
\TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN)
|
\TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN)
|
||||||
(FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS
|
(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)
|
\TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS)
|
||||||
(FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING
|
(FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING
|
||||||
TEDIT.UNPARSE.PAGEFORMAT)
|
TEDIT.UNPARSE.PAGEFORMAT)
|
||||||
(COMS (* ; "Initialization Code")
|
(COMS (* ; "Initialization Code")
|
||||||
(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU
|
(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU
|
||||||
TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC
|
TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC
|
||||||
TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU)
|
TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU)
|
||||||
@@ -2067,11 +2068,14 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
|||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(\TEXTMENU.START
|
(\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")
|
"Edited 4-Jun-93 11:59 by sybalsky:mv:envos")
|
||||||
|
|
||||||
(* ;; "Create a TEdit-based menu for a given main window.")
|
(* ;; "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
|
(PROG ([WREG (COND
|
||||||
(MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION))
|
(MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION))
|
||||||
(T (GETREGION]
|
(T (GETREGION]
|
||||||
@@ -2104,6 +2108,9 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
|
|||||||
(* ;
|
(* ;
|
||||||
"Mark this as a TEDIT MENU window")
|
"Mark this as a TEDIT MENU window")
|
||||||
(ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE)
|
(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)
|
(SETQ MENUTEXT MENU)
|
||||||
(replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
|
(replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
|
||||||
with T)
|
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) (
|
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.DISPLAYFN 101126 . 103811) (MDESCALE 103813 . 104252) (MSCALE 104254 . 104588) (
|
||||||
MB.MARGINBAR.SHOWTAB 104590 . 106761) (MB.MARGINBAR.TABTRACK 106763 . 108098) (\TEDIT.TABTYPE.SET
|
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) (
|
108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130838 (\TEXTMENU.START 112725 . 116438) (
|
||||||
\TEXTMENU.DOC.CREATE 115919 . 127443) (TEXTMENU.CLOSEFN 127445 . 130315)) (130627 150691 (
|
\TEXTMENU.DOC.CREATE 116440 . 127964) (TEXTMENU.CLOSEFN 127966 . 130836)) (131148 151212 (
|
||||||
\TEDITMENU.CREATE 130637 . 130937) (\TEDIT.EXPANDED.MENU 130939 . 131643) (MB.DEFAULTBUTTON.FN 131645
|
\TEDITMENU.CREATE 131158 . 131458) (\TEDIT.EXPANDED.MENU 131460 . 132164) (MB.DEFAULTBUTTON.FN 132166
|
||||||
. 134517) (\TEDITMENU.RECORD.UNFORMATTED 134519 . 134857) (MB.DEFAULTBUTTON.ACTIONFN 134859 . 150689)
|
. 135038) (\TEDITMENU.RECORD.UNFORMATTED 135040 . 135378) (MB.DEFAULTBUTTON.ACTIONFN 135380 . 151210)
|
||||||
) (150692 178075 (\TEDIT.CHARLOOKSMENU.CREATE 150702 . 152842) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152844
|
) (151213 178596 (\TEDIT.CHARLOOKSMENU.CREATE 151223 . 153363) (\TEDIT.EXPANDEDCHARLOOKS.MENU 153365
|
||||||
. 153218) (\TEDIT.APPLY.BOLDNESS 153220 . 153505) (\TEDIT.APPLY.CHARLOOKS 153507 . 155438) (
|
. 153739) (\TEDIT.APPLY.BOLDNESS 153741 . 154026) (\TEDIT.APPLY.CHARLOOKS 154028 . 155959) (
|
||||||
\TEDIT.APPLY.OLINE 155440 . 155721) (\TEDIT.SHOW.CHARLOOKS 155723 . 157636) (
|
\TEDIT.APPLY.OLINE 155961 . 156242) (\TEDIT.SHOW.CHARLOOKS 156244 . 158157) (
|
||||||
\TEDIT.NEUTRALIZE.CHARLOOKS 157638 . 158564) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158566 . 166219) (
|
\TEDIT.NEUTRALIZE.CHARLOOKS 158159 . 159085) (\TEDIT.FILL.IN.CHARLOOKS.MENU 159087 . 166740) (
|
||||||
\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166221 . 169104) (\TEDIT.PARSE.CHARLOOKS.MENU 169106 . 177214) (
|
\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166742 . 169625) (\TEDIT.PARSE.CHARLOOKS.MENU 169627 . 177735) (
|
||||||
\TEDIT.APPLY.SLOPE 177216 . 177499) (\TEDIT.APPLY.STRIKEOUT 177501 . 177788) (\TEDIT.APPLY.ULINE
|
\TEDIT.APPLY.SLOPE 177737 . 178020) (\TEDIT.APPLY.STRIKEOUT 178022 . 178309) (\TEDIT.APPLY.ULINE
|
||||||
177790 . 178073)) (178076 210142 (\TEDITPARAMENU.CREATE 178086 . 178466) (\TEDIT.EXPANDEDPARA.MENU
|
178311 . 178594)) (178597 210663 (\TEDITPARAMENU.CREATE 178607 . 178987) (\TEDIT.EXPANDEDPARA.MENU
|
||||||
178468 . 178788) (\TEDIT.APPLY.PARALOOKS 178790 . 191020) (\TEDIT.SHOW.PARALOOKS 191022 . 202549) (
|
178989 . 179309) (\TEDIT.APPLY.PARALOOKS 179311 . 191541) (\TEDIT.SHOW.PARALOOKS 191543 . 203070) (
|
||||||
\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202551 . 208622) (\TEDIT.RECORD.TABLEADERS 208624 . 210140)) (210143
|
\TEDIT.NEUTRALIZE.PARALOOKS.MENU 203072 . 209143) (\TEDIT.RECORD.TABLEADERS 209145 . 210661)) (210664
|
||||||
248145 (\TEDIT.SHOW.PAGEFORMATTING 210153 . 226693) (\TEDITPAGEMENU.CREATE 226695 . 227738) (
|
248666 (\TEDIT.SHOW.PAGEFORMATTING 210674 . 227214) (\TEDITPAGEMENU.CREATE 227216 . 228259) (
|
||||||
\TEDIT.APPLY.PAGEFORMATTING 227740 . 240111) (TEDIT.UNPARSE.PAGEFORMAT 240113 . 248143)) (248450
|
\TEDIT.APPLY.PAGEFORMATTING 228261 . 240632) (TEDIT.UNPARSE.PAGEFORMAT 240634 . 248664)) (248971
|
||||||
275299 (\TEDIT.MENU.INIT 248460 . 275297)))))
|
275820 (\TEDIT.MENU.INIT 248981 . 275818)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,10 +1,10 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED "20-Sep-2021 11:37:28" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;3 1644
|
|
||||||
|
|
||||||
changes to%: (FNS BACKGROUND-YIELD)
|
(FILECREATED "14-Nov-2021 22:05:58" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;2 1597
|
||||||
(VARS BACKGROUND-YIELDCOMS)
|
|
||||||
|
|
||||||
previous date%: "19-Sep-2021 13:37:10" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;1)
|
changes to%: (VARS BACKGROUND-YIELD)
|
||||||
|
|
||||||
|
previous date%: "20-Sep-2021 11:37:28" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;1)
|
||||||
|
|
||||||
|
|
||||||
(PRETTYCOMPRINT BACKGROUND-YIELDCOMS)
|
(PRETTYCOMPRINT BACKGROUND-YIELDCOMS)
|
||||||
@@ -44,7 +44,7 @@
|
|||||||
(INIT-YIELD T)
|
(INIT-YIELD T)
|
||||||
)
|
)
|
||||||
|
|
||||||
(RPAQQ BACKGROUND-YIELD 8333330)
|
(RPAQQ BACKGROUND-YIELD 833333)
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (879 1528 (BACKGROUND-YIELD 889 . 1144) (INIT-YIELD 1146 . 1526)))))
|
(FILEMAP (NIL (833 1482 (BACKGROUND-YIELD 843 . 1098) (INIT-YIELD 1100 . 1480)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,15 +1,16 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(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"
|
changes to%: (FNS DINFO.CREATE.FMENU)
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;4)
|
|
||||||
|
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)
|
(PRETTYCOMPRINT DINFOCOMS)
|
||||||
@@ -19,24 +20,24 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
|
|||||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DINFOGRAPH DINFONODE)
|
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DINFOGRAPH DINFONODE)
|
||||||
(FUNCTIONS DINFOGRAPHPROP))
|
(FUNCTIONS DINFOGRAPHPROP))
|
||||||
(INITRECORDS DINFOGRAPH)
|
(INITRECORDS DINFOGRAPH)
|
||||||
(FNS (* ; "Primary functions")
|
(FNS (* ; "Primary functions")
|
||||||
DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH
|
DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH
|
||||||
DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP)
|
DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP)
|
||||||
(FNS (* ; "Koto compatability")
|
(FNS (* ; "Koto compatability")
|
||||||
DINFO.READ.KOTO.GRAPH)
|
DINFO.READ.KOTO.GRAPH)
|
||||||
(FNS (* ; "Window functions")
|
(FNS (* ; "Window functions")
|
||||||
DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN)
|
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.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER
|
||||||
DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY
|
DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY
|
||||||
DINFO.TOGGLE.TEXT)
|
DINFO.TOGGLE.TEXT)
|
||||||
(FNS (* ; "Other menu functions")
|
(FNS (* ; "Other menu functions")
|
||||||
DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY
|
DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY
|
||||||
DINFO.HISTORIC.UPDATE)
|
DINFO.HISTORIC.UPDATE)
|
||||||
(FNS (* ; "Interface to GRAPHER")
|
(FNS (* ; "Interface to GRAPHER")
|
||||||
DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW
|
DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW
|
||||||
DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH)
|
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.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL
|
||||||
DINFO.GET.FILENAME)
|
DINFO.GET.FILENAME)
|
||||||
(ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH)
|
(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.UPDATE.FMENU GRAPH])
|
||||||
|
|
||||||
(DINFO.CREATE.FMENU
|
(DINFO.CREATE.FMENU
|
||||||
[LAMBDA (GRAPH) (* jow "15-Jul-86 17:39")
|
[LAMBDA (GRAPH) (* ; "Edited 25-Oct-2021 23:23 by rmk:")
|
||||||
|
(* jow "15-Jul-86 17:39")
|
||||||
(* * Makes a DInfo FreeMenu for GRAPH)
|
|
||||||
|
(* ;;; "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))
|
(LET* [(ADD.ITEMS (fetch (DINFOGRAPH FREEMENUITEMS) of GRAPH))
|
||||||
(FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH))
|
(FONT (OR (FONTP (fetch (DINFOGRAPH MENUFONT) of GRAPH))
|
||||||
MENUFONT))
|
MENUFONT))
|
||||||
(FM (FREEMENU `((PROPS FONT %, FONT)
|
[FM (FREEMENU `((PROPS FONT %, FONT)
|
||||||
((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10))
|
((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10))
|
||||||
(ID NODE LABEL "" TYPE DISPLAY))
|
(ID NODE LABEL "" TYPE DISPLAY))
|
||||||
((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD)
|
((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)
|
(HELVETICA 10 BOLD)
|
||||||
MESSAGE
|
MESSAGE
|
||||||
"Lookup a term in this graph. LEFT for new term, MIDDLE to repeat last."
|
"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 'FM.DONTRESHAPE T)
|
||||||
|
(WINDOWPROP FM 'MINSIZE (CONS 0 HEIGHT))
|
||||||
|
(WINDOWPROP FM 'MAXSIZE (CONS 64000 HEIGHT))
|
||||||
FM])
|
FM])
|
||||||
|
|
||||||
(DINFO.FMW.CLOSEFN
|
(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))
|
(PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987 2020 2021))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (7732 24558 (DINFO 7742 . 9356) (DINFO.UPDATE 9358 . 12222) (DINFOGRAPH 12224 . 12642) (
|
(FILEMAP (NIL (7733 24559 (DINFO 7743 . 9357) (DINFO.UPDATE 9359 . 12223) (DINFOGRAPH 12225 . 12643) (
|
||||||
DINFO.SPECIAL.UPDATE 12644 . 14342) (DINFO.READ.GRAPH 14344 . 16199) (DINFO.WRITE.GRAPH 16201 . 17291)
|
DINFO.SPECIAL.UPDATE 12645 . 14343) (DINFO.READ.GRAPH 14345 . 16200) (DINFO.WRITE.GRAPH 16202 . 17292)
|
||||||
(DINFO.SELECT.GRAPH 17293 . 18200) (DINFO.DEFAULT.MENU 18202 . 20726) (DINFO.FIND 20728 . 23112) (
|
(DINFO.SELECT.GRAPH 17294 . 18201) (DINFO.DEFAULT.MENU 18203 . 20727) (DINFO.FIND 20729 . 23113) (
|
||||||
DINFO.LOOKUP 23114 . 24556)) (24559 27253 (DINFO.READ.KOTO.GRAPH 24569 . 27251)) (27254 29568 (
|
DINFO.LOOKUP 23115 . 24557)) (24560 27254 (DINFO.READ.KOTO.GRAPH 24570 . 27252)) (27255 29569 (
|
||||||
DINFO.SETUP.WINDOW 27264 . 27945) (DINFO.CLOSEFN 27947 . 28380) (DINFO.SHRINKFN 28382 . 28578) (
|
DINFO.SETUP.WINDOW 27265 . 27946) (DINFO.CLOSEFN 27948 . 28381) (DINFO.SHRINKFN 28383 . 28579) (
|
||||||
DINFO.EXPANDFN 28580 . 29137) (DINFO.ICONFN 29139 . 29566)) (29569 40417 (DINFO.ADD.FMENU 29579 .
|
DINFO.EXPANDFN 28581 . 29138) (DINFO.ICONFN 29140 . 29567)) (29570 40830 (DINFO.ADD.FMENU 29580 .
|
||||||
30674) (DINFO.CREATE.FMENU 30676 . 34213) (DINFO.FMW.CLOSEFN 34215 . 35060) (DINFO.FMENU.HANDLER 35062
|
30675) (DINFO.CREATE.FMENU 30677 . 34626) (DINFO.FMW.CLOSEFN 34628 . 35473) (DINFO.FMENU.HANDLER 35475
|
||||||
. 35701) (DINFO.UPDATE.FMENU 35703 . 37908) (DINFO.TOGGLE.MENU 37910 . 38500) (DINFO.TOGGLE.GRAPH
|
. 36114) (DINFO.UPDATE.FMENU 36116 . 38321) (DINFO.TOGGLE.MENU 38323 . 38913) (DINFO.TOGGLE.GRAPH
|
||||||
38502 . 39001) (DINFO.TOGGLE.HISTORY 39003 . 39547) (DINFO.TOGGLE.TEXT 39549 . 40415)) (40418 48116 (
|
38915 . 39414) (DINFO.TOGGLE.HISTORY 39416 . 39960) (DINFO.TOGGLE.TEXT 39962 . 40828)) (40831 48529 (
|
||||||
DINFO.UPDATE.MENU.DISPLAY 40428 . 44448) (DINFO.UPDATE.FROM.MENU 44450 . 44749) (DINFO.UPDATE.HISTORY
|
DINFO.UPDATE.MENU.DISPLAY 40841 . 44861) (DINFO.UPDATE.FROM.MENU 44863 . 45162) (DINFO.UPDATE.HISTORY
|
||||||
44751 . 47285) (DINFO.HISTORIC.UPDATE 47287 . 48114)) (48117 58283 (DINFO.UPDATE.GRAPH.DISPLAY 48127
|
45164 . 47698) (DINFO.HISTORIC.UPDATE 47700 . 48527)) (48530 58696 (DINFO.UPDATE.GRAPH.DISPLAY 48540
|
||||||
. 49445) (DINFO.UPDATE.FROM.GRAPH 49447 . 49890) (DINFO.GET.GRAPH.WINDOW 49892 . 50477) (
|
. 49858) (DINFO.UPDATE.FROM.GRAPH 49860 . 50303) (DINFO.GET.GRAPH.WINDOW 50305 . 50890) (
|
||||||
DINFO.CREATE.GRAPH.WINDOW 50479 . 51596) (DINFO.SHOWGRAPH 51598 . 53323) (DINFO.INVERT.NODE 53325 .
|
DINFO.CREATE.GRAPH.WINDOW 50892 . 52009) (DINFO.SHOWGRAPH 52011 . 53736) (DINFO.INVERT.NODE 53738 .
|
||||||
54713) (DINFO.LAYOUTGRAPH 54715 . 58281)) (58284 64140 (DINFO.UPDATE.TEXT.DISPLAY 58294 . 60155) (
|
55126) (DINFO.LAYOUTGRAPH 55128 . 58694)) (58697 64553 (DINFO.UPDATE.TEXT.DISPLAY 58707 . 60568) (
|
||||||
DINFO.TITLEMENUFN 60157 . 61282) (DINFO.OPENTEXTSTREAM 61284 . 62500) (DINFO.SHOWSEL 62502 . 63235) (
|
DINFO.TITLEMENUFN 60570 . 61695) (DINFO.OPENTEXTSTREAM 61697 . 62913) (DINFO.SHOWSEL 62915 . 63648) (
|
||||||
DINFO.GET.FILENAME 63237 . 64138)))))
|
DINFO.GET.FILENAME 63650 . 64551)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
3
lispusers/MIGRATION/DIR.TXT
Normal file
3
lispusers/MIGRATION/DIR.TXT
Normal file
@@ -0,0 +1,3 @@
|
|||||||
|
Contains a tool for translating File Manger format Interlisp source
|
||||||
|
files from Medley into Common Lisp text files. The software runs in
|
||||||
|
the Medley system.
|
||||||
116
lispusers/MIGRATION/FILEPKGRECORDS
Normal file
116
lispusers/MIGRATION/FILEPKGRECORDS
Normal file
@@ -0,0 +1,116 @@
|
|||||||
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
|
|
||||||
|
(* "
|
||||||
|
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||||
|
The following program was created in 1982 but has not been published
|
||||||
|
within the meaning of the copyright law, is furnished under license,
|
||||||
|
and may not be used, copied and/or disclosed except in accordance
|
||||||
|
with the terms of said license.
|
||||||
|
")
|
||||||
|
|
||||||
|
(PRETTYCOMPRINT FILEPKGRECORDSCOMS)
|
||||||
|
|
||||||
|
(RPAQQ FILEPKGRECORDSCOMS
|
||||||
|
[(COMS (* ;
|
||||||
|
"standard records for accessing file package type/command parts. Exported for PRETTY")
|
||||||
|
(RECORDS * FILEPKGRECORDS)])
|
||||||
|
|
||||||
|
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
|
||||||
|
|
||||||
|
(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
|
||||||
|
(UNDOABLE (COND
|
||||||
|
(NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
|
||||||
|
(T (/REMPROP DATUM 'ADDTOPRETTYCOM]
|
||||||
|
[DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
|
||||||
|
(UNDOABLE (COND
|
||||||
|
(NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
|
||||||
|
(T (/REMPROP DATUM 'DELFROMPRETTYCOM]
|
||||||
|
[PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
|
||||||
|
(UNDOABLE (COND
|
||||||
|
(NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
|
||||||
|
(T (/REMPROP DATUM 'PRETTYTYPE]
|
||||||
|
[CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
|
||||||
|
(UNDOABLE (COND
|
||||||
|
(NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
|
||||||
|
(T (/REMPROP DATUM 'FILEPKGCONTENTS]
|
||||||
|
(MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
|
||||||
|
(STANDARD [COND
|
||||||
|
[NEWVALUE (PUTASSOC DATUM NEWVALUE
|
||||||
|
(OR (LISTP (GETTOPVAL
|
||||||
|
'PRETTYDEFMACROS))
|
||||||
|
(SETTOPVAL 'PRETTYDEFMACROS
|
||||||
|
(LIST (LIST DATUM]
|
||||||
|
(T (SETTOPVAL 'PRETTYDEFMACROS
|
||||||
|
(REMOVE (FASSOC DATUM (GETTOPVAL
|
||||||
|
'PRETTYDEFMACROS))
|
||||||
|
(GETTOPVAL 'PRETTYDEFMACROS]
|
||||||
|
UNDOABLE
|
||||||
|
(COND
|
||||||
|
[NEWVALUE (/PUTASSOC DATUM NEWVALUE
|
||||||
|
(OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
|
||||||
|
(/SETTOPVAL 'PRETTYDEFMACROS
|
||||||
|
(LIST (LIST DATUM]
|
||||||
|
(T (/SETTOPVAL 'PRETTYDEFMACROS
|
||||||
|
(REMOVE (FASSOC DATUM (GETTOPVAL
|
||||||
|
'PRETTYDEFMACROS))
|
||||||
|
(GETTOPVAL 'PRETTYDEFMACROS]
|
||||||
|
(* Not an atom record cause want
|
||||||
|
REMPROP on NILs.)
|
||||||
|
(* NOTE%: PRETTCOM on PRETTY has
|
||||||
|
open-coded access to the MACRO
|
||||||
|
property.)
|
||||||
|
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
|
||||||
|
FILEPKGCONTENTS)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED
|
||||||
|
HASDEF EDITDEF FILEGETDEF CANFILEDEF)
|
||||||
|
(ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
|
||||||
|
(CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
|
||||||
|
)
|
||||||
|
(CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
|
||||||
|
DATUM)))
|
||||||
|
(STANDARD (SETTOPVAL (CAR (
|
||||||
|
SEARCHPRETTYTYPELST
|
||||||
|
DATUM NEWVALUE)
|
||||||
|
)
|
||||||
|
NEWVALUE)
|
||||||
|
UNDOABLE
|
||||||
|
(/SETTOPVAL (CAR (
|
||||||
|
SEARCHPRETTYTYPELST
|
||||||
|
DATUM NEWVALUE))
|
||||||
|
NEWVALUE)))
|
||||||
|
(DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
|
||||||
|
DATUM)))
|
||||||
|
(CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
|
||||||
|
DATUM NEWVALUE))
|
||||||
|
NEWVALUE)))
|
||||||
|
(ALLFIELDS NIL (/SETTOPVAL
|
||||||
|
'PRETTYTYPELST
|
||||||
|
(REMOVE (SEARCHPRETTYTYPELST
|
||||||
|
DATUM)
|
||||||
|
(GETTOPVAL 'PRETTYTYPELST]
|
||||||
|
(* NOTE%: PRETTYCOM on PRETTY has
|
||||||
|
open-coded access to GETDEF property)
|
||||||
|
(INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
|
||||||
|
(MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
|
||||||
|
(PUT X
|
||||||
|
'PROPTYPE
|
||||||
|
'FILEPKGCOMS]
|
||||||
|
(ADDTOVAR PRETTYTYPELST))))
|
||||||
|
|
||||||
|
|
||||||
|
(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
|
||||||
|
[ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
|
||||||
|
(STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
|
||||||
|
UNDOABLE
|
||||||
|
(/PUTPROP DATUM 'FILE NEWVALUE])
|
||||||
|
|
||||||
|
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
|
||||||
|
|
||||||
|
(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
IL:STOP
|
||||||
1
lispusers/MIGRATION/FILEPKGRECORDS.LCOM
Normal file
1
lispusers/MIGRATION/FILEPKGRECORDS.LCOM
Normal file
@@ -0,0 +1 @@
|
|||||||
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
805
lispusers/MIGRATION/IL-CONVERT
Normal file
805
lispusers/MIGRATION/IL-CONVERT
Normal file
@@ -0,0 +1,805 @@
|
|||||||
|
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL-CONVERT" BASE 10)
|
||||||
|
(IL:FILECREATED "26-Jan-90 10:28:55" IL:|{DSK}/users/welch/migration/IL-CONVERT.;5| 30652
|
||||||
|
|
||||||
|
IL:|changes| IL:|to:| (IL:VARS IL:IL-CONVERTCOMS)
|
||||||
|
|
||||||
|
IL:|previous| IL:|date:| "25-Jan-90 14:45:43" IL:|{DSK}/users/welch/migration/IL-CONVERT.;4|)
|
||||||
|
|
||||||
|
|
||||||
|
; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
|
||||||
|
|
||||||
|
(IL:PRETTYCOMPRINT IL:IL-CONVERTCOMS)
|
||||||
|
|
||||||
|
(IL:RPAQQ IL:IL-CONVERTCOMS
|
||||||
|
((IL:FUNCTIONS IL-DEFCONV)
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"Used when an Interlisp function is the same as the Common Lisp function of the same name.")
|
||||||
|
|
||||||
|
(IL:FUNCTIONS IL-COPYDEF)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")
|
||||||
|
|
||||||
|
(IL:FUNCTIONS IL-DEFUN IL-DEFVAR)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "
|
||||||
|
; Creates an external symbol in the IL package.
|
||||||
|
(defmacro il-defsym (name)
|
||||||
|
`(export (intern (symbol-name ',name) *il-package*) *il-package*))
|
||||||
|
|
||||||
|
(defmacro il-import (symbol)
|
||||||
|
`(progn (import ,symbol 'il)
|
||||||
|
(export (find-symbol (symbol-name ,symbol) 'il) 'il)))
|
||||||
|
")
|
||||||
|
|
||||||
|
(IL:FUNCTIONS IL-COPYCONV)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")
|
||||||
|
|
||||||
|
(IL:FUNCTIONS IL-WARNINGFORM)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1. Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR).")
|
||||||
|
|
||||||
|
(IL:P
|
||||||
|
(MACROLET ((DEF-*-IF-NEEDED
|
||||||
|
(NAME)
|
||||||
|
(LET ((NAME-STRING (SYMBOL-NAME NAME)))
|
||||||
|
`(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED"))
|
||||||
|
(ARGS)
|
||||||
|
(CASE (LENGTH ARGS)
|
||||||
|
(0 ,(EVAL `(,NAME)))
|
||||||
|
(1 (FIRST ARGS))
|
||||||
|
(T `(,',NAME ,@ARGS)))))))
|
||||||
|
(DEF-*-IF-NEEDED PROGN)
|
||||||
|
(DEF-*-IF-NEEDED AND)
|
||||||
|
(DEF-*-IF-NEEDED OR)))
|
||||||
|
(IL:STRUCTURES FAKE-SYMBOL SHARP-DOT SHARP-COMMA)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")
|
||||||
|
|
||||||
|
(IL:FUNCTIONS QUOTED-SYMBOL-P)
|
||||||
|
(IL:VARIABLES *ORIGINAL-READTABLE*)
|
||||||
|
(IL:FUNCTIONS OLD-CONVERT-FILE)
|
||||||
|
(IL:P (EXPORT 'CONVERT-FILE))
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")")
|
||||||
|
|
||||||
|
(IL:P (EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES)))
|
||||||
|
(IL:FUNCTIONS READ-EXPORTS)
|
||||||
|
(IL:* IL:\; "Get the symbol list")
|
||||||
|
(IL:FUNCTIONS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES READ-HASH-TABLE
|
||||||
|
WRITE-HASH-TABLE)
|
||||||
|
(IL:FUNCTIONS CONVERT-FILE CONVERT-FILECOMS CONVERT-ONE-FILECOM
|
||||||
|
EXPURGATE-EXTRANEOUS-PROGNS REORDER-FILECOMS MAKE-EXPORT-FORM)
|
||||||
|
(IL:VARIABLES *WALKER-TEMPLATES*)
|
||||||
|
(IL:FUNCTIONS GET-WALKER-TEMPLATE WALK-FORM-INTERNAL WALK-TEMPLATE
|
||||||
|
WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-REPEAT-EVAL RECONS
|
||||||
|
RELIST RELIST* RELIST-INTERNAL)
|
||||||
|
(IL:VARIABLES *GETVALUE-TRANSLATION* *CURRENT-DEFINITION* *CURRENT-DEFINITION-TYPE*
|
||||||
|
*CURRENT-EXPRESSION* *CURRENT-LOCALS* *FILE-CONTEXT* *WALKER-FIND-PARAMETER-LIST*
|
||||||
|
*WARNINGS-MADE* *PACKAGE-FOR-IL-SYMBOLS* *PACKAGE-FOR-RESULT-FILE*
|
||||||
|
*PARAMETERS-ALWAYS-OPTIONAL* *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE*
|
||||||
|
*UNKNOWN-MACRO-ACTION* *ALWAYS-INCLUDE-PROPS*)
|
||||||
|
(IL:DECLARE\: IL:DONTCOPY (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE)
|
||||||
|
IL:IL-CONVERT))))
|
||||||
|
|
||||||
|
(XCL:DEFDEFINER IL-DEFCONV IL:FUNCTIONS (NAME ARGLIST &REST REST)
|
||||||
|
(CHECK-TYPE NAME SYMBOL)
|
||||||
|
(LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
|
||||||
|
*IL-PACKAGE*)))
|
||||||
|
(IF FN-NAME
|
||||||
|
`(SETF (GET ',FN-NAME 'CONVERT-FORM)
|
||||||
|
#'(LAMBDA ,ARGLIST ,@REST))
|
||||||
|
(PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
|
||||||
|
NIL))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"Used when an Interlisp function is the same as the Common Lisp function of the same name.")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFMACRO IL-COPYDEF (NAME &OPTIONAL (NEWNAME NAME))
|
||||||
|
(LET ((SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
|
||||||
|
*IL-PACKAGE*)))
|
||||||
|
(UNLESS SYM (ERROR "No symbol ~:@(~a~) found in IL package." SYM))
|
||||||
|
`(SETF (GET ',SYM 'CONVERT-FORM)
|
||||||
|
#'(LAMBDA (&REST ARGS)
|
||||||
|
(CONS ',NAME (MAPCONVERT ARGS))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")
|
||||||
|
|
||||||
|
|
||||||
|
(XCL:DEFDEFINER IL-DEFUN IL:FUNCTIONS (NAME &REST REST)
|
||||||
|
(CHECK-TYPE NAME SYMBOL)
|
||||||
|
(LET* ((NAME-STRING (SYMBOL-NAME NAME))
|
||||||
|
(IL-SYM (INTERN NAME-STRING 'IL))
|
||||||
|
(IL-SYM1 (IF (CHAR/= (ELT NAME-STRING 0)
|
||||||
|
#\/)
|
||||||
|
(INTERN (CONCATENATE 'STRING "/" NAME-STRING)
|
||||||
|
'IL))))
|
||||||
|
`(PROGN (EXPORT ',IL-SYM 'IL)
|
||||||
|
(DEFUN ,IL-SYM ,@REST) (IL:* IL:\;
|
||||||
|
"Also make a version starting with a /")
|
||||||
|
,@(IF IL-SYM1
|
||||||
|
`((EXPORT ',IL-SYM1 'IL)
|
||||||
|
(SETF (SYMBOL-FUNCTION ',IL-SYM1)
|
||||||
|
(SYMBOL-FUNCTION ',IL-SYM)))))))
|
||||||
|
|
||||||
|
(XCL:DEFDEFINER IL-DEFVAR IL:FUNCTIONS (NAME &REST ARGS)
|
||||||
|
(LET ((IL-SYM (INTERN (SYMBOL-NAME NAME)
|
||||||
|
*IL-PACKAGE*)))
|
||||||
|
`(PROGN (EXPORT ',IL-SYM 'IL)
|
||||||
|
(DEFVAR ,IL-SYM ,@(MAPCONVERT ARGS)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"
|
||||||
|
; Creates an external symbol in the IL package.
|
||||||
|
(defmacro il-defsym (name)
|
||||||
|
`(export (intern (symbol-name ',name) *il-package*) *il-package*))
|
||||||
|
|
||||||
|
(defmacro il-import (symbol)
|
||||||
|
`(progn (import ,symbol 'il)
|
||||||
|
(export (find-symbol (symbol-name ,symbol) 'il) 'il)))
|
||||||
|
")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFMACRO IL-COPYCONV (OLDNAME NEWNAME)
|
||||||
|
(LET* ((OLD-SYM (FIND-SYMBOL (SYMBOL-NAME OLDNAME)
|
||||||
|
*IL-PACKAGE*))
|
||||||
|
(NEW-SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
|
||||||
|
*IL-PACKAGE*)))
|
||||||
|
(UNLESS OLD-SYM (ERROR "No symbol ~:@(~a~) found in IL package." OLD-SYM))
|
||||||
|
(UNLESS NEW-SYM (ERROR "No symbol ~:@(~a~) found in IL package." NEW-SYM))
|
||||||
|
`(SETF (GET ',NEW-SYM 'CONVERT-FORM)
|
||||||
|
#'(LAMBDA (&REST ARGS)
|
||||||
|
(APPLY (GET ',OLD-SYM 'CONVERT-FORM)
|
||||||
|
ARGS)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")
|
||||||
|
|
||||||
|
|
||||||
|
(XCL:DEFDEFINER IL-WARNINGFORM IL:FUNCTIONS (NAME &OPTIONAL (TEMPLATE '(NIL REPEAT (EVAL)))
|
||||||
|
(WARN-SWITCH '*WARN-ON-UNTRANSLATABLE-IL-FORM*)
|
||||||
|
)
|
||||||
|
(LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
|
||||||
|
*IL-PACKAGE*)))
|
||||||
|
(IF FN-NAME
|
||||||
|
`(SETF (GET ',FN-NAME 'CONVERT-FORM)
|
||||||
|
#'(LAMBDA (&REST REST)
|
||||||
|
(DECLARE (SPECIAL ,WARN-SWITCH))
|
||||||
|
(WHEN ,WARN-SWITCH
|
||||||
|
(WARN "Unable to translate a ~a form." ',FN-NAME))
|
||||||
|
(WALK-TEMPLATE (CONS ',FN-NAME REST)
|
||||||
|
',TEMPLATE)))
|
||||||
|
(PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
|
||||||
|
NIL))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1. Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR)."
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(MACROLET ((DEF-*-IF-NEEDED (NAME)
|
||||||
|
(LET ((NAME-STRING (SYMBOL-NAME NAME)))
|
||||||
|
`(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED")) (ARGS)
|
||||||
|
(CASE (LENGTH ARGS)
|
||||||
|
(0 ,(EVAL `(,NAME)))
|
||||||
|
(1 (FIRST ARGS))
|
||||||
|
(T `(,',NAME ,@ARGS)))))))
|
||||||
|
(DEF-*-IF-NEEDED PROGN)
|
||||||
|
(DEF-*-IF-NEEDED AND)
|
||||||
|
(DEF-*-IF-NEEDED OR))
|
||||||
|
|
||||||
|
(DEFSTRUCT (FAKE-SYMBOL (:CONSTRUCTOR MAKE-FAKE-SYMBOL (NAME))
|
||||||
|
(:PRINT-FUNCTION (LAMBDA (OBJ STREAM DEPTH)
|
||||||
|
(PRINC (FAKE-SYMBOL-NAME OBJ)
|
||||||
|
STREAM))))
|
||||||
|
NAME)
|
||||||
|
|
||||||
|
(DEFSTRUCT (SHARP-DOT (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
|
||||||
|
(WRITE-STRING "#." STREAM)
|
||||||
|
(WRITE (SHARP-DOT-CONTENTS SELF)
|
||||||
|
:STREAM STREAM))))
|
||||||
|
CONTENTS)
|
||||||
|
|
||||||
|
(DEFSTRUCT (SHARP-COMMA (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
|
||||||
|
(WRITE-STRING "#," STREAM)
|
||||||
|
(WRITE (SHARP-COMMA-CONTENTS SELF)
|
||||||
|
:STREAM STREAM))))
|
||||||
|
CONTENTS)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFUN QUOTED-SYMBOL-P (X)
|
||||||
|
(AND (CONSP X)
|
||||||
|
(EQ (CAR X)
|
||||||
|
'QUOTE)
|
||||||
|
(SYMBOLP (CADR X))
|
||||||
|
(NULL (CDDR X))))
|
||||||
|
|
||||||
|
(DEFVAR *ORIGINAL-READTABLE* (COPY-READTABLE NIL))
|
||||||
|
|
||||||
|
(DEFUN OLD-CONVERT-FILE (INFILE OUTFILE)
|
||||||
|
(WITH-OPEN-FILE (INSTREAM INFILE)
|
||||||
|
(IF OUTFILE
|
||||||
|
(WITH-OPEN-STREAM (OUTSTREAM (COND
|
||||||
|
((EQ OUTFILE 'T)
|
||||||
|
(MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
|
||||||
|
(T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS
|
||||||
|
:SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
|
||||||
|
(CONVERT-FILE-INTERNAL INSTREAM OUTSTREAM))
|
||||||
|
(CONVERT-FILE-INTERNAL INSTREAM NIL))))
|
||||||
|
|
||||||
|
(EXPORT 'CONVERT-FILE)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")"
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES))
|
||||||
|
|
||||||
|
(DEFUN READ-EXPORTS (FILE)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Read the exported-symbols file if it exists")
|
||||||
|
|
||||||
|
(WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
|
||||||
|
(WHEN STREAM
|
||||||
|
(READ STREAM) (IL:* IL:\;
|
||||||
|
"Read the \"(in-package)\" form")
|
||||||
|
(SETQ *EXPORTED-IL-SYMBOLS* (CADADR (READ STREAM))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:\; "Get the symbol list")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFUN WRITE-EXPORTS (FILE)
|
||||||
|
(WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
|
||||||
|
(SETQ *EXPORTED-IL-SYMBOLS* (SORT *EXPORTED-IL-SYMBOLS* #'STRING< :KEY #'SYMBOL-NAME))
|
||||||
|
(LET ((*PACKAGE* *IL-PACKAGE*))
|
||||||
|
(FORMAT STREAM "(lisp:in-package \"IL\")~%(lisp:export '(")
|
||||||
|
(DOLIST (SYM *EXPORTED-IL-SYMBOLS*)
|
||||||
|
(FORMAT STREAM "~% ~s" SYM))
|
||||||
|
(FORMAT STREAM ")~%"))))
|
||||||
|
|
||||||
|
(DEFUN READ-RECORD-TYPES (FILE) (IL:* IL:\;
|
||||||
|
"Read the record-types file if it exists")
|
||||||
|
(WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
|
||||||
|
(WHEN STREAM (READ-HASH-TABLE *RECORD-TYPES* STREAM))))
|
||||||
|
|
||||||
|
(DEFUN WRITE-RECORD-TYPES (FILE)
|
||||||
|
(WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
|
||||||
|
(WRITE-HASH-TABLE *RECORD-TYPES* STREAM)
|
||||||
|
(TERPRI STREAM)))
|
||||||
|
|
||||||
|
(DEFUN READ-HASH-TABLE (HT STREAM &AUX ITEM)
|
||||||
|
(LOOP (WHEN (EQ (SETQ ITEM (READ STREAM NIL 'STOP))
|
||||||
|
'STOP)
|
||||||
|
(RETURN))
|
||||||
|
(SETF (GETHASH (CAR ITEM)
|
||||||
|
HT)
|
||||||
|
(CDR ITEM))))
|
||||||
|
|
||||||
|
(DEFUN WRITE-HASH-TABLE (HT STREAM)
|
||||||
|
(LET* ((COUNT (HASH-TABLE-COUNT HT))
|
||||||
|
(SORTED-TABLE (MAKE-ARRAY COUNT))
|
||||||
|
(I 0))
|
||||||
|
(MAPHASH #'(LAMBDA (KEY VALUE)
|
||||||
|
(SETF (SVREF SORTED-TABLE I)
|
||||||
|
(CONS KEY VALUE))
|
||||||
|
(INCF I))
|
||||||
|
HT)
|
||||||
|
(SORT SORTED-TABLE #'STRING< :KEY #'(LAMBDA (X)
|
||||||
|
(SYMBOL-NAME (CAR X))))
|
||||||
|
(DOTIMES (I COUNT)
|
||||||
|
(PPRINT (SVREF SORTED-TABLE I)
|
||||||
|
STREAM))))
|
||||||
|
|
||||||
|
(DEFUN CONVERT-FILE (FILENAME OUTFILE)
|
||||||
|
(LET* ((REAL-FILENAME (FIND-SYMBOL (STRING FILENAME)
|
||||||
|
(FIND-PACKAGE 'IL)))
|
||||||
|
(COMS (SYMBOL-VALUE (OR (CAAR (GET REAL-FILENAME 'IL:FILE))
|
||||||
|
(ERROR "~a has no FILES definition." FILENAME)))))
|
||||||
|
(IF OUTFILE
|
||||||
|
(WITH-OPEN-STREAM (OUTSTREAM (COND
|
||||||
|
((EQ OUTFILE 'T)
|
||||||
|
(MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
|
||||||
|
(T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS
|
||||||
|
:SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
|
||||||
|
(CONVERT-FILECOMS COMS REAL-FILENAME OUTSTREAM))
|
||||||
|
(CONVERT-FILECOMS COMS REAL-FILENAME NIL))))
|
||||||
|
|
||||||
|
(DEFUN CONVERT-FILECOMS (COMS FILENAME &OPTIONAL OUTSTREAM)
|
||||||
|
(LET ((*EXPORTED-IL-SYMBOLS* NIL)
|
||||||
|
REORDERED-FILECOMS CONVERTED-FILE-LIST)
|
||||||
|
(FORMAT T "~&Processing Forms...~%")
|
||||||
|
(SETQ REORDERED-FILECOMS (REORDER-FILECOMS COMS)
|
||||||
|
CONVERTED-FILE-LIST
|
||||||
|
(EXPURGATE-EXTRANEOUS-PROGNS (MAPCAR 'CONVERT-ONE-FILECOM REORDERED-FILECOMS)))
|
||||||
|
(WHEN OUTSTREAM
|
||||||
|
(FORMAT T "~&Writing output...")
|
||||||
|
(LET* ((MFE (GET FILENAME 'IL:MAKEFILE-ENVIRONMENT))
|
||||||
|
(*PACKAGE* (OR (FIND-PACKAGE (EVAL (GETF MFE :PACKAGE)))
|
||||||
|
*IL-PACKAGE*))
|
||||||
|
(*PRINT-PRETTY* T)
|
||||||
|
(*PRINT-CASE* :DOWNCASE))
|
||||||
|
(WHEN MFE
|
||||||
|
(PRINT '(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL"))
|
||||||
|
OUTSTREAM))
|
||||||
|
(PRINT (IF MFE
|
||||||
|
(LIST 'IN-PACKAGE (GETF MFE ':PACKAGE))
|
||||||
|
'(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL")))
|
||||||
|
OUTSTREAM)
|
||||||
|
(TERPRI OUTSTREAM)
|
||||||
|
(WHEN *EXPORTED-IL-SYMBOLS*
|
||||||
|
(PRINT (MAKE-EXPORT-FORM *EXPORTED-IL-SYMBOLS*)
|
||||||
|
OUTSTREAM)
|
||||||
|
(TERPRI OUTSTREAM))
|
||||||
|
(DOLIST (FORM CONVERTED-FILE-LIST)
|
||||||
|
(WHEN FORM
|
||||||
|
(PRINT FORM OUTSTREAM)
|
||||||
|
(TERPRI OUTSTREAM)))))))
|
||||||
|
|
||||||
|
(DEFUN CONVERT-ONE-FILECOM (COM)
|
||||||
|
(UNLESS (CONSP COM)
|
||||||
|
(ERROR "Invalid filecom: ~s" COM))
|
||||||
|
(LET (
|
||||||
|
(IL:* IL:|;;| "We bind these for the warnings mechanism in case the filecom type is unknown... They'll be rebound lower down.")
|
||||||
|
|
||||||
|
(*CURRENT-EXPRESSION* COM)
|
||||||
|
(*CURRENT-DEFINITION* (CAR COM))
|
||||||
|
(*CURRENT-DEFINITION-TYPE* "Filecom")
|
||||||
|
(*WARNINGS-MADE* NIL)
|
||||||
|
(CONVERTER (GET (CAR COM)
|
||||||
|
'CONVERT-COM))
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "FILEVARS are handled at this level, except in PROP and IFPROP coms.")
|
||||||
|
|
||||||
|
(FILEVAR-P (AND (EQ (SECOND COM)
|
||||||
|
'IL:*)
|
||||||
|
(NOT (MEMBER (FIRST COM)
|
||||||
|
' (IL:* IL:PROP IL:IFPROP))))))
|
||||||
|
(FUNCALL (OR CONVERTER 'CONVERT-UNKNOWN-COM)
|
||||||
|
(IF CONVERTER
|
||||||
|
(IF FILEVAR-P
|
||||||
|
(IL:EVAL (THIRD COM))
|
||||||
|
(CDR COM))
|
||||||
|
COM))))
|
||||||
|
|
||||||
|
(DEFUN EXPURGATE-EXTRANEOUS-PROGNS (FORMS-LIST)
|
||||||
|
(LET (RESULT)
|
||||||
|
(DOLIST (FORM FORMS-LIST)
|
||||||
|
(SETQ RESULT (NCONC RESULT (IF (AND (CONSP FORM)
|
||||||
|
(EQ (CAR FORM)
|
||||||
|
'PROGN))
|
||||||
|
(EXPURGATE-EXTRANEOUS-PROGNS (CDR FORM))
|
||||||
|
(CONS FORM NIL)))))
|
||||||
|
RESULT))
|
||||||
|
|
||||||
|
(DEFUN REORDER-FILECOMS (COMS-LIST)
|
||||||
|
(LET (EARLY-LIST LATE-LIST)
|
||||||
|
(LABELS ((EARLY-P (COM)
|
||||||
|
(AND (CONSP COM)
|
||||||
|
(OR (MEMBER (CAR COM)
|
||||||
|
'(IL:CONSTANTS IL:MACROS))
|
||||||
|
(AND (MEMBER (CAR COM)
|
||||||
|
'(IL:DECLARE\:))
|
||||||
|
(SOME #'EARLY-P (CDR COM)))))))
|
||||||
|
(DOLIST (COM COMS-LIST)
|
||||||
|
(IF (EARLY-P COM)
|
||||||
|
(PUSH COM EARLY-LIST)
|
||||||
|
(PUSH COM LATE-LIST)))
|
||||||
|
(NCONC (NREVERSE EARLY-LIST)
|
||||||
|
(NREVERSE LATE-LIST)))))
|
||||||
|
|
||||||
|
(DEFUN MAKE-EXPORT-FORM (LIST-OF-SYMBOLS)
|
||||||
|
(LET (SORTED)
|
||||||
|
(DOLIST (S LIST-OF-SYMBOLS)
|
||||||
|
(LET ((A (ASSOC (SYMBOL-PACKAGE S)
|
||||||
|
SORTED)))
|
||||||
|
(IF A
|
||||||
|
(PUSH S (CDR A))
|
||||||
|
(PUSH (CONS (SYMBOL-PACKAGE S)
|
||||||
|
(LIST S))
|
||||||
|
SORTED))))
|
||||||
|
(CONS 'PROGN (MAPCAR #'(LAMBDA (P)
|
||||||
|
`(EXPORT (MAPCAR 'INTERN ',(MAPCAR 'STRING (CDR P))
|
||||||
|
',(PACKAGE-NAME (CAR P)))))
|
||||||
|
SORTED))))
|
||||||
|
|
||||||
|
(DEFPARAMETER *WALKER-TEMPLATES*
|
||||||
|
'(BLOCK (NIL NIL REPEAT (EVAL))
|
||||||
|
CATCH
|
||||||
|
(NIL EVAL REPEAT (EVAL))
|
||||||
|
CHECK-TYPE
|
||||||
|
(NIL EVAL REPEAT (NIL))
|
||||||
|
COMPILER-LET
|
||||||
|
(NIL (REPEAT (NIL EVAL))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
DECLARE
|
||||||
|
(REPEAT (NIL))
|
||||||
|
EVAL-WHEN
|
||||||
|
(NIL QUOTE REPEAT (EVAL))
|
||||||
|
FLET
|
||||||
|
(NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
FUNCTION
|
||||||
|
(NIL CALL)
|
||||||
|
GO
|
||||||
|
(NIL QUOTE)
|
||||||
|
IF
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
LABELS
|
||||||
|
(NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
LAMBDA
|
||||||
|
(NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||||
|
LET
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
LET*
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
LOCALLY
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
MACROLET
|
||||||
|
(NIL (REPEAT ((NIL NIL REPEAT (EVAL))))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
MULTIPLE-VALUE-CALL
|
||||||
|
(NIL EVAL REPEAT (EVAL))
|
||||||
|
MULTIPLE-VALUE-LIST
|
||||||
|
(NIL EVAL)
|
||||||
|
MULTIPLE-VALUE-PROG1
|
||||||
|
(NIL RETURN REPEAT (EVAL))
|
||||||
|
MULTIPLE-VALUE-SETQ
|
||||||
|
(NIL (REPEAT (SET))
|
||||||
|
EVAL)
|
||||||
|
MULTIPLE-VALUE-BIND
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT (SET))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
IL:NLSETQ
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
PROGN
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
PROGV
|
||||||
|
(NIL EVAL EVAL REPEAT (EVAL))
|
||||||
|
QUOTE
|
||||||
|
(NIL QUOTE)
|
||||||
|
RETURN-FROM
|
||||||
|
(NIL QUOTE REPEAT (RETURN))
|
||||||
|
SETQ
|
||||||
|
(NIL REPEAT (SET EVAL))
|
||||||
|
SETF
|
||||||
|
(NIL REPEAT (SET EVAL))
|
||||||
|
TAGBODY
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
THE
|
||||||
|
(NIL QUOTE EVAL)
|
||||||
|
THROW
|
||||||
|
(NIL EVAL EVAL)
|
||||||
|
UNLESS
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
UNWIND-PROTECT
|
||||||
|
(NIL RETURN REPEAT (EVAL))
|
||||||
|
WHEN
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
DO
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
|
||||||
|
(EVAL EVAL)
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
DO*
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
|
||||||
|
(EVAL EVAL)
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
DOLIST
|
||||||
|
(NIL (NIL EVAL)
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
DOTIMES
|
||||||
|
(NIL (NIL EVAL)
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
PROG
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
PROG*
|
||||||
|
(NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
COND
|
||||||
|
(NIL REPEAT ((TEST REPEAT (EVAL))))
|
||||||
|
DEFINE-SETF-METHOD
|
||||||
|
(NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||||
|
DEFUN
|
||||||
|
(NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||||
|
DEFMACRO
|
||||||
|
(NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
|
||||||
|
CASE
|
||||||
|
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||||
|
ECASE
|
||||||
|
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||||
|
TYPECASE
|
||||||
|
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||||
|
ETYPECASE
|
||||||
|
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
|
||||||
|
XCL:DEFDEFINER
|
||||||
|
(NIL NIL NIL NIL REPEAT (EVAL))
|
||||||
|
INCF
|
||||||
|
(NIL EVAL EVAL)
|
||||||
|
DECF
|
||||||
|
(NIL EVAL EVAL)
|
||||||
|
WITH-INPUT-FROM-STRING
|
||||||
|
(NIL (NIL EVAL REPEAT (EVAL))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
WITH-OUTPUT-TO-STRING
|
||||||
|
(NIL (NIL EVAL)
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
WITH-OPEN-FILE
|
||||||
|
(NIL (NIL REPEAT (EVAL))
|
||||||
|
REPEAT
|
||||||
|
(EVAL))
|
||||||
|
LOOP
|
||||||
|
(NIL REPEAT (EVAL))
|
||||||
|
POP
|
||||||
|
(NIL EVAL)
|
||||||
|
PUSH
|
||||||
|
(NIL EVAL EVAL)
|
||||||
|
PUSHNEW
|
||||||
|
(NIL EVAL EVAL REPEAT EVAL)))
|
||||||
|
|
||||||
|
(DEFUN GET-WALKER-TEMPLATE (FN)
|
||||||
|
(GETF *WALKER-TEMPLATES* FN NIL))
|
||||||
|
|
||||||
|
(DEFUN WALK-FORM-INTERNAL (FORM &AUX NEWFORM NEWNEWFORM WALK-NO-MORE-P MACROP FN TEMPLATE)
|
||||||
|
(COND
|
||||||
|
((ATOM FORM)
|
||||||
|
(WHEN (AND (SYMBOLP FORM)
|
||||||
|
(NOT (NULL *CURRENT-FREE-REFERENCES*))
|
||||||
|
(NOT (KEYWORDP FORM))
|
||||||
|
(NOT (MEMBER FORM '(T NIL)))
|
||||||
|
(NULL (ASSOC FORM *LOCALS*)))
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Almost certainly a free ref. Note for later analysis.")
|
||||||
|
|
||||||
|
(PUSHNEW FORM *CURRENT-FREE-REFERENCES*))
|
||||||
|
FORM)
|
||||||
|
((SETQ TEMPLATE (GET-WALKER-TEMPLATE (SETQ FN (CAR FORM))))
|
||||||
|
(IF (SYMBOLP TEMPLATE)
|
||||||
|
(FUNCALL TEMPLATE FORM)
|
||||||
|
(WALK-TEMPLATE FORM TEMPLATE)))
|
||||||
|
((AND (SYMBOLP FN)
|
||||||
|
(OR (GET FN 'CONVERT-FORM)
|
||||||
|
(EQ (CAR (GET FN 'IL:CLISPWORD))
|
||||||
|
'IL:FORWORD)))
|
||||||
|
(CONVERT FORM))
|
||||||
|
((AND (SYMBOLP FN)
|
||||||
|
(MACRO-FUNCTION FN))
|
||||||
|
(LET ((*CURRENT-EXPRESSION* FORM))
|
||||||
|
(WARN "Macro form ~s not translated" FN))
|
||||||
|
FORM)
|
||||||
|
((AND (SYMBOLP FN)
|
||||||
|
(NOT (FBOUNDP FN))
|
||||||
|
(SPECIAL-FORM-P FN))
|
||||||
|
(UNKNOWN-MACRO-FORM FORM))
|
||||||
|
(T
|
||||||
|
(IL:* IL:|;;| "Otherwise, walk the form as if its just a standard ")
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "functioncall using a template for standard function")
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "call.")
|
||||||
|
|
||||||
|
(WALK-TEMPLATE FORM '(CALL REPEAT (EVAL))))))
|
||||||
|
|
||||||
|
(DEFUN WALK-TEMPLATE (FORM TEMPLATE)
|
||||||
|
(IF (ATOM TEMPLATE)
|
||||||
|
(ECASE TEMPLATE
|
||||||
|
((EVAL SET FUNCTION TEST EFFECT RETURN)
|
||||||
|
(WHEN *WALKER-FIND-PARAMETER-LIST*
|
||||||
|
(THROW 'PARAMETER-LIST NIL))
|
||||||
|
(WALK-FORM-INTERNAL FORM))
|
||||||
|
((NIL QUOTE) FORM)
|
||||||
|
((BINDING)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "This should only appear inside (after) a BINDING-CONTOUR...")
|
||||||
|
|
||||||
|
(WHEN (SYMBOLP FORM)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Perhaps this should note if FORM is declared special somehow...")
|
||||||
|
|
||||||
|
(PUSH (CONS FORM ':LOCAL)
|
||||||
|
*LOCALS*)
|
||||||
|
(PUSHNEW FORM *CURRENT-LOCALS*))
|
||||||
|
FORM)
|
||||||
|
((LAMBDA CALL) (COND
|
||||||
|
((SYMBOLP FORM)
|
||||||
|
(UNLESS (NULL *CURRENT-FUNCTION-CALLS*)
|
||||||
|
(PUSHNEW FORM *CURRENT-FUNCTION-CALLS*))
|
||||||
|
FORM)
|
||||||
|
(T
|
||||||
|
(IL:* IL:|;;| "Have we a \"#'foo\" here?")
|
||||||
|
|
||||||
|
(WHEN (AND (CONSP FORM)
|
||||||
|
(EQ (CAR FORM)
|
||||||
|
'FUNCTION)
|
||||||
|
(NULL (CDDR FORM))
|
||||||
|
(SYMBOLP (SECOND FORM)))
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Record it if we do...")
|
||||||
|
|
||||||
|
(PUSHNEW (SECOND FORM)
|
||||||
|
*CURRENT-FUNCTION-CALLS*))
|
||||||
|
(WALK-FORM-INTERNAL FORM))))
|
||||||
|
((NAME)
|
||||||
|
(WHEN (NULL *CURRENT-FUNCTION-CALLS*)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Don't record name in a nested def, if we ever see one.")
|
||||||
|
|
||||||
|
(SETQ *CURRENT-DEFINITION* FORM)
|
||||||
|
(PUSH FORM *CURRENT-FUNCTION-CALLS*)
|
||||||
|
(PUSH FORM *CURRENT-FREE-REFERENCES*))
|
||||||
|
FORM)
|
||||||
|
((PARAMETER) (IF (SYMBOLP FORM)
|
||||||
|
(WALK-TEMPLATE FORM 'BINDING)
|
||||||
|
(WALK-TEMPLATE FORM '(BINDING EVAL REPEAT (BINDING)))))
|
||||||
|
((PARAMETER-LIST)
|
||||||
|
(WHEN *WALKER-FIND-PARAMETER-LIST*
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "Some code-analysis stuff uses this.")
|
||||||
|
|
||||||
|
(THROW 'PARAMETER-LIST FORM))
|
||||||
|
(WALK-TEMPLATE FORM '(REPEAT (PARAMETER)))))
|
||||||
|
(CASE (CAR TEMPLATE)
|
||||||
|
(REPEAT (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE)
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "For the case where nothing happens")
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "after the repeat optimize out the")
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "call to length.")
|
||||||
|
|
||||||
|
(IF (NULL (CDDR TEMPLATE))
|
||||||
|
NIL
|
||||||
|
(NTHCDR (- (LENGTH FORM)
|
||||||
|
(LENGTH (CDDR TEMPLATE)))
|
||||||
|
FORM))))
|
||||||
|
(IF (WALK-TEMPLATE FORM (IF (IF (LISTP (CADR TEMPLATE))
|
||||||
|
(EVAL (CADR TEMPLATE))
|
||||||
|
(FUNCALL (CADR TEMPLATE)
|
||||||
|
FORM))
|
||||||
|
(CADDR TEMPLATE)
|
||||||
|
(CADDDR TEMPLATE))))
|
||||||
|
(BINDING-CONTOUR (LET ((*LOCALS* *LOCALS*))
|
||||||
|
(WALK-TEMPLATE FORM (CDR TEMPLATE))))
|
||||||
|
(REMOTE (WALK-TEMPLATE FORM (CADR TEMPLATE)))
|
||||||
|
(WARN
|
||||||
|
(WARN (SECOND TEMPLATE))
|
||||||
|
(IF (NULL (CDDR TEMPLATE))
|
||||||
|
FORM
|
||||||
|
(WALK-TEMPLATE FORM (CDDR TEMPLATE))))
|
||||||
|
(OTHERWISE (COND
|
||||||
|
((ATOM FORM)
|
||||||
|
FORM)
|
||||||
|
(T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
|
||||||
|
(CAR TEMPLATE))
|
||||||
|
(WALK-TEMPLATE (CDR FORM)
|
||||||
|
(CDR TEMPLATE)))))))))
|
||||||
|
|
||||||
|
(DEFUN WALK-TEMPLATE-HANDLE-REPEAT (FORM TEMPLATE STOP-FORM)
|
||||||
|
(IF (EQ FORM STOP-FORM)
|
||||||
|
(WALK-TEMPLATE FORM (CDR TEMPLATE))
|
||||||
|
(WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
|
||||||
|
STOP-FORM)))
|
||||||
|
|
||||||
|
(DEFUN WALK-TEMPLATE-HANDLE-REPEAT-1 (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM)
|
||||||
|
(COND
|
||||||
|
((NULL FORM)
|
||||||
|
NIL)
|
||||||
|
((EQ FORM STOP-FORM)
|
||||||
|
(IF (NULL REPEAT-TEMPLATE)
|
||||||
|
(WALK-TEMPLATE STOP-FORM (CDR TEMPLATE))
|
||||||
|
(ERROR
|
||||||
|
"While handling repeat:
|
||||||
|
~%~Ran into stop while still in repeat template.")))
|
||||||
|
((NULL REPEAT-TEMPLATE)
|
||||||
|
(WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
|
||||||
|
STOP-FORM))
|
||||||
|
(T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
|
||||||
|
(CAR REPEAT-TEMPLATE))
|
||||||
|
(WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM)
|
||||||
|
TEMPLATE
|
||||||
|
(CDR REPEAT-TEMPLATE)
|
||||||
|
STOP-FORM)))))
|
||||||
|
|
||||||
|
(DEFUN WALK-REPEAT-EVAL (FORM ENV)
|
||||||
|
(AND FORM (RECONS FORM (WALK-FORM-INTERNAL (CAR FORM))
|
||||||
|
(WALK-REPEAT-EVAL (CDR FORM)))))
|
||||||
|
|
||||||
|
(DEFUN RECONS (X CAR CDR)
|
||||||
|
(IF (OR (NOT (EQ (CAR X)
|
||||||
|
CAR))
|
||||||
|
(NOT (EQ (CDR X)
|
||||||
|
CDR)))
|
||||||
|
(CONS CAR CDR)
|
||||||
|
X))
|
||||||
|
|
||||||
|
(DEFUN RELIST (X &REST ARGS)
|
||||||
|
(RELIST-INTERNAL X ARGS NIL))
|
||||||
|
|
||||||
|
(DEFUN RELIST* (X &REST ARGS)
|
||||||
|
(RELIST-INTERNAL X ARGS 'T))
|
||||||
|
|
||||||
|
(DEFUN RELIST-INTERNAL (X ARGS *P)
|
||||||
|
(IF (NULL (CDR ARGS))
|
||||||
|
(IF *P
|
||||||
|
(CAR ARGS)
|
||||||
|
(LIST (CAR ARGS)))
|
||||||
|
(RECONS X (CAR ARGS)
|
||||||
|
(RELIST-INTERNAL (CDR X)
|
||||||
|
(CDR ARGS)
|
||||||
|
*P))))
|
||||||
|
|
||||||
|
(DEFVAR *GETVALUE-TRANSLATION* :SLOT-VALUE)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-DEFINITION*)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-DEFINITION-TYPE*)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-EXPRESSION*)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-LOCALS* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *FILE-CONTEXT* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *WALKER-FIND-PARAMETER-LIST* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *WARNINGS-MADE* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *PACKAGE-FOR-IL-SYMBOLS* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *PACKAGE-FOR-RESULT-FILE* "CL")
|
||||||
|
|
||||||
|
(DEFVAR *PARAMETERS-ALWAYS-OPTIONAL* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *UNKNOWN-MACRO-ACTION* :UM-WARN)
|
||||||
|
|
||||||
|
(DEFVAR *ALWAYS-INCLUDE-PROPS* NIL)
|
||||||
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
|
|
||||||
|
(IL:PUTPROPS IL:IL-CONVERT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "IL-CONVERT" :BASE
|
||||||
|
10))
|
||||||
|
|
||||||
|
(IL:PUTPROPS IL:IL-CONVERT IL:FILETYPE :COMPILE-FILE)
|
||||||
|
)
|
||||||
|
(IL:PUTPROPS IL:IL-CONVERT IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
|
||||||
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
|
(IL:FILEMAP (NIL)))
|
||||||
|
IL:STOP
|
||||||
1
lispusers/MIGRATION/IL-CONVERT.LCOM
Normal file
1
lispusers/MIGRATION/IL-CONVERT.LCOM
Normal file
File diff suppressed because one or more lines are too long
420
lispusers/MIGRATION/IL-LOOPS
Normal file
420
lispusers/MIGRATION/IL-LOOPS
Normal file
@@ -0,0 +1,420 @@
|
|||||||
|
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||||
|
(FILECREATED "26-Jan-90 10:12:33" {DSK}/users/welch/migration/IL-LOOPS.;8 28689
|
||||||
|
|
||||||
|
changes to%: (FUNCTIONS IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::GetValue IL-CONVERT::_Super)
|
||||||
|
|
||||||
|
previous date%: "25-Jan-90 14:14:46" {DSK}/users/welch/migration/IL-LOOPS.;6)
|
||||||
|
|
||||||
|
|
||||||
|
(* "
|
||||||
|
Copyright (c) 1989, 1990 by Savoir, Inc.. All rights reserved.
|
||||||
|
")
|
||||||
|
|
||||||
|
(PRETTYCOMPRINT IL-LOOPSCOMS)
|
||||||
|
|
||||||
|
(RPAQQ IL-LOOPSCOMS
|
||||||
|
((FUNCTIONS IL-CONVERT::@ IL-CONVERT::_ IL-CONVERT::$ IL-CONVERT::_! IL-CONVERT::_Super
|
||||||
|
IL-CONVERT::_Super? IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
|
||||||
|
IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER IL-CONVERT::CONVERT-CLASSES
|
||||||
|
IL-CONVERT::CONVERT-METHODS IL-CONVERT::CONVERT-ONE-CLASS
|
||||||
|
IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::Class
|
||||||
|
IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||||
|
IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER
|
||||||
|
IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER IL-CONVERT::GETFROMIV-ACCESSOR-WRITER
|
||||||
|
IL-CONVERT::GetValue)
|
||||||
|
(PROP IL-CONVERT::CONVERT-COM CLASSES METHODS)
|
||||||
|
(PROP IL-CONVERT::ACCESSOR-WRITER EveryFetch FFGetFromIV FFSendSelf FirstFetch GetFromIV
|
||||||
|
AVSendSelf)))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::@ (&REST IL-CONVERT::ARGS)
|
||||||
|
(LET [(IL-CONVERT::EXPANSION (Parse@ IL-CONVERT::ARGS
|
||||||
|
'IV]
|
||||||
|
(OR (AND IL-CONVERT::EXPANSION (IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::EXPANSION)
|
||||||
|
)
|
||||||
|
(PROGN (CL:WARN "Unrecognizable @ form")
|
||||||
|
IL-CONVERT::*CURRENT-EXPRESSION*))))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_ (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
|
||||||
|
`(,IL-CONVERT::METH ,(IL-CONVERT:CONVERT IL-CONVERT::INST)
|
||||||
|
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::$ (IL-CONVERT::NAME)
|
||||||
|
(LET ((IL-CONVERT::REC ($! IL-CONVERT::NAME)))
|
||||||
|
(CL:IF (Class? IL-CONVERT::REC)
|
||||||
|
`[,(IL-CONVERT::MAKE-FAKE-SYMBOL "FIND-CLASS")
|
||||||
|
',(IL-CONVERT:CONVERT IL-CONVERT::NAME]
|
||||||
|
(PROGN (CL:WARN
|
||||||
|
"$ form doesn't refer to a known class"
|
||||||
|
)
|
||||||
|
IL-CONVERT::*CURRENT-EXPRESSION*))))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_! (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
|
||||||
|
`(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::METH)
|
||||||
|
,(IL-CONVERT:CONVERT IL-CONVERT::INST)
|
||||||
|
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super (&OPTIONAL IL-CONVERT::OBJ IL-CONVERT::SEL &REST
|
||||||
|
IL-CONVERT::ARGS)
|
||||||
|
(DECLARE (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL))
|
||||||
|
(CONS (IL-CONVERT::MAKE-FAKE-SYMBOL "CALL-NEXT-METHOD"
|
||||||
|
)
|
||||||
|
(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super? (IL-CONVERT::OBJ IL-CONVERT::SEL &REST
|
||||||
|
IL-CONVERT::ARGS)
|
||||||
|
(DECLARE (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL)
|
||||||
|
)
|
||||||
|
`[AND (,(IL-CONVERT::MAKE-FAKE-SYMBOL "NEXT-METHOD-P"
|
||||||
|
))
|
||||||
|
(,(IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||||
|
"CALL-NEXT-METHOD")
|
||||||
|
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS])
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
|
||||||
|
IL-CONVERT::CLASS-NAME)
|
||||||
|
(DECLARE (CL:DECLARATION CL:VALUES)
|
||||||
|
(CL:VALUES IL-CONVERT::SLOT-SPEC &REST IL-CONVERT::AUX-DEFS))
|
||||||
|
(CASE IL-CONVERT::*GETVALUE-TRANSLATION*
|
||||||
|
(:SLOT-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
|
||||||
|
(CL:WARN "Active value in SLOT-VALUE GetValue mode")
|
||||||
|
IL-CONVERT::OBJ))
|
||||||
|
(:ACCESSOR (CASE (ClassName IL-CONVERT::OBJ)
|
||||||
|
(ExplicitFnActiveValue (IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||||
|
IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
|
||||||
|
IL-CONVERT::CLASS-NAME))
|
||||||
|
(CL:OTHERWISE
|
||||||
|
[LET* ((IL-CONVERT::GM (GetIt (Class IL-CONVERT::OBJ)
|
||||||
|
'GetWrappedValue NIL 'METHOD))
|
||||||
|
[IL-CONVERT::GMCLASS (CL:SECOND (GETDEF IL-CONVERT::GM 'METHODS]
|
||||||
|
(IL-CONVERT::PM (GetIt (Class IL-CONVERT::OBJ)
|
||||||
|
'PutWrappedValue NIL 'METHOD))
|
||||||
|
(IL-CONVERT::PMCLASS (CL:SECOND (GETDEF IL-CONVERT::PM 'METHODS]
|
||||||
|
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
|
||||||
|
(CL:WARN "Unconvertable ~a in defclass" (ClassName IL-CONVERT::OBJ)))
|
||||||
|
IL-CONVERT::OBJ)))
|
||||||
|
(:ACTIVE-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
|
||||||
|
(CL:WARN "Active value emulator not written yet")
|
||||||
|
IL-CONVERT::OBJ))))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||||
|
IL-CONVERT::LOCALSTATE)
|
||||||
|
[IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)])
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::CONVERT-CLASSES (IL-CONVERT::CS)
|
||||||
|
(IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::CS))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::CONVERT-METHODS (IL-CONVERT::MS)
|
||||||
|
(CONS 'PROGN (IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::MS)))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::CONVERT-ONE-CLASS (IL-CONVERT::C)
|
||||||
|
""
|
||||||
|
[LET*
|
||||||
|
((IL-CONVERT::SRC (_ [OR ($! IL-CONVERT::C)
|
||||||
|
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::C))
|
||||||
|
(CL:WARN "Class not found")
|
||||||
|
(CL:RETURN-FROM IL-CONVERT::CONVERT-ONE-CLASS
|
||||||
|
(LIST '* ';; (CL:FORMAT NIL "Class ~a not found."
|
||||||
|
IL-CONVERT::C]
|
||||||
|
MakeFileSource))
|
||||||
|
(IL-CONVERT::CLASSNAME (IL-CONVERT:CONVERT (CL:SECOND IL-CONVERT::SRC)))
|
||||||
|
(IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::CLASSNAME)
|
||||||
|
(IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Class")
|
||||||
|
(IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::CLASSNAME))
|
||||||
|
(IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::CLASSNAME))
|
||||||
|
(IL-CONVERT::ATTRIBUTES (CDDR IL-CONVERT::SRC))
|
||||||
|
(IL-CONVERT::META (CDR (CL:ASSOC 'MetaClass IL-CONVERT::ATTRIBUTES)))
|
||||||
|
(IL-CONVERT::SUPERS (CDR (CL:ASSOC 'Supers IL-CONVERT::ATTRIBUTES)))
|
||||||
|
(IL-CONVERT::CVS (CDR (CL:ASSOC 'ClassVariables IL-CONVERT::ATTRIBUTES)))
|
||||||
|
(IL-CONVERT::IVS (CDR (CL:ASSOC 'InstanceVariables IL-CONVERT::ATTRIBUTES)))
|
||||||
|
IL-CONVERT::PROPS-ALIST IL-CONVERT::AUX-DEFS)
|
||||||
|
(CL:LABELS
|
||||||
|
([IL-CONVERT::LOOPS-CONVERT (IL-CONVERT::X)
|
||||||
|
(COND
|
||||||
|
[(Class? IL-CONVERT::X)
|
||||||
|
`(IL-CONVERT::FIND-CLASS ',(IL-CONVERT:CONVERT (_ IL-CONVERT::X ClassName)]
|
||||||
|
((AnnotatedValue? IL-CONVERT::X)
|
||||||
|
(IL-CONVERT::AV-CONVERT IL-CONVERT::X))
|
||||||
|
((CL:CONSP IL-CONVERT::X)
|
||||||
|
(CL:MAPCAR #'IL-CONVERT::LOOPS-CONVERT IL-CONVERT::X))
|
||||||
|
((Instance? IL-CONVERT::X)
|
||||||
|
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::X))
|
||||||
|
(CL:WARN "Unconvertable LOOPS object in defclass"))
|
||||||
|
IL-CONVERT::X)
|
||||||
|
(T (IL-CONVERT:CONVERT IL-CONVERT::X]
|
||||||
|
(IL-CONVERT::AV-CONVERT (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ)
|
||||||
|
(CL:SETQ IL-CONVERT::OBJ (fetch annotatedValue of IL-CONVERT::OBJ))
|
||||||
|
(LET [(CL:VALUES (CL:MULTIPLE-VALUE-LIST (IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
|
||||||
|
IL-CONVERT::NAME IL-CONVERT::DOC
|
||||||
|
IL-CONVERT::OBJ IL-CONVERT::CLASSNAME]
|
||||||
|
(CL:SETQ IL-CONVERT::AUX-DEFS (NCONC IL-CONVERT::AUX-DEFS (CDR CL:VALUES)))
|
||||||
|
(CAR CL:VALUES)))
|
||||||
|
(IL-CONVERT::PROCESS-IV
|
||||||
|
(IL-CONVERT::SPEC &OPTIONAL IL-CONVERT::ALLOC &AUX IL-CONVERT::DOC)
|
||||||
|
(LET* [(IL-CONVERT::NAME (IL-CONVERT:CONVERT (CL:FIRST IL-CONVERT::SPEC)))
|
||||||
|
(IL-CONVERT::OBJ (CL:SECOND IL-CONVERT::SPEC))
|
||||||
|
(IL-CONVERT::DOC (CL:GETF (CDDR IL-CONVERT::SPEC)
|
||||||
|
'doc))
|
||||||
|
[IL-CONVERT::CONVERSION (CL:IF (type? annotatedValue IL-CONVERT::OBJ)
|
||||||
|
(IL-CONVERT::AV-CONVERT IL-CONVERT::NAME IL-CONVERT::DOC
|
||||||
|
IL-CONVERT::OBJ)
|
||||||
|
`[,IL-CONVERT::NAME
|
||||||
|
,@[AND (CDR IL-CONVERT::SPEC)
|
||||||
|
`(:INITFORM ,(IL-CONVERT::LOOPS-CONVERT
|
||||||
|
IL-CONVERT::OBJ]
|
||||||
|
:INITARG
|
||||||
|
,(CL:INTERN (STRING (CL:FIRST IL-CONVERT::SPEC))
|
||||||
|
*KEYWORD-PACKAGE*)
|
||||||
|
,@[AND IL-CONVERT::ALLOC `(:ALLOCATION
|
||||||
|
,IL-CONVERT::ALLOC]
|
||||||
|
,@(AND IL-CONVERT::DOC `(:DOCUMENTATION ,IL-CONVERT::DOC])
|
||||||
|
]
|
||||||
|
(IL-CONVERT::PROPS (CL:COPY-LIST (CL:IF IL-CONVERT::DOC
|
||||||
|
(AND (CDDR (CDDR IL-CONVERT::SPEC))
|
||||||
|
(CDDR IL-CONVERT::SPEC))
|
||||||
|
(CDDR IL-CONVERT::SPEC))]
|
||||||
|
|
||||||
|
(* ;; "The following (when not quoted) fails to compile, for some reason:")
|
||||||
|
|
||||||
|
'(CL:REMF IL-CONVERT::PROPS 'doc)
|
||||||
|
(CL:WHEN IL-CONVERT::PROPS
|
||||||
|
(CL:PUSH (CONS IL-CONVERT::NAME IL-CONVERT::PROPS)
|
||||||
|
IL-CONVERT::PROPS-ALIST))
|
||||||
|
IL-CONVERT::CONVERSION)))
|
||||||
|
(LET [(IL-CONVERT::FORM `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFCLASS")
|
||||||
|
,IL-CONVERT::CLASSNAME
|
||||||
|
,(IL-CONVERT::MAPCONVERT IL-CONVERT::SUPERS)
|
||||||
|
[,@(CL:REMOVE-IF 'NULL (CL:MAPCAR #'IL-CONVERT::PROCESS-IV
|
||||||
|
IL-CONVERT::IVS))
|
||||||
|
,@(CL:REMOVE-IF 'NULL (for IL-CONVERT::CV in IL-CONVERT::CVS
|
||||||
|
collect (IL-CONVERT::PROCESS-IV
|
||||||
|
IL-CONVERT::CV :CLASS)))
|
||||||
|
,@(AND (OR IL-CONVERT::PROPS-ALIST IL-CONVERT::*ALWAYS-INCLUDE-PROPS*
|
||||||
|
)
|
||||||
|
`(IL-CONVERT::.PROPS-ALIST. :INITFORM '
|
||||||
|
,
|
||||||
|
IL-CONVERT::PROPS-ALIST
|
||||||
|
]
|
||||||
|
,@(CL:UNLESS (EQ (CAR IL-CONVERT::META)
|
||||||
|
'Class)
|
||||||
|
[LET [(IL-CONVERT::*CURRENT-EXPRESSION* (IL-CONVERT:CONVERT
|
||||||
|
(CAR IL-CONVERT::META]
|
||||||
|
(CL:WARN "Metaclass might be incorrect")
|
||||||
|
`(:METACLASS ,IL-CONVERT::*CURRENT-EXPRESSION*])]
|
||||||
|
(CL:IF IL-CONVERT::AUX-DEFS
|
||||||
|
`(PROGN ,IL-CONVERT::FORM ,.IL-CONVERT::AUX-DEFS)
|
||||||
|
IL-CONVERT::FORM)])
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::CONVERT-ONE-METHOD (IL-CONVERT::M)
|
||||||
|
(LET* ((IL-CONVERT::METHOD-BODY (\DEFINE-TYPE-GETDEF IL-CONVERT::M 'METHOD-FNS))
|
||||||
|
[IL-CONVERT::METHOD-CLASS (CL:FIRST (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
|
||||||
|
[IL-CONVERT::METHOD-SELECTOR (CL:SECOND (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
|
||||||
|
(IL-CONVERT::METHOD-ARGS (CDR (CL:SECOND IL-CONVERT::METHOD-BODY)))
|
||||||
|
(IL-CONVERT::METHOD-FNBODY (CDDR IL-CONVERT::METHOD-BODY))
|
||||||
|
(IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::M)
|
||||||
|
(IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Function")
|
||||||
|
(IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::M))
|
||||||
|
(IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::M))
|
||||||
|
(IL-CONVERT::*SELF-VARIABLE* (CL:FIRST IL-CONVERT::METHOD-ARGS)))
|
||||||
|
(DECLARE (CL:SPECIAL IL-CONVERT::*SELF-VARIABLE*))
|
||||||
|
(CL:VALUES [CL:MULTIPLE-VALUE-BIND (IL-CONVERT::NEW-VARLST IL-CONVERT::VARNAMES)
|
||||||
|
(IL-CONVERT::EXPAND-VARLIST IL-CONVERT::METHOD-ARGS)
|
||||||
|
[LET ((IL-CONVERT::*LOCALS* (CL:COPY-LIST IL-CONVERT::VARNAMES)))
|
||||||
|
(CL:WHEN (AND (CDR IL-CONVERT::NEW-VARLST)
|
||||||
|
IL-CONVERT::*PARAMETERS-ALWAYS-OPTIONAL*)
|
||||||
|
(CL:PUSH '&OPTIONAL (CDR IL-CONVERT::NEW-VARLST)))]
|
||||||
|
`(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::DEFMETHOD)
|
||||||
|
,IL-CONVERT::METHOD-SELECTOR
|
||||||
|
[(,(CL:FIRST IL-CONVERT::NEW-VARLST)
|
||||||
|
,IL-CONVERT::METHOD-CLASS)
|
||||||
|
,@(CDR IL-CONVERT::NEW-VARLST)
|
||||||
|
,@(AND IL-CONVERT::*ADD-REST-ARG* '(&REST IL-CONVERT::$EXTRA-ARGS$]
|
||||||
|
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::METHOD-FNBODY]
|
||||||
|
(CL:NREVERSE IL-CONVERT::*CURRENT-FUNCTION-CALLS*)
|
||||||
|
(CL:NREVERSE IL-CONVERT::*CURRENT-FREE-REFERENCES*))))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::Class (IL-CONVERT::X)
|
||||||
|
`(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::CLASS-OF)
|
||||||
|
,(IL-CONVERT:CONVERT IL-CONVERT::X)))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||||
|
IL-CONVERT::LOCALSTATE)
|
||||||
|
(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
|
||||||
|
(IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
|
||||||
|
`(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE))
|
||||||
|
(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE)))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC (IL-CONVERT::NAME IL-CONVERT::DOC
|
||||||
|
IL-CONVERT::OBJ
|
||||||
|
IL-CONVERT::CLASS-NAME)
|
||||||
|
|
||||||
|
(* ;; "Old-style AVs done here. ")
|
||||||
|
|
||||||
|
(LET* ((IL-CONVERT::LS (@ IL-CONVERT::OBJ localState))
|
||||||
|
(IL-CONVERT::GF (@ IL-CONVERT::OBJ getFn))
|
||||||
|
(IL-CONVERT::PF (@ IL-CONVERT::OBJ putFn))
|
||||||
|
(IL-CONVERT::CODEWRITER (GET IL-CONVERT::GF 'IL-CONVERT::ACCESSOR-WRITER))
|
||||||
|
IL-CONVERT::DEFS)
|
||||||
|
|
||||||
|
(* ;; " Write the accessor...")
|
||||||
|
|
||||||
|
(CL:UNLESS IL-CONVERT::CODEWRITER
|
||||||
|
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM IL-CONVERT::OBJ
|
||||||
|
)))
|
||||||
|
(CL:WARN "No accessor-writer for ~a" IL-CONVERT::GF)
|
||||||
|
(CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||||
|
IL-CONVERT::*CURRENT-EXPRESSION*)))
|
||||||
|
(LET* [(CL:NAMESTRING (CL:IF (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::NAME)
|
||||||
|
(IL-CONVERT::FAKE-SYMBOL-NAME IL-CONVERT::NAME)
|
||||||
|
(STRING IL-CONVERT::NAME)))
|
||||||
|
[IL-CONVERT::VARNAME (AND (CL:CONSP IL-CONVERT::CODEWRITER)
|
||||||
|
(CDR IL-CONVERT::CODEWRITER)
|
||||||
|
(IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING
|
||||||
|
"!CACHE-FOR-"
|
||||||
|
CL:NAMESTRING]
|
||||||
|
(IL-CONVERT::CODE (CL:FUNCALL (CL:IF (CL:CONSP IL-CONVERT::CODEWRITER)
|
||||||
|
(CAR IL-CONVERT::CODEWRITER)
|
||||||
|
IL-CONVERT::CODEWRITER)
|
||||||
|
IL-CONVERT::VARNAME
|
||||||
|
'self IL-CONVERT::LS))
|
||||||
|
(IL-CONVERT::ACCESSOR (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING
|
||||||
|
"!ACCESSOR-FOR-"
|
||||||
|
CL:NAMESTRING]
|
||||||
|
(CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
|
||||||
|
,IL-CONVERT::ACCESSOR
|
||||||
|
((,(IL-CONVERT::MAKE-FAKE-SYMBOL "SELF")
|
||||||
|
,IL-CONVERT::CLASS-NAME))
|
||||||
|
,IL-CONVERT::CODE)
|
||||||
|
IL-CONVERT::DEFS)
|
||||||
|
|
||||||
|
(* ;; "Look at putfn...")
|
||||||
|
|
||||||
|
(CL:UNLESS (CL:MEMBER IL-CONVERT::PF '(ReplaceMe NoUpdatePermitted))
|
||||||
|
(LET [(IL-CONVERT::CODEWRITER (GET IL-CONVERT::PF 'IL-CONVERT::ACCESSOR-WRITER]
|
||||||
|
(CL:UNLESS IL-CONVERT::CODEWRITER
|
||||||
|
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM
|
||||||
|
IL-CONVERT::OBJ)))
|
||||||
|
(CL:WARN "No accessor-writer for ~a" IL-CONVERT::PF)
|
||||||
|
(CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
|
||||||
|
IL-CONVERT::*CURRENT-EXPRESSION*)))
|
||||||
|
(LET ((IL-CONVERT::CODE (CL:FUNCALL IL-CONVERT::CODEWRITER
|
||||||
|
IL-CONVERT::VARNAME 'self IL-CONVERT::LS)))
|
||||||
|
(CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
|
||||||
|
(CL:SETF ,IL-CONVERT::ACCESSOR)
|
||||||
|
((self ,IL-CONVERT::CLASS-NAME))
|
||||||
|
,IL-CONVERT::CODE)
|
||||||
|
IL-CONVERT::DEFS))))
|
||||||
|
|
||||||
|
(* ;; "Make slot spec...")
|
||||||
|
|
||||||
|
(CL:APPLY 'CL:VALUES (* ; "values-list* y'might say")
|
||||||
|
[AND IL-CONVERT::VARNAME
|
||||||
|
`(,IL-CONVERT::VARNAME ,@(AND (EQ IL-CONVERT::PF 'ReplaceMe)
|
||||||
|
`(:WRITER (CL:SETF ,IL-CONVERT::ACCESSOR]
|
||||||
|
IL-CONVERT::DEFS))))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||||
|
IL-CONVERT::LOCALSTATE)
|
||||||
|
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
[CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE]))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||||
|
IL-CONVERT::LOCALSTATE)
|
||||||
|
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
[CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
,(IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)]))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||||
|
IL-CONVERT::LOCALSTATE)
|
||||||
|
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
(CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
|
||||||
|
,(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
|
||||||
|
(IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
|
||||||
|
`(CL:FUNCALL ,IL-CONVERT::LOCALSTATE)
|
||||||
|
IL-CONVERT::LOCALSTATE))))
|
||||||
|
|
||||||
|
(CL:DEFUN IL-CONVERT::GETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
|
||||||
|
IL-CONVERT::LOCALSTATE)
|
||||||
|
`(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE))
|
||||||
|
|
||||||
|
(IL-CONVERT::IL-DEFCONV IL-CONVERT::GetValue (IL-CONVERT::INST &OPTIONAL IL-CONVERT::VAR
|
||||||
|
IL-CONVERT::PROP)
|
||||||
|
[COND
|
||||||
|
(IL-CONVERT::PROP (LIST (
|
||||||
|
IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||||
|
"SLOT-PROP-VALUE")
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::INST)
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::VAR)
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::PROP)))
|
||||||
|
[IL-CONVERT::VAR
|
||||||
|
(CL:ECASE IL-CONVERT::*GETVALUE-TRANSLATION*
|
||||||
|
(:SLOT-VALUE (LIST
|
||||||
|
IL-CONVERT::*SLOT-VALUE-FAKESYM*
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::INST)
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::VAR)))
|
||||||
|
(:ACCESSOR
|
||||||
|
(CL:IF (AND (CL:CONSP IL-CONVERT::VAR)
|
||||||
|
(EQ (CAR IL-CONVERT::VAR)
|
||||||
|
'QUOTE))
|
||||||
|
(LIST
|
||||||
|
[IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||||
|
(CL:CONCATENATE
|
||||||
|
'STRING "access-"
|
||||||
|
(LET [(IL-CONVERT::NEWNAME
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
(CL:SECOND IL-CONVERT::VAR
|
||||||
|
]
|
||||||
|
(CL:IF (
|
||||||
|
IL-CONVERT::FAKE-SYMBOL-P
|
||||||
|
IL-CONVERT::NEWNAME)
|
||||||
|
(
|
||||||
|
IL-CONVERT::FAKE-SYMBOL-NAME
|
||||||
|
IL-CONVERT::NEWNAME)
|
||||||
|
(CL:SYMBOL-NAME
|
||||||
|
IL-CONVERT::NEWNAME
|
||||||
|
))]
|
||||||
|
(IL-CONVERT:CONVERT IL-CONVERT::INST
|
||||||
|
))
|
||||||
|
(PROGN (CL:WARN
|
||||||
|
"Unquoted IV spec in :ACCESSOR GetValue mode"
|
||||||
|
)
|
||||||
|
|
||||||
|
IL-CONVERT::*CURRENT-EXPRESSION*
|
||||||
|
)))
|
||||||
|
(:ACTIVE-VALUE (IL-CONVERT::MAKE-FAKE-SYMBOL
|
||||||
|
"ACTIVE-VALUE"
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::INST)
|
||||||
|
(IL-CONVERT:CONVERT
|
||||||
|
IL-CONVERT::VAR))))]
|
||||||
|
(T (IL-CONVERT:CONVERT `(GetValue self
|
||||||
|
,IL-CONVERT::INST])
|
||||||
|
|
||||||
|
(PUTPROPS CLASSES IL-CONVERT::CONVERT-COM IL-CONVERT::CONVERT-CLASSES)
|
||||||
|
|
||||||
|
(PUTPROPS METHODS IL-CONVERT::CONVERT-COM IL-CONVERT::CONVERT-METHODS)
|
||||||
|
|
||||||
|
(PUTPROPS EveryFetch IL-CONVERT::ACCESSOR-WRITER IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER)
|
||||||
|
|
||||||
|
(PUTPROPS FFGetFromIV IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER . T))
|
||||||
|
|
||||||
|
(PUTPROPS FFSendSelf IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER . T))
|
||||||
|
|
||||||
|
(PUTPROPS FirstFetch IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER . T))
|
||||||
|
|
||||||
|
(PUTPROPS GetFromIV IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER))
|
||||||
|
|
||||||
|
(PUTPROPS AVSendSelf IL-CONVERT::ACCESSOR-WRITER IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER)
|
||||||
|
(PUTPROPS IL-LOOPS COPYRIGHT ("Savoir, Inc." 1989 1990))
|
||||||
|
(DECLARE%: DONTCOPY
|
||||||
|
(FILEMAP (NIL)))
|
||||||
|
STOP
|
||||||
1
lispusers/MIGRATION/IL-LOOPS.LCOM
Normal file
1
lispusers/MIGRATION/IL-LOOPS.LCOM
Normal file
File diff suppressed because one or more lines are too long
214
lispusers/MIGRATION/IL-RECORD
Normal file
214
lispusers/MIGRATION/IL-RECORD
Normal file
@@ -0,0 +1,214 @@
|
|||||||
|
(DEFINE-FILE-INFO PACKAGE "IL-CONVERT" READTABLE "XCL")
|
||||||
|
(IL:FILECREATED "14-Sep-89 10:03:02" IL:|{DSK}/python2/aria/migration/interlisp/IL-RECORD.;2| 21305
|
||||||
|
|
||||||
|
IL:|changes| IL:|to:| (IL:FUNCTIONS MAKE-RECORD-ACCESSORS |fetch| |replace| |DO-create|)
|
||||||
|
|
||||||
|
IL:|previous| IL:|date:| " 2-Mar-89 13:12:40" IL:|{DSK}/users/eweaver/convert/IL-RECORD.;4|)
|
||||||
|
|
||||||
|
|
||||||
|
; Copyright (c) 1989 by ENVOS Corporation. All rights reserved.
|
||||||
|
|
||||||
|
(IL:PRETTYCOMPRINT IL:IL-RECORDCOMS)
|
||||||
|
|
||||||
|
(IL:RPAQQ IL:IL-RECORDCOMS ((IL:* IL:\| "chapter 8") (IL:VARIABLES *RECORD-TYPES*) (IL:FUNCTIONS ADD-EXPORTS ASSOCRECORD PROPRECORD ATOMRECORD BLOCKRECORD) (IL:FUNCTIONS ARRAYRECORD DEFINE-ARRAYRECORD-STRUCTURE) (IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)") (IL:FUNCTIONS INTERLISP-COMMENT-P) (IL:FUNCTIONS RECORD) (IL:FUNCTIONS TYPERECORD FLATTEN MAKE-RECORD-ACCESSORS DEFINE-RECORD-STRUCTURE) (IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ") (IL:* IL:|;;| "
|
||||||
|
; this version defines a defstruct which is not really the same
|
||||||
|
; as the IL record type.
|
||||||
|
(defun
|
||||||
|
define-record-structure (record-name record-fields named record-tail)
|
||||||
|
(let* ((name-string (symbol-name record-name))
|
||||||
|
(struct-name (intern name-string))
|
||||||
|
(*current-record-name* record-name)
|
||||||
|
(slots nil))
|
||||||
|
(declare (special *current-record-name*))
|
||||||
|
(setq record-fields (make-true-list record-fields))
|
||||||
|
(do ((fields record-fields (rest fields))
|
||||||
|
field)
|
||||||
|
((null fields) (setq slots (nreverse slots)))
|
||||||
|
(setq field (first fields))
|
||||||
|
(cond
|
||||||
|
((null field )
|
||||||
|
(warn \"NIL as record field name not supported\"))
|
||||||
|
((atom field) (push field slots))
|
||||||
|
((eq (first field) '*)) ;Ignore comments
|
||||||
|
(t (setq slots (append (reverse (flatten field)) slots)))))
|
||||||
|
(setf (gethash struct-name *record-types*) slots)
|
||||||
|
(multiple-value-bind
|
||||||
|
(record-tail-forms record-tail-inits)
|
||||||
|
(process-record-tail record-tail)
|
||||||
|
(add-exports
|
||||||
|
`((defstruct
|
||||||
|
,struct-name
|
||||||
|
(:type list)
|
||||||
|
(:named ,named)
|
||||||
|
,@(mapcar
|
||||||
|
#'(lambda (slot &aux pair)
|
||||||
|
(if (setq pair (assoc slot record-tail-inits))
|
||||||
|
`(,slot ,(cdr pair))
|
||||||
|
slot))
|
||||||
|
slots))
|
||||||
|
,@record-tail-forms)))))
|
||||||
|
") (IL:* IL:|;;| "Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.") (IL:FUNCTIONS PROCESS-RECORD-TAIL) (IL:* IL:|;;| "Define user-created access functions. It doesn't matter if these fields are part of the structure or not. If so, they will redefine the access functions created by defstruct.") (IL:FUNCTIONS ACCESSFNS) (IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))") (IL:FUNCTIONS DATATYPE FIELD-TO-SLOT-TYPE /DECLAREDATATYPE FIND-RECORD-TYPE FIND-RECORD-FIELDS |fetch| |replace| TYPE? |create| |DO-create|) (IL:P (IL-COPYCONV |fetch| FETCH) (IL-COPYCONV |fetch| |ffetch|) (IL-COPYCONV |ffetch| FFETCH) (IL-COPYCONV |replace| REPLACE) (IL-COPYCONV |replace| |freplace|) (IL-COPYCONV |freplace| FREPLACE) (IL-COPYCONV TYPE? |type?|) (IL-COPYCONV |create| CREATE)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-RECORD))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:\| "chapter 8")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFVAR *RECORD-TYPES* (MAKE-HASH-TABLE :SIZE 100))
|
||||||
|
|
||||||
|
(DEFUN ADD-EXPORTS (FORMS &AUX (EXPORT-LIST NIL)) (DOLIST (FORM FORMS) (AND (CONSP FORM) (MEMBER (FIRST FORM) (QUOTE (DEFUN DEFMACRO)) :TEST (FUNCTION EQ)) (PUSH (SECOND FORM) EXPORT-LIST))) (IF EXPORT-LIST (IL:BQUOTE (PROGN (EXPORT (QUOTE (IL:\\\, (REVERSE EXPORT-LIST)))) (IL:\\\,@ FORMS))) (PROGN-IF-NEEDED FORMS)))
|
||||||
|
|
||||||
|
(IL-DEFCONV ASSOCRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ASSOCRECORD not supported") (IL:* IL:|;;| "
|
||||||
|
(setf
|
||||||
|
(gethash record-name *record-types*)
|
||||||
|
(mapcar #'car record-fields))
|
||||||
|
(process-record-tail record-tail)
|
||||||
|
"))
|
||||||
|
|
||||||
|
(IL-DEFCONV PROPRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "PROPRECORD not supported") (IL:* IL:|;;| "
|
||||||
|
(setf
|
||||||
|
(gethash record-name *record-types*)
|
||||||
|
(do ((fields record-fields (rest (rest fields)))
|
||||||
|
(slots nil))
|
||||||
|
((endp fields) (nreverse slots))
|
||||||
|
(push (first fields) slots))
|
||||||
|
(process-record-tail record-tail))
|
||||||
|
"))
|
||||||
|
|
||||||
|
(IL-DEFCONV ATOMRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ATOMRECORD not supported"))
|
||||||
|
|
||||||
|
(IL-DEFCONV BLOCKRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-TAIL)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (WARN "BLOCKRECORD not supported") (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) (SLOTS NIL) FIELD) ((ENDP FIELDS) (SETF (GETHASH RECORD-NAME *RECORD-TYPES*) (IF (BOUNDP (QUOTE *ADD-TO-RECORD-DEFN*)) (APPEND (NREVERSE SLOTS) (GETHASH RECORD-NAME *RECORD-TYPES*)) (NREVERSE SLOTS)))) (SETQ FIELD (FIRST FIELDS)) (WHEN (CONSP FIELD) (SETQ FIELD (FIRST FIELD))) (WHEN (AND FIELD (NOT (INTEGERP FIELD))) (PUSH FIELD SLOTS))) NIL)
|
||||||
|
|
||||||
|
(IL-DEFCONV ARRAYRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DEFINE-ARRAYRECORD-STRUCTURE RECORD-NAME RECORD-FIELDS RECORD-TAIL))
|
||||||
|
|
||||||
|
(DEFUN DEFINE-ARRAYRECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS RECORD-TAIL) (LET ((*CURRENT-RECORD-NAME* RECORD-NAME)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (FIELD-FNS NIL) (INITS NIL) (KEYS NIL) CREATE-FN (LENGTH 0)) (DO ((I 0 (1+ I)) (FIELDS RECORD-FIELDS (REST FIELDS)) FIELD) ((ENDP FIELDS) (SETQ FIELD-FNS (NREVERSE FIELD-FNS)) (SETQ INITS (NREVERSE INITS)) (SETQ KEYS (NREVERSE KEYS))) (IL:* IL:|;;| "Define accessor functions. We don't need to define") (IL:* IL:|;;| "setf methods because the accessors are actually") (IL:* IL:|;;| "macros which generate calls to svref, and setf") (IL:* IL:\; "already knows how to handle svref.") (SETQ FIELD (FIRST FIELDS)) (INCF LENGTH) (COND ((INTEGERP FIELD) (INCF I (1- FIELD)) (INCF LENGTH (1- FIELD))) ((NULL FIELD)) (T (PUSH (IL:BQUOTE (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME FIELD)))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (SVREF (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X))) (IL:\\\, I))))))) FIELD-FNS) (LET ((SVAR (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME FIELD) "-SET")))) (PUSH (IL:BQUOTE (WHEN (IL:\\\, SVAR) (SETF (SVREF $X$ (IL:\\\, I)) (IL:\\\, FIELD)))) INITS) (PUSH (IL:BQUOTE ((IL:\\\, FIELD) (IL:\\\, (CDR (ASSOC FIELD RECORD-TAIL-INITS))) (IL:\\\, SVAR))) KEYS))))) (SETQ CREATE-FN (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ KEYS)) (LET (($X$) (MAKE-ARRAY (IL:\\\, LENGTH))) (IL:\\\,@ INITS) $X$)))) (ADD-EXPORTS (IL:BQUOTE ((IL:\\\, CREATE-FN) (IL:\\\,@ FIELD-FNS) (IL:\\\,@ RECORD-TAIL-FORMS))))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFUN INTERLISP-COMMENT-P (X) (AND (CONSP X) (EQ (FIRST X) (QUOTE *))))
|
||||||
|
|
||||||
|
(IL-DEFCONV RECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) NIL (REST (REST ARGS))))
|
||||||
|
|
||||||
|
(IL-DEFCONV TYPERECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) T (REST (REST ARGS))))
|
||||||
|
|
||||||
|
(DEFUN FLATTEN (X) (COND ((CONSP X) (APPEND (FLATTEN (CAR X)) (FLATTEN (CDR X)))) ((NULL X) NIL) (T (CONS X NIL))))
|
||||||
|
|
||||||
|
(DEFUN MAKE-RECORD-ACCESSORS (RECORD-NAME TREE PATH) (COND ((NULL TREE) NIL) ((ATOM TREE) (LET ((ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) RECORD-NAME "-" (SYMBOL-NAME TREE))))) (IL:BQUOTE ((DEFSETF (IL:\\\, ACCESSOR-NAME) (X) (VAL) (LIST (QUOTE SETF) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ)))) VAL)) (DEFMACRO (IL:\\\, ACCESSOR-NAME) (X) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ))))))))) ((EQ (CAR TREE) (QUOTE *)) NIL) (T (APPEND (MAKE-RECORD-ACCESSORS RECORD-NAME (CAR TREE) (IL:BQUOTE (CAR (IL:\\\, PATH)))) (MAKE-RECORD-ACCESSORS RECORD-NAME (CDR TREE) (IL:BQUOTE (CDR (IL:\\\, PATH))))))))
|
||||||
|
|
||||||
|
(DEFUN DEFINE-RECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS NAMED RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) (SLOTS (REMOVE-IF (FUNCTION NULL) (FLATTEN RECORD-FIELDS))) (ACCESSORS (MAKE-RECORD-ACCESSORS NAME-STRING RECORD-FIELDS (IF NAMED (QUOTE (CDR T)) T)))) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (ADD-EXPORTS (IL:BQUOTE ((DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT &AUX PAIR) (IF (SETQ PAIR (ASSOC SLOT RECORD-TAIL-INITS :TEST (FUNCTION EQ))) (LIST SLOT (CDR PAIR)) SLOT))) SLOTS))) (IL:\\\, (MAKE-BQ (LET ((FORM (SUBLIS (MAPCAR (FUNCTION (LAMBDA (SLOT) (CONS SLOT (MAKE-MACRO-ARG :ELEMENT SLOT)))) SLOTS) RECORD-FIELDS))) (IF NAMED (CONS RECORD-NAME FORM) FORM))))) (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (COPY-TREE (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X)))))))) (IL:\\\,@ ACCESSORS) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"
|
||||||
|
; this version defines a defstruct which is not really the same
|
||||||
|
; as the IL record type.
|
||||||
|
(defun
|
||||||
|
define-record-structure (record-name record-fields named record-tail)
|
||||||
|
(let* ((name-string (symbol-name record-name))
|
||||||
|
(struct-name (intern name-string))
|
||||||
|
(*current-record-name* record-name)
|
||||||
|
(slots nil))
|
||||||
|
(declare (special *current-record-name*))
|
||||||
|
(setq record-fields (make-true-list record-fields))
|
||||||
|
(do ((fields record-fields (rest fields))
|
||||||
|
field)
|
||||||
|
((null fields) (setq slots (nreverse slots)))
|
||||||
|
(setq field (first fields))
|
||||||
|
(cond
|
||||||
|
((null field )
|
||||||
|
(warn \"NIL as record field name not supported\"))
|
||||||
|
((atom field) (push field slots))
|
||||||
|
((eq (first field) '*)) ;Ignore comments
|
||||||
|
(t (setq slots (append (reverse (flatten field)) slots)))))
|
||||||
|
(setf (gethash struct-name *record-types*) slots)
|
||||||
|
(multiple-value-bind
|
||||||
|
(record-tail-forms record-tail-inits)
|
||||||
|
(process-record-tail record-tail)
|
||||||
|
(add-exports
|
||||||
|
`((defstruct
|
||||||
|
,struct-name
|
||||||
|
(:type list)
|
||||||
|
(:named ,named)
|
||||||
|
,@(mapcar
|
||||||
|
#'(lambda (slot &aux pair)
|
||||||
|
(if (setq pair (assoc slot record-tail-inits))
|
||||||
|
`(,slot ,(cdr pair))
|
||||||
|
slot))
|
||||||
|
slots))
|
||||||
|
,@record-tail-forms)))))
|
||||||
|
")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFUN PROCESS-RECORD-TAIL (RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((SPECS RECORD-TAIL (REST SPECS)) SPEC (FORMS NIL) (INITS NIL)) ((ENDP SPECS) (VALUES FORMS (REVERSE INITS))) (COND ((AND (ATOM (FIRST SPECS)) (REST SPECS) (EQ (SECOND SPECS) (QUOTE IL:_))) (IF (EQ *CURRENT-RECORD-NAME* (FIRST SPECS)) (WARN "implicit CREATE record spec (by assignment to record name) not supported") (PUSH (CONS (FIRST SPECS) (CONVERT (THIRD SPECS))) INITS)) (IL:* IL:|;;| "A \"field-name _ form\" spec is not a list -- it is") (IL:* IL:|;;| "three separate entries in the record-tail.") (POP SPECS) (POP SPECS)) (T (IL:* IL:\; "All others are lists.") (SETQ SPEC (FIRST SPECS)) (CASE (FIRST SPEC) ((IL:CREATE IL:INIT IL:SUBRECORD IL:SYSTEM) (WARN "~:@(~s~) record spec not supported" (FIRST SPEC))) (IL:TYPE? (PUSH (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME *CURRENT-RECORD-NAME*) "-P"))) (DATUM) (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (IL:\\\,@ (MAPCONVERT (REST SPEC)))))) FORMS)) ((IL:ACCESSFNS IL:BLOCKRECORD) (LET ((*ADD-TO-RECORD-DEFN* T)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (SETQ FORMS (APPEND FORMS (LIST (CONVERT SPEC)))))) (T (WARN "unknown record spec ~s ignored" SPEC)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;|
|
||||||
|
"Define user-created access functions. It doesn't matter if these fields are part of the structure or not. If so, they will redefine the access functions created by defstruct."
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(IL-DEFCONV ACCESSFNS (RECORD-NAME &OPTIONAL RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DECLARE (SPECIAL *LOCALS*)) (IL:* IL:|;;| "The manual says the record name is the first argument, but it appears that sometimes it is missing when this is a subdeclaration, so we get it from a special variable which is set while processing the main declaration.") (UNLESS (ATOM RECORD-NAME) (SETQ RECORD-FIELDS RECORD-NAME RECORD-NAME *CURRENT-RECORD-NAME*)) (WHEN) (DO ((FORMS NIL) FIELD FIELD-NAME ACCESSOR-NAME (FIELDS (IF (AND (= (LENGTH RECORD-FIELDS) 2) (ATOM (FIRST RECORD-FIELDS))) (IL:* IL:|;;| "Pidgin single accessfn declaration...") (LIST RECORD-FIELDS) RECORD-FIELDS) (REST FIELDS))) ((ENDP FIELDS) (ADD-EXPORTS (REVERSE FORMS))) (SETQ FIELD (FIRST FIELDS)) (SETQ FIELD-NAME (POP FIELD)) (SETQ ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:* IL:\; "Define the accessor function") (WHEN FIELD (IL:* IL:|;;| "Also remember that we know about this field") (PUSH FIELD-NAME (GETHASH RECORD-NAME *RECORD-TYPES*)) (PUSH (IL:BQUOTE (DEFUN (IL:\\\, ACCESSOR-NAME) (DATUM) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (CONVERT (POP FIELD)))))) FORMS) (IL:* IL:\; "Define the function to set a new value") (WHEN FIELD (PUSH (IL:BQUOTE (DEFSETF (IL:\\\, ACCESSOR-NAME) (DATUM) (NEWVALUE) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE NEWVALUE) :LOCAL (ACONS (QUOTE DATUM) :LOCAL *LOCALS*)))) (CONVERT (POP FIELD)))))) FORMS)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))")
|
||||||
|
|
||||||
|
|
||||||
|
(IL-DEFCONV DATATYPE (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) RECORD-TAIL-FORMS RECORD-TAIL-INITS (SLOTS NIL) (SLOT-DEFNS NIL) (FIELD-TYPES NIL)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) SLOT-NAME FIELD-TYPE FIELD) ((ENDP FIELDS) (SETQ SLOTS (NREVERSE SLOTS))) (SETQ FIELD (FIRST FIELDS)) (SETQ SLOT-NAME (COND ((CONSP FIELD) (CASE (FIRST FIELD) ((NIL) (IL:* IL:|;;| "Some code has field specs like \"(nil 5 word))\"") (WARN "record spec ~s ignored -- NIL not allowed as field name" FIELD) NIL) (IL:* NIL) (IL:* IL:\; "Ignore comments") (T (SETQ FIELD-TYPE (REST FIELD)) (FIRST FIELD)))) (T (SETQ FIELD-TYPE NIL) FIELD))) (WHEN SLOT-NAME (PUSH SLOT-NAME SLOTS) (PUSH FIELD-TYPE FIELD-TYPES))) (IL:* IL:|;;| "Have to set the field names defined here before calling") (IL:* IL:|;;| "process-record-tail since it will add to them.") (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-SETQ (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL)) (IL:* IL:|;;| "This could be changed to a mapcar. Previous definitions of il-defconv") (IL:* IL:|;;| "for some reason did not correctly handle lambda's.") (DO ((SLOTS SLOTS (REST SLOTS)) (FIELD-TYPES FIELD-TYPES (REST FIELD-TYPES)) SLOT-NAME FIELD-TYPE) ((ENDP SLOTS) (SETQ SLOT-DEFNS (NREVERSE SLOT-DEFNS))) (SETQ SLOT-NAME (FIRST SLOTS) FIELD-TYPE (FIRST FIELD-TYPES)) (PUSH (IL:BQUOTE ((IL:\\\, SLOT-NAME) (IL:\\\, (CDR (ASSOC SLOT-NAME RECORD-TAIL-INITS))) :TYPE (IL:\\\, (FIELD-TO-SLOT-TYPE FIELD-TYPE SLOT-NAME)))) SLOT-DEFNS)) (LET ((NAME-STRING (SYMBOL-NAME STRUCT-NAME))) (PROGN-IF-NEEDED (IL:BQUOTE ((EXPORT (QUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-P"))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT) (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME SLOT))))) SLOTS))))) (DEFSTRUCT (IL:\\\, STRUCT-NAME) (IL:\\\,@ SLOT-DEFNS)) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
|
||||||
|
|
||||||
|
(DEFUN FIELD-TO-SLOT-TYPE (TYPE &OPTIONAL SLOT-NAME) (IF (NULL TYPE) T (CASE (FIRST TYPE) (INTEGER (QUOTE INTEGER)) ((IL:FIXP IL:SIGNEDWORD) (QUOTE FIXNUM)) ((IL:FLOATING IL:FLOATP) (QUOTE FLOAT)) (IL:FLAG (QUOTE (OR NIL T))) (IL:BITS (IF (<= (1- (EXPT 2 (SECOND TYPE))) MOST-POSITIVE-FIXNUM) (QUOTE FIXNUM) (QUOTE INTEGER))) (BYTE (QUOTE FIXNUM)) (IL:WORD (QUOTE FIXNUM)) ((IL:POINTER IL:XPOINTER IL:FULLPOINTER IL:FULLXPOINTER) T) (T (WARN "Unknown type spec ~:@(~a~)~:[~; for slot ~:*~:@(~a~)~]" (FIRST TYPE) SLOT-NAME) T))))
|
||||||
|
|
||||||
|
(IL-DEFCONV /DECLAREDATATYPE (&REST ARGS) (WARN "/DECLAREDATATYPE ignored") NIL)
|
||||||
|
|
||||||
|
(DEFUN FIND-RECORD-TYPE (FIELDNAME) (LET ((RECORD-TYPES NIL)) (MAPHASH (FUNCTION (LAMBDA (RECORD-NAME FIELDS) (WHEN (MEMBER FIELDNAME FIELDS :TEST (FUNCTION EQ)) (PUSH RECORD-NAME RECORD-TYPES)))) *RECORD-TYPES*) (CASE (LENGTH RECORD-TYPES) (0 (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELDNAME FIELDNAME) (QUOTE XXXXX)) (1 (CAR RECORD-TYPES)) (T (CERROR "use ~a" "~*multiple record types have a field named ~s: ~s" (CAR RECORD-TYPES) FIELDNAME RECORD-TYPES) (CAR RECORD-TYPES)))))
|
||||||
|
|
||||||
|
(DEFUN FIND-RECORD-FIELDS (RECORD-TYPE) (MULTIPLE-VALUE-BIND (RECORD FOUND) (GETHASH RECORD-TYPE *RECORD-TYPES*) (IF FOUND RECORD (PROGN (WARN "no record type ~a, initializations may not be done" RECORD-TYPE) NIL))))
|
||||||
|
|
||||||
|
(IL-DEFCONV |fetch| (FIELD-NAME OF &OPTIONAL X &AUX RECORD-TYPE) (DECLARE (SPECIAL IL:USERRECLST)) (WHEN (NOT (STRING-EQUAL OF "of")) (SETQ X OF)) (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/RECFIELDLOOK IL:USERRECLST FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X)))))
|
||||||
|
|
||||||
|
(IL-DEFCONV |replace| (FIELD-NAME OF X WITH Y &AUX RECORD-TYPE) (COND ((NOT (STRING-EQUAL OF "OF")) (CERROR "Skip this form" "Missing |of| in |replace|") *CURRENT-FORM*) ((NOT (STRING-EQUAL WITH "WITH")) (CERROR "Skip this form" "Missing |with| in |replace|") *CURRENT-FORM*) (T (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/ACCESSDEF FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE (SETF ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X))) (IL:\\\, (CONVERT Y)))))))
|
||||||
|
|
||||||
|
(IL-DEFCONV TYPE? (RECORD-NAME FORM) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-P"))) (IL:\\\, (CONVERT FORM)))))
|
||||||
|
|
||||||
|
(IL-DEFCONV |create| (RECORD-NAME &REST ASSIGNMENTS) (|DO-create| RECORD-NAME ASSIGNMENTS))
|
||||||
|
|
||||||
|
(DEFUN |DO-create| (RECORD-NAME ASSIGNMENTS) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (INITS NIL) (SMASHING NIL) (USING NIL) (VAR (MAKE-FAKE-SYMBOL (STRING (GENSYM "G"))))) (DO ((ASSIGNMENTS ASSIGNMENTS (REST ASSIGNMENTS))) ((ENDP ASSIGNMENTS) (SETQ INITS (REVERSE INITS))) (COND ((AND (CONSP (FIRST ASSIGNMENTS)) (STRING-EQUAL (CAAR ASSIGNMENTS) (QUOTE "*")))) ((AND (SYMBOLP (SECOND ASSIGNMENTS)) (STRING-EQUAL (SECOND ASSIGNMENTS) "_")) (PUSH (CONS (FIRST ASSIGNMENTS) (CONVERT (THIRD ASSIGNMENTS))) INITS) (SETQ ASSIGNMENTS (CDDR ASSIGNMENTS))) (T (CASE (FIRST ASSIGNMENTS) ((IL:USING IL:|using|) (SETQ USING (CONVERT (SECOND ASSIGNMENTS)))) ((IL:COPYING IL:|copying|) (WARN "COPYING assignment not supported")) ((IL:REUSING IL:|reusing|) (WARN "REUSING assignment not supported")) ((IL:SMASHING IL:|smashing|) (SETQ SMASHING (CONVERT (SECOND ASSIGNMENTS)))) (T (WARN "unknown assignment ~s" (FIRST ASSIGNMENTS)))) (POP ASSIGNMENTS)))) (COND (USING (IL:BQUOTE (LET (((IL:\\\, VAR) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, USING)))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR)))) (SMASHING (IF INITS (IL:BQUOTE (LET (((IL:\\\, VAR) (IL:\\\, SMASHING))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR))) SMASHING)) (T (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (IL:BQUOTE ((IL:\\\, (INTERN (STRING (CAR INIT)) (QUOTE KEYWORD))) (IL:\\\, (CDR INIT)))))) INITS))))))))
|
||||||
|
|
||||||
|
(IL-COPYCONV |fetch| FETCH)
|
||||||
|
|
||||||
|
(IL-COPYCONV |fetch| |ffetch|)
|
||||||
|
|
||||||
|
(IL-COPYCONV |ffetch| FFETCH)
|
||||||
|
|
||||||
|
(IL-COPYCONV |replace| REPLACE)
|
||||||
|
|
||||||
|
(IL-COPYCONV |replace| |freplace|)
|
||||||
|
|
||||||
|
(IL-COPYCONV |freplace| FREPLACE)
|
||||||
|
|
||||||
|
(IL-COPYCONV TYPE? |type?|)
|
||||||
|
|
||||||
|
(IL-COPYCONV |create| CREATE)
|
||||||
|
|
||||||
|
(IL:PUTPROPS IL:IL-RECORD IL:MAKEFILE-ENVIRONMENT (:PACKAGE "IL-CONVERT" :READTABLE "XCL"))
|
||||||
|
(IL:PUTPROPS IL:IL-RECORD IL:COPYRIGHT ("ENVOS Corporation" 1989))
|
||||||
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
|
(IL:FILEMAP (NIL)))
|
||||||
|
IL:STOP
|
||||||
1
lispusers/MIGRATION/IL-RECORD.LCOM
Normal file
1
lispusers/MIGRATION/IL-RECORD.LCOM
Normal file
File diff suppressed because one or more lines are too long
1356
lispusers/MIGRATION/IL-SIM
Normal file
1356
lispusers/MIGRATION/IL-SIM
Normal file
File diff suppressed because one or more lines are too long
1
lispusers/MIGRATION/IL-SIM.LCOM
Normal file
1
lispusers/MIGRATION/IL-SIM.LCOM
Normal file
File diff suppressed because one or more lines are too long
90
lispusers/MIGRATION/IL-STARTUP
Normal file
90
lispusers/MIGRATION/IL-STARTUP
Normal file
@@ -0,0 +1,90 @@
|
|||||||
|
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CL IN-PACKAGE "IL-CONVERT")
|
||||||
|
*PACKAGE*) BASE 10)
|
||||||
|
(IL:FILECREATED "14-Sep-89 10:01:13" IL:|{DSK}/python2/aria/migration/interlisp/IL-STARTUP.;2| 6548
|
||||||
|
|
||||||
|
IL:|changes| IL:|to:| (IL:FUNCTIONS NOTE-EXPORTED-SYMBOL CONVERT)
|
||||||
|
|
||||||
|
IL:|previous| IL:|date:| " 7-Jul-89 16:55:06" IL:|{DSK}/users/eweaver/convert/IL-STARTUP.;17|
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
; Copyright (c) 1989 by ENVOS Corporation. All rights reserved.
|
||||||
|
|
||||||
|
(IL:PRETTYCOMPRINT IL:IL-STARTUPCOMS)
|
||||||
|
|
||||||
|
(IL:RPAQQ IL:IL-STARTUPCOMS ((IL:* IL:|;;;| "This should be loaded before any other files.") (EVAL-WHEN (LOAD COMPILE EVAL) (IL:VARIABLES *IL-PACKAGE*)) (IL:VARIABLES *IL-SIM-PACKAGE*) (IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ") (IL:STRUCTURES BQ MACRO-ARG) (IL:* IL:|;;;| "") (IL:VARIABLES *CURRENT-CONVERT-FORM* *CURRENT-CONVERT-FUNCTION* *GLOBALS* *LOCALS* *FUNCTION-CALLS* *CURRENT-FUNCTION-CALLS* *CURRENT-FREE-REFERENCES* *EXPORTED-IL-SYMBOLS*) (IL:P (EXPORT (QUOTE CONVERT))) (IL:FUNCTIONS CONVERT MAPCONVERT EXTERN NOTE-EXPORTED-SYMBOL) (IL:FUNCTIONS TRUE-LIST-P) (IL:* IL:\; "true if this is nil or a true list") (IL:* IL:|;;| "make a true list out of a pseudo-list (make-true-list '(A B . C)) => (A B C)") (IL:FUNCTIONS MAKE-TRUE-LIST) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-STARTUP))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;;| "This should be loaded before any other files.")
|
||||||
|
|
||||||
|
(EVAL-WHEN (LOAD COMPILE EVAL)
|
||||||
|
|
||||||
|
(DEFVAR *IL-PACKAGE* (FIND-PACKAGE "INTERLISP"))
|
||||||
|
)
|
||||||
|
|
||||||
|
(DEFVAR *IL-SIM-PACKAGE* (MAKE-PACKAGE "IL-SIM" :USE NIL))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFSTRUCT (BQ (:TYPE LIST) (:CONSTRUCTOR MAKE-BQ (ELEMENT))) (BQFLAG (QUOTE IL:BQUOTE)) ELEMENT)
|
||||||
|
|
||||||
|
(DEFSTRUCT (MACRO-ARG (:TYPE LIST) (:CONSTRUCTOR MAKE-MACRO-ARG (&KEY ELEMENT APPEND-P (FLAG (IF APPEND-P (QUOTE IL:\\\,@) (QUOTE IL:\\\,)))))) FLAG ELEMENT)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;;| "")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-CONVERT-FORM*)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-CONVERT-FUNCTION*)
|
||||||
|
|
||||||
|
(DEFVAR *GLOBALS* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *LOCALS* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *FUNCTION-CALLS* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-FUNCTION-CALLS* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *CURRENT-FREE-REFERENCES* NIL)
|
||||||
|
|
||||||
|
(DEFVAR *EXPORTED-IL-SYMBOLS* NIL)
|
||||||
|
|
||||||
|
(EXPORT (QUOTE CONVERT))
|
||||||
|
|
||||||
|
(DEFUN CONVERT (FORM &AUX FN VAR) (IL:BLOCK) (LET ((*CURRENT-EXPRESSION* FORM)) (COND (IL:* IL:|;;| "Forms in which the car is a symbol...") ((AND (CONSP FORM) (ATOM (FIRST FORM))) (COND ((NOT (TRUE-LIST-P FORM)) (LET ((TAIL (CDR (LAST FORM)))) (IL:* IL:|;;| "dotted lists ending in a macro arg are okay.") (IF (AND (SYMBOLP TAIL) (EQ (CDR (ASSOC TAIL *LOCALS*)) :MACRO-ARG)) (LET ((MARG (MAKE-MACRO-ARG :ELEMENT TAIL)) (VAL (COPY-LIST FORM))) (SETF (CDR (LAST VAL)) MARG) VAL) (PROGN (WARN "~s not a list, left as is" FORM) FORM)))) ((LET ((FOO (GET (CAR FORM) (QUOTE IL:CLISPWORD)))) (AND (CONSP FOO) (EQ (CAR FOO) (QUOTE IL:FORWORD)) (NOT (EQ (CAR FORM) (QUOTE DECLARE))))) (CONVERT-ITERATION-STATEMENT (CAR FORM) (CDR FORM))) ((SETQ FN (GET (FIRST FORM) (QUOTE CONVERT-FORM))) (SETQ *CURRENT-CONVERT-FORM* FORM *CURRENT-CONVERT-FUNCTION* FN) (APPLY FN (REST FORM))) ((OR (MACRO-FUNCTION (FIRST FORM)) (SPECIAL-FORM-P (FIRST FORM))) (IL:* IL:|;;| "Use CL code walker for this") (WALK-FORM-INTERNAL FORM)) ((EQ (CHAR (STRING (FIRST FORM)) 0) #\\) (WARN "Untranslatable function ~a" (STRING (FIRST FORM))) FORM) (T (IL:* IL:|;;| "(setq fn (first form) (extern (symbol-name (first form)) *il-package*))") (WHEN *CURRENT-FUNCTION-CALLS* (PUSHNEW FN *CURRENT-FUNCTION-CALLS*)) (NOTE-EXPORTED-SYMBOL (FIRST FORM)) (CONS (FIRST FORM) (MAPCAR (QUOTE CONVERT) (REST FORM)))))) (IL:* IL:|;;| "Forms in which the car is a Lambda...") ((AND (CONSP FORM) (IL:* IL:|;;| "But car is cons") (SYMBOLP (CAAR FORM)) (STRING-EQUAL (CAAR FORM) "LAMBDA")) (CONS (CONVERT (CAR FORM)) (MAPCONVERT (CDR FORM)))) (IL:* IL:|;;| "Other non-atomic forms...") ((CONSP FORM) (WARN "Unknown kind of form ~s, not converted." FORM) FORM) (IL:* IL:|;;| "Atomic forms...") ((NULL FORM) NIL) ((EQ FORM T) T) ((KEYWORDP FORM) FORM) ((SYMBOLP FORM) (IF (SETQ VAR (ASSOC FORM *LOCALS*)) (CASE (CDR VAR) (:LOCAL (CAR VAR)) (:MACRO-ARG (MAKE-MACRO-ARG :ELEMENT (CAR VAR))) (T (ERROR "unexpected value ~s in *LOCALS*" VAR))) (PROGN (NOTE-EXPORTED-SYMBOL FORM) (WHEN *CURRENT-FREE-REFERENCES* (PUSHNEW FORM *CURRENT-FREE-REFERENCES*)) FORM))) (T FORM))))
|
||||||
|
|
||||||
|
(DEFUN MAPCONVERT (FORM-OR-FORMS) (IF (ATOM FORM-OR-FORMS) (CONVERT FORM-OR-FORMS) (DO* ((TAIL FORM-OR-FORMS (CDR TAIL)) (SUBFORM (IF (CONSP TAIL) (CAR TAIL) TAIL) (IF (CONSP TAIL) (CAR TAIL) TAIL)) RESULT) ((ATOM TAIL) (IF (NULL TAIL) (NREVERSE RESULT) (PROGN (SETF (CDR (LAST (SETQ RESULT (NREVERSE RESULT)))) (CONVERT TAIL)) RESULT))) (PUSH (CONVERT SUBFORM) RESULT))))
|
||||||
|
|
||||||
|
(DEFUN EXTERN (STRING &OPTIONAL (PACKAGE *PACKAGE*)) (IL:* (LET ((SYM (INTERN STRING PACKAGE))) (EXPORT SYM PACKAGE) (IF (EQ PACKAGE *IL-PACKAGE*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*)) SYM)) (ERROR "Old leftover call to EXTERN!"))
|
||||||
|
|
||||||
|
(DEFUN NOTE-EXPORTED-SYMBOL (SYM &AUX PKG PKGNM) "" (WHEN (NULL (SETQ PKG (SYMBOL-PACKAGE SYM))) (RETURN-FROM NOTE-EXPORTED-SYMBOL SYM)) (WHEN (AND (EQ PKG IL:*INTERLISP-PACKAGE*) (NOT (EQ (FIND-SYMBOL (SYMBOL-NAME SYM) IL:*LISP-PACKAGE*) SYM)) (OR *WARN-FOR-ALL-IL-SYMBOLS* (< (IL:\\LOLOC SYM) (IL:\\LOLOC *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS*)))) (LET ((*CURRENT-EXPRESSION* SYM)) (WARN "Use of IL symbol ~a" SYM))) (WHEN (OR (EQ PKG IL:*INTERLISP-PACKAGE*) (AND (NOT (OR (EQ PKG IL:*KEYWORD-PACKAGE*) (EQ PKG IL:*LISP-PACKAGE*))) (MULTIPLE-VALUE-BIND (IGNORE TYPE) (FIND-SYMBOL (SYMBOL-NAME SYM) PKG) (EQ TYPE :EXTERNAL)))) (IF (NULL *FILE-CONTEXT*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*) (PUSHNEW SYM (FILE-CONTEXT-EXPORTED-SYMS *FILE-CONTEXT*)))) SYM)
|
||||||
|
|
||||||
|
(DEFUN TRUE-LIST-P (PSEUDO-LIST) (DO ((PL PSEUDO-LIST (CDR PL))) ((NULL PL) T) (IF (ATOM PL) (RETURN NIL))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:\; "true if this is nil or a true list")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(IL:* IL:|;;| "make a true list out of a pseudo-list (make-true-list '(A B . C)) => (A B C)")
|
||||||
|
|
||||||
|
|
||||||
|
(DEFUN MAKE-TRUE-LIST (PSEUDO-LIST) (COND ((TRUE-LIST-P PSEUDO-LIST) PSEUDO-LIST) (T (DO ((TRUE-LIST NIL)) ((ATOM PSEUDO-LIST) (NREVERSE (CONS PSEUDO-LIST TRUE-LIST))) (IF (ENDP PSEUDO-LIST) (RETURN (NREVERSE TRUE-LIST))) (PUSH (POP PSEUDO-LIST) TRUE-LIST)))))
|
||||||
|
|
||||||
|
(IL:PUTPROPS IL:IL-STARTUP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (IN-PACKAGE "IL-CONVERT") *PACKAGE*) :BASE 10)
|
||||||
|
)
|
||||||
|
|
||||||
|
(IL:PUTPROPS IL:IL-STARTUP IL:FILETYPE :COMPILE-FILE)
|
||||||
|
(IL:PUTPROPS IL:IL-STARTUP IL:COPYRIGHT ("ENVOS Corporation" 1989))
|
||||||
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
|
(IL:FILEMAP (NIL)))
|
||||||
|
IL:STOP
|
||||||
1
lispusers/MIGRATION/IL-STARTUP.LCOM
Normal file
1
lispusers/MIGRATION/IL-STARTUP.LCOM
Normal file
File diff suppressed because one or more lines are too long
25
lispusers/MIGRATION/MIGRATION-TOOL
Normal file
25
lispusers/MIGRATION/MIGRATION-TOOL
Normal file
@@ -0,0 +1,25 @@
|
|||||||
|
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")
|
||||||
|
(IL:FILECREATED "26-Jan-90 10:27:59" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;2| 1091
|
||||||
|
|
||||||
|
IL:|changes| IL:|to:| (IL:FILES IL:IL-CONVERT)
|
||||||
|
|
||||||
|
IL:|previous| IL:|date:| "11-Aug-89 16:19:28" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;1|
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
|
||||||
|
|
||||||
|
(IL:PRETTYCOMPRINT IL:MIGRATION-TOOLCOMS)
|
||||||
|
|
||||||
|
(IL:RPAQQ IL:MIGRATION-TOOLCOMS ((IL:PROP IL:MAKEFILE-ENVIRONMENT IL:MIGRATION-TOOL)
|
||||||
|
(IL:FILES IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD
|
||||||
|
IL:TRANSLATOR-ASSISTANT)))
|
||||||
|
|
||||||
|
(IL:PUTPROPS IL:MIGRATION-TOOL IL:MAKEFILE-ENVIRONMENT (:PACKAGE (XCL:DEFPACKAGE "IL-CONVERT")
|
||||||
|
:READTABLE "XCL"))
|
||||||
|
|
||||||
|
(IL:FILESLOAD IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD IL:TRANSLATOR-ASSISTANT)
|
||||||
|
(IL:PUTPROPS IL:MIGRATION-TOOL IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
|
||||||
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
|
(IL:FILEMAP (NIL)))
|
||||||
|
IL:STOP
|
||||||
1
lispusers/MIGRATION/MIGRATION-TOOL.LCOM
Normal file
1
lispusers/MIGRATION/MIGRATION-TOOL.LCOM
Normal file
@@ -0,0 +1 @@
|
|||||||
|
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")
|
||||||
242
lispusers/MIGRATION/SEDIT-DECLS
Normal file
242
lispusers/MIGRATION/SEDIT-DECLS
Normal file
File diff suppressed because one or more lines are too long
1
lispusers/MIGRATION/SEDIT-DECLS.LCOM
Normal file
1
lispusers/MIGRATION/SEDIT-DECLS.LCOM
Normal file
File diff suppressed because one or more lines are too long
35
lispusers/MIGRATION/TABLEBROWSERDECLS
Normal file
35
lispusers/MIGRATION/TABLEBROWSERDECLS
Normal file
@@ -0,0 +1,35 @@
|
|||||||
|
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||||
|
(FILECREATED "27-Jan-88 17:04:01" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;5 5052
|
||||||
|
|
||||||
|
changes to%: (RECORDS TABLEBROWSER)
|
||||||
|
|
||||||
|
previous date%: "18-Oct-85 18:10:50" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;2)
|
||||||
|
|
||||||
|
|
||||||
|
(* "
|
||||||
|
Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved.
|
||||||
|
")
|
||||||
|
|
||||||
|
(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS)
|
||||||
|
|
||||||
|
(RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN)))
|
||||||
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
|
(DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; "True if creator set explicit item height or baseline") (NIL 6 FLAG) (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; "Number of lines occupied by each item, normally 1 (dunno if any other values work)") (TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item. If none selected, is > TB#ITEMS") (TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item. If none selected, is 0") (TBITEMHEIGHT WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; "Pointer to the display window. Need to snap this link when browser is closed") (TBLOCK POINTER) (* ; "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; "Window's extent, updated as items are added, deleted, or printfn prints farther to right") (TBUPDATEFROMHERE POINTER) (* ; "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; "Y position of the top of the first item") (TBTAILHINT POINTER) (* ; "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))
|
||||||
|
)
|
||||||
|
|
||||||
|
(DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
(/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER))) (QUOTE 48))
|
||||||
|
(/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)) (QUOTE ((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 (FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 0 POINTER) (TABLEITEM 2 (BITS . 15)) (TABLEITEM 3 (BITS . 15)))) (QUOTE 4))
|
||||||
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
|
(RPAQQ TB.LEFT.MARGIN 8)
|
||||||
|
|
||||||
|
(CONSTANTS TB.LEFT.MARGIN)
|
||||||
|
)
|
||||||
|
(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Xerox Corporation" 1985 1988))
|
||||||
|
(DECLARE%: DONTCOPY
|
||||||
|
(FILEMAP (NIL)))
|
||||||
|
STOP
|
||||||
1
lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM
Normal file
1
lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM
Normal file
File diff suppressed because one or more lines are too long
1646
lispusers/MIGRATION/TRANSLATOR-ASSISTANT
Normal file
1646
lispusers/MIGRATION/TRANSLATOR-ASSISTANT
Normal file
File diff suppressed because it is too large
Load Diff
@@ -1,11 +1,11 @@
|
|||||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED "11-Jun-2021 12:50:16"
|
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;18 10803
|
|
||||||
|
|
||||||
changes to%: (FNS ENABLEWHEELSCROLL)
|
(FILECREATED "23-Oct-2021 16:33:29" {DSK}<home>larry>medley>lispusers>WHEELSCROLL.;2 11221
|
||||||
|
|
||||||
previous date%: "11-Jun-2021 11:11:10"
|
changes to%: (VARS WHEELSCROLLCOMS)
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;14)
|
(FNS ENABLEWHEELSCROLL WHEELSCROLL)
|
||||||
|
|
||||||
|
previous date%: "11-Jun-2021 12:50:16" {DSK}<home>larry>medley>lispusers>WHEELSCROLL.;1)
|
||||||
|
|
||||||
|
|
||||||
(PRETTYCOMPRINT WHEELSCROLLCOMS)
|
(PRETTYCOMPRINT WHEELSCROLLCOMS)
|
||||||
@@ -14,15 +14,15 @@
|
|||||||
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL
|
[(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL
|
||||||
LISPINTERRUPTS.WHEELSCROLL)
|
LISPINTERRUPTS.WHEELSCROLL)
|
||||||
|
|
||||||
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
|
(* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")
|
||||||
|
|
||||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (UP 156)
|
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\WSUP 156)
|
||||||
(DOWN 157)
|
(\WSDOWN 157)
|
||||||
(LEFT 158)
|
(\WSLEFT 158)
|
||||||
(RIGHT 159)))
|
(\WSRIGHT 159)))
|
||||||
(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
|
(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
|
||||||
|
|
||||||
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
|
(* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")
|
||||||
|
|
||||||
[ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
|
[ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
|
||||||
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
|
(AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
|
||||||
@@ -35,65 +35,69 @@
|
|||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(ENABLEWHEELSCROLL
|
(ENABLEWHEELSCROLL
|
||||||
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ; "Edited 11-Jun-2021 12:50 by rmk:")
|
[LAMBDA (ON EXCLUDEHORIZONTAL) (* ;
|
||||||
(* ; "Edited 28-May-2021 11:46 by rmk:")
|
"Edited 23-Oct-2021 16:31 by larry")
|
||||||
|
(* ;
|
||||||
|
"Edited 11-Jun-2021 12:50 by rmk:")
|
||||||
|
(* ;
|
||||||
|
"Edited 28-May-2021 11:46 by rmk:")
|
||||||
|
|
||||||
(* ;; "So we can toggle this scrolling.")
|
(* ;; "So we can toggle this scrolling.")
|
||||||
|
|
||||||
(IF ON
|
(if ON
|
||||||
THEN (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
|
then (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
|
||||||
(GETD 'LISPINTERRUPTS.WHEELSCROLL))
|
(GETD 'LISPINTERRUPTS.WHEELSCROLL))
|
||||||
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
(CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||||
(* ; "In case of LOADFROM?")
|
(* ; "In case of LOADFROM?")
|
||||||
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
|
(MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
|
||||||
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)))
|
(MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS)))
|
||||||
|
|
||||||
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
|
(* ;; "In some situations these other keyactions seem to be installed, hit them all.")
|
||||||
|
|
||||||
[FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||||
DO ((FOR K IN [IF EXCLUDEHORIZONTAL
|
do (for K in [if EXCLUDEHORIZONTAL
|
||||||
THEN `((PAD1 ,UP)
|
then `((PAD1 ,\WSUP)
|
||||||
(PAD2 ,DOWN)
|
(PAD2 ,\WSDOWN)
|
||||||
(PAD4 IGNORE)
|
(PAD4 IGNORE)
|
||||||
(PAD5 IGNORE))
|
(PAD5 IGNORE))
|
||||||
ELSE `((PAD1 ,UP)
|
else `((PAD1 ,\WSUP)
|
||||||
(PAD2 ,DOWN)
|
(PAD2 ,\WSDOWN)
|
||||||
(PAD4 ,LEFT)
|
(PAD4 ,\WSLEFT)
|
||||||
(PAD5 ,RIGHT]
|
(PAD5 ,\WSRIGHT]
|
||||||
DO (KEYACTION (CAR K)
|
do (KEYACTION (CAR K)
|
||||||
(CONS (CL:IF (EQ (CADR K)
|
(CONS (CL:IF (EQ (CADR K)
|
||||||
'IGNORE)
|
'IGNORE)
|
||||||
'IGNORE
|
'IGNORE
|
||||||
`(,(CADR K)
|
`(,(CADR K)
|
||||||
,(CADR K)))
|
,(CADR K)))
|
||||||
`IGNORE)
|
`IGNORE)
|
||||||
KAT]
|
KAT)))
|
||||||
(FOR I IN WHEELSCROLLINTERRUPTS
|
(for I in WHEELSCROLLINTERRUPTS
|
||||||
DO (INTERRUPTCHAR (CAR I)
|
do (INTERRUPTCHAR (CAR I)
|
||||||
(CADR I)
|
(CADR I)
|
||||||
(CADDR I))
|
(CADDR I))
|
||||||
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
||||||
|
|
||||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||||
|
|
||||||
(TEDIT.SETFUNCTION (CAR I)
|
(TEDIT.SETFUNCTION (CAR I)
|
||||||
`[LAMBDA NIL
|
`[LAMBDA NIL
|
||||||
,(CADR I]
|
,(CADR I]
|
||||||
TEDIT.READTABLE)))
|
TEDIT.READTABLE)))
|
||||||
(SETQ WHEELSCROLLENABLED T)
|
(SETQ WHEELSCROLLENABLED T)
|
||||||
ELSE (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
else (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
|
||||||
(GETD 'LISPINTERRUPTS))
|
(GETD 'LISPINTERRUPTS))
|
||||||
(MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
|
(MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
|
||||||
(FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
|
(for I in WHEELSCROLLINTERRUPTS do (INTERRUPTCHAR (CAR I)
|
||||||
NIL)
|
NIL)
|
||||||
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
(CL:WHEN (BOUNDP 'TEDIT.READTABLE)
|
||||||
|
|
||||||
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
(* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")
|
||||||
|
|
||||||
(TEDIT.SETFUNCTION (CAR I)
|
(TEDIT.SETFUNCTION (CAR I)
|
||||||
NIL TEDIT.READTABLE)))
|
NIL TEDIT.READTABLE)))
|
||||||
(FOR KAT IN (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
(for KAT in (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
|
||||||
DO (KEYACTION 'PAD1 '(IGNORE . IGNORE)
|
do (KEYACTION 'PAD1 '(IGNORE . IGNORE)
|
||||||
KAT)
|
KAT)
|
||||||
(KEYACTION 'PAD2 '(IGNORE . IGNORE)
|
(KEYACTION 'PAD2 '(IGNORE . IGNORE)
|
||||||
KAT)
|
KAT)
|
||||||
@@ -104,41 +108,42 @@
|
|||||||
(SETQ WHEELSCROLLENABLED NIL])
|
(SETQ WHEELSCROLLENABLED NIL])
|
||||||
|
|
||||||
(WHEELSCROLL
|
(WHEELSCROLL
|
||||||
[LAMBDA (DIRECTION DELTA) (* ; "Edited 21-Feb-2021 09:38 by rmk:")
|
[LAMBDA (DIRECTION DELTA) (* ;
|
||||||
|
"Edited 21-Feb-2021 09:38 by rmk:")
|
||||||
|
|
||||||
(* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)")
|
(* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button. And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button. We don't yet have a good solution to this problem. (This is not an issue with a trackpad)")
|
||||||
|
|
||||||
(* ;; "")
|
(* ;; "")
|
||||||
|
|
||||||
(CL:WHEN (MOUSESTATE UP) (* ;
|
(CL:WHEN (MOUSESTATE UP) (* ;
|
||||||
"Ignore interrupt if a button is down")
|
"Ignore interrupt if a button is down")
|
||||||
[LET ((W (WHICHW)))
|
[LET ((W (WHICHW)))
|
||||||
|
|
||||||
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within
|
(* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within
|
||||||
the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
|
the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))
|
||||||
|
|
||||||
(CL:WHEN W
|
(CL:WHEN W
|
||||||
|
|
||||||
(* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")
|
(* ;; "We scroll only if the window has a scrollfn. Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL. Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")
|
||||||
|
|
||||||
(IF (WINDOWPROP W 'SCROLLFN)
|
(if (WINDOWPROP W 'SCROLLFN)
|
||||||
THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
|
then [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
|
||||||
(CL:IF (EQ DIRECTION 'VERTICAL)
|
(CL:IF (EQ DIRECTION 'VERTICAL)
|
||||||
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
||||||
0
|
0
|
||||||
,DELTA)
|
,DELTA)
|
||||||
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
`(WHEELSCROLL.DOIT ,(KWOTE W)
|
||||||
,DELTA 0))]
|
,DELTA 0))]
|
||||||
ELSEIF (EQ DIRECTION 'VERTICAL)
|
elseif (EQ DIRECTION 'VERTICAL)
|
||||||
THEN
|
then
|
||||||
|
|
||||||
(* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.")
|
(* ;; "We are in a pop-up scrollbar. This moves the cursor there, the user has to click to scroll the main window.")
|
||||||
|
|
||||||
(CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
|
(CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
|
||||||
(\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
|
(\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
|
||||||
(GETMOUSESTATE))
|
(GETMOUSESTATE))
|
||||||
ELSEIF (EQ DIRECTION 'HORIZONTAL)
|
elseif (EQ DIRECTION 'HORIZONTAL)
|
||||||
THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
|
then (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
|
||||||
(\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
|
(\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
|
||||||
LASTMOUSEY)
|
LASTMOUSEY)
|
||||||
(GETMOUSESTATE))))])])
|
(GETMOUSESTATE))))])])
|
||||||
@@ -186,19 +191,19 @@
|
|||||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(RPAQQ UP 156)
|
(RPAQQ \WSUP 156)
|
||||||
|
|
||||||
(RPAQQ DOWN 157)
|
(RPAQQ \WSDOWN 157)
|
||||||
|
|
||||||
(RPAQQ LEFT 158)
|
(RPAQQ \WSLEFT 158)
|
||||||
|
|
||||||
(RPAQQ RIGHT 159)
|
(RPAQQ \WSRIGHT 159)
|
||||||
|
|
||||||
|
|
||||||
(CONSTANTS (UP 156)
|
(CONSTANTS (\WSUP 156)
|
||||||
(DOWN 157)
|
(\WSDOWN 157)
|
||||||
(LEFT 158)
|
(\WSLEFT 158)
|
||||||
(RIGHT 159))
|
(\WSRIGHT 159))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||||
@@ -229,6 +234,6 @@
|
|||||||
(ENABLEWHEELSCROLL T)
|
(ENABLEWHEELSCROLL T)
|
||||||
)
|
)
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (1575 9814 (ENABLEWHEELSCROLL 1585 . 5542) (WHEELSCROLL 5544 . 8080) (WHEELSCROLL.DOIT
|
(FILEMAP (NIL (1604 10208 (ENABLEWHEELSCROLL 1614 . 5871) (WHEELSCROLL 5873 . 8474) (WHEELSCROLL.DOIT
|
||||||
8082 . 8718) (INSTALL-WHEELSCROLL 8720 . 9535) (LISPINTERRUPTS.WHEELSCROLL 9537 . 9812)))))
|
8476 . 9112) (INSTALL-WHEELSCROLL 9114 . 9929) (LISPINTERRUPTS.WHEELSCROLL 9931 . 10206)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
15
loadups/README.md
Normal file
15
loadups/README.md
Normal file
@@ -0,0 +1,15 @@
|
|||||||
|
# medley/loadups
|
||||||
|
|
||||||
|
This directory is for holding the sysouts from a release
|
||||||
|
* lisp.sysout (the system in the IRM + Common Lisp)
|
||||||
|
* full.sysout (lisp + modernizations + TEdit and others)
|
||||||
|
|
||||||
|
* starter.sysout you have to have a running Medley to make a new one(!)
|
||||||
|
this file is just a stable place to stand.
|
||||||
|
|
||||||
|
* whereis.hash A "hash file" directory index of everything
|
||||||
|
|
||||||
|
* lisp.venuesysout full.venuesysout -- vintage sysouts for comparision
|
||||||
|
|
||||||
|
Plus, if you make your own loadups (from BUILDING.md) you'll see some .dribble files which are the logs of the build proccess.
|
||||||
|
|
||||||
@@ -51,7 +51,7 @@ if [ -z "$LDEDESTSYSOUT" ] ; then
|
|||||||
fi
|
fi
|
||||||
|
|
||||||
if [ -z "$LDEINIT" ] ; then
|
if [ -z "$LDEINIT" ] ; then
|
||||||
export LDEINIT="$MEDLEYDIR/greetfiles/SIMPLE-INIT"
|
export LDEINIT="$MEDLEYDIR/greetfiles/MEDLEYDIR-INIT"
|
||||||
fi
|
fi
|
||||||
|
|
||||||
export LDEKBDTYPE=x
|
export LDEKBDTYPE=x
|
||||||
@@ -195,4 +195,3 @@ export INMEDLEY=1
|
|||||||
|
|
||||||
"$prog" $noscroll $geometry $screensize $mem -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
|
"$prog" $noscroll $geometry $screensize $mem -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -29,7 +29,7 @@ tar cfz medley/tmp/$tag-runtime.tgz \
|
|||||||
--exclude "*~" --exclude "*#*" \
|
--exclude "*~" --exclude "*#*" \
|
||||||
medley/docs/dinfo \
|
medley/docs/dinfo \
|
||||||
medley/docs/Documentation\ Tools \
|
medley/docs/Documentation\ Tools \
|
||||||
medley/greetfiles/SIMPLE-INIT \
|
medley/greetfiles \
|
||||||
medley/run-medley \
|
medley/run-medley \
|
||||||
medley/scripts \
|
medley/scripts \
|
||||||
medley/fonts/displayfonts medley/fonts/altofonts \
|
medley/fonts/displayfonts medley/fonts/altofonts \
|
||||||
|
|||||||
@@ -1,104 +1,94 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
(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)
|
(PRETTYCOMPRINT CLSTREAMSCOMS)
|
||||||
|
|
||||||
(RPAQQ CLSTREAMSCOMS (
|
(RPAQQ CLSTREAMSCOMS
|
||||||
|
(
|
||||||
|
|
||||||
(* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21")
|
(* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21")
|
||||||
|
|
||||||
(COMS
|
(COMS
|
||||||
(* |;;| "documented functions and macros")
|
(* |;;| "documented functions and macros")
|
||||||
|
|
||||||
(FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT)
|
(FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT)
|
||||||
(FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P
|
(FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P CL:OUTPUT-STREAM-P
|
||||||
CL:OUTPUT-STREAM-P XCL:OPEN-STREAM-P)
|
XCL:OPEN-STREAM-P)
|
||||||
(COMS (FUNCTIONS FILE-STREAM-POSITION)
|
(COMS (FUNCTIONS FILE-STREAM-POSITION)
|
||||||
(SETFS FILE-STREAM-POSITION))
|
(SETFS FILE-STREAM-POSITION))
|
||||||
(FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P
|
(FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P XCL:SYNONYM-STREAM-SYMBOL
|
||||||
XCL:SYNONYM-STREAM-SYMBOL XCL:FOLLOW-SYNONYM-STREAMS)
|
XCL:FOLLOW-SYNONYM-STREAMS)
|
||||||
(FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P
|
(FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P XCL:BROADCAST-STREAM-STREAMS
|
||||||
XCL:BROADCAST-STREAM-STREAMS)
|
)
|
||||||
(FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P
|
(FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P
|
||||||
XCL:CONCATENATED-STREAM-STREAMS)
|
XCL:CONCATENATED-STREAM-STREAMS)
|
||||||
(FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P
|
(FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P XCL:TWO-WAY-STREAM-OUTPUT-STREAM
|
||||||
XCL:TWO-WAY-STREAM-OUTPUT-STREAM
|
XCL:TWO-WAY-STREAM-INPUT-STREAM)
|
||||||
XCL:TWO-WAY-STREAM-INPUT-STREAM)
|
(FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P XCL:ECHO-STREAM-INPUT-STREAM
|
||||||
(FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P
|
XCL:ECHO-STREAM-OUTPUT-STREAM)
|
||||||
XCL:ECHO-STREAM-INPUT-STREAM XCL:ECHO-STREAM-OUTPUT-STREAM)
|
(FUNCTIONS CL:MAKE-STRING-INPUT-STREAM MAKE-CONCATENATED-STRING-INPUT-STREAM)
|
||||||
(FUNCTIONS CL:MAKE-STRING-INPUT-STREAM
|
(FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
|
||||||
MAKE-CONCATENATED-STRING-INPUT-STREAM)
|
(FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING CL:WITH-OUTPUT-TO-STRING
|
||||||
(FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS)
|
CL:WITH-OPEN-FILE)
|
||||||
(FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING
|
(FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM MAKE-FILL-POINTER-OUTPUT-STREAM
|
||||||
CL:WITH-OUTPUT-TO-STRING CL:WITH-OPEN-FILE)
|
CL:GET-OUTPUT-STREAM-STRING \\STRING-STREAM-OUTCHARFN
|
||||||
(FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM
|
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN))
|
||||||
MAKE-FILL-POINTER-OUTPUT-STREAM CL:GET-OUTPUT-STREAM-STRING
|
(COMS
|
||||||
\\STRING-STREAM-OUTCHARFN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN
|
(* |;;| "helpers")
|
||||||
))
|
|
||||||
(COMS
|
|
||||||
(* |;;| "helpers")
|
|
||||||
|
|
||||||
(FUNCTIONS %NEW-FILE PREDICT-NAME)
|
(FUNCTIONS %NEW-FILE PREDICT-NAME)
|
||||||
(DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
|
(DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS)))
|
||||||
(COMS
|
(COMS
|
||||||
(* |;;| "methods for the special devices")
|
(* |;;| "methods for the special devices")
|
||||||
|
|
||||||
(FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN
|
(FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN
|
||||||
%BROADCAST-STREAM-DEVICE-CLOSEFILE
|
%BROADCAST-STREAM-DEVICE-CLOSEFILE %BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
|
||||||
%BROADCAST-STREAM-DEVICE-FORCEOUTPUT)
|
(FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
|
||||||
(FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN)
|
(FNS %CONCATENATED-STREAM-DEVICE-BIN %CONCATENATED-STREAM-DEVICE-CLOSEFILE
|
||||||
(FNS %CONCATENATED-STREAM-DEVICE-BIN
|
%CONCATENATED-STREAM-DEVICE-EOFP %CONCATENATED-STREAM-DEVICE-PEEKBIN
|
||||||
%CONCATENATED-STREAM-DEVICE-CLOSEFILE
|
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
|
||||||
%CONCATENATED-STREAM-DEVICE-EOFP
|
(FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
|
||||||
%CONCATENATED-STREAM-DEVICE-PEEKBIN
|
(FNS %ECHO-STREAM-DEVICE-BIN)
|
||||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR)
|
(FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
|
||||||
(FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN)
|
(FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT
|
||||||
(FNS %ECHO-STREAM-DEVICE-BIN)
|
%SYNONYM-STREAM-DEVICE-OUTCHARFN %SYNONYM-STREAM-DEVICE-CLOSEFILE
|
||||||
(FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM)
|
%SYNONYM-STREAM-DEVICE-EOFP %SYNONYM-STREAM-DEVICE-FORCEOUTPUT
|
||||||
(FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT
|
%SYNONYM-STREAM-DEVICE-GETFILEINFO %SYNONYM-STREAM-DEVICE-PEEKBIN
|
||||||
%SYNONYM-STREAM-DEVICE-OUTCHARFN
|
%SYNONYM-STREAM-DEVICE-READP %SYNONYM-STREAM-DEVICE-BACKFILEPTR
|
||||||
%SYNONYM-STREAM-DEVICE-CLOSEFILE %SYNONYM-STREAM-DEVICE-EOFP
|
%SYNONYM-STREAM-DEVICE-SETFILEINFO %SYNONYM-STREAM-DEVICE-CHARSETFN)
|
||||||
%SYNONYM-STREAM-DEVICE-FORCEOUTPUT
|
(FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM
|
||||||
%SYNONYM-STREAM-DEVICE-GETFILEINFO
|
%TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
|
||||||
%SYNONYM-STREAM-DEVICE-PEEKBIN %SYNONYM-STREAM-DEVICE-READP
|
%TWO-WAY-STREAM-DEVICE-OUTCHARFN %TWO-WAY-STREAM-DEVICE-CLOSEFILE
|
||||||
%SYNONYM-STREAM-DEVICE-BACKFILEPTR
|
%TWO-WAY-STREAM-DEVICE-EOFP %TWO-WAY-STREAM-DEVICE-READP
|
||||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO
|
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
|
||||||
%SYNONYM-STREAM-DEVICE-CHARSETFN)
|
%TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN)
|
||||||
(FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM
|
(FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE %FILL-POINTER-STREAM-DEVICE-GETFILEPTR
|
||||||
%TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM
|
)
|
||||||
%TWO-WAY-STREAM-DEVICE-OUTCHARFN
|
(GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE
|
||||||
%TWO-WAY-STREAM-DEVICE-CLOSEFILE %TWO-WAY-STREAM-DEVICE-EOFP
|
%TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE))
|
||||||
%TWO-WAY-STREAM-DEVICE-READP %TWO-WAY-STREAM-DEVICE-BACKFILEPTR
|
(COMS
|
||||||
%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT
|
(* |;;| "helper stuff")
|
||||||
%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))
|
(FNS %SYNONYM-STREAM-DEVICE-GET-STREAM))
|
||||||
(COMS
|
(COMS
|
||||||
(* |;;| "module initialization")
|
(* |;;| "module initialization")
|
||||||
|
|
||||||
(VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT*
|
(VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT* *STANDARD-OUTPUT*
|
||||||
*STANDARD-OUTPUT* *STANDARD-INPUT*)
|
*STANDARD-INPUT*)
|
||||||
(FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
|
(FUNCTIONS %INITIALIZE-STANDARD-STREAMS)
|
||||||
(FNS %INITIALIZE-CLSTREAM-TYPES)
|
(FNS %INITIALIZE-CLSTREAM-TYPES)
|
||||||
(DECLARE\: DONTEVAL@LOAD DOCOPY
|
(DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization")
|
||||||
(* \; "initialization")
|
(P (%INITIALIZE-CLSTREAM-TYPES)
|
||||||
(P (%INITIALIZE-CLSTREAM-TYPES)
|
(%INITIALIZE-STANDARD-STREAMS))))
|
||||||
(%INITIALIZE-STANDARD-STREAMS))))
|
(PROP FILETYPE CLSTREAMS)))
|
||||||
(PROP FILETYPE CLSTREAMS)))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -111,10 +101,10 @@
|
|||||||
|
|
||||||
|
|
||||||
(CL:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT)
|
(CL:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT)
|
||||||
(ELEMENT-TYPE 'CL:STRING-CHAR)
|
(ELEMENT-TYPE 'CL:STRING-CHAR)
|
||||||
(IF-EXISTS NIL EXISTS-P)
|
(IF-EXISTS NIL EXISTS-P)
|
||||||
(IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
|
(IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P)
|
||||||
(EXTERNAL-FORMAT :DEFAULT))
|
(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.")
|
(* |;;;| "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)))
|
(FOR-OUTPUT (MEMQ DIRECTION '(:IO :OUTPUT)))
|
||||||
(ACCESS (INTERLISP-ACCESS DIRECTION))
|
(ACCESS (INTERLISP-ACCESS DIRECTION))
|
||||||
(FILE-TYPE (IF (CL:MEMBER ELEMENT-TYPE '(CL:UNSIGNED-BYTE CL:SIGNED-BYTE (CL:UNSIGNED-BYTE
|
(FILE-TYPE (IF (CL:MEMBER ELEMENT-TYPE '(CL:UNSIGNED-BYTE CL:SIGNED-BYTE (CL:UNSIGNED-BYTE
|
||||||
8)
|
8)
|
||||||
(CL:SIGNED-BYTE 8))
|
(CL:SIGNED-BYTE 8))
|
||||||
:TEST
|
:TEST
|
||||||
'CL:EQUAL)
|
'CL:EQUAL)
|
||||||
THEN 'BINARY
|
THEN 'BINARY
|
||||||
ELSE 'TEXT))
|
ELSE 'TEXT))
|
||||||
(STREAM NIL))
|
(STREAM NIL))
|
||||||
@@ -149,7 +139,7 @@
|
|||||||
:NEWEST)
|
:NEWEST)
|
||||||
:NEW-VERSION
|
:NEW-VERSION
|
||||||
:ERROR))) (* \;
|
: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
|
(CL:UNLESS DOES-NOT-EXIST-P
|
||||||
(SETQ IF-DOES-NOT-EXIST (COND
|
(SETQ IF-DOES-NOT-EXIST (COND
|
||||||
((OR (EQ IF-EXISTS :APPEND)
|
((OR (EQ IF-EXISTS :APPEND)
|
||||||
@@ -159,101 +149,98 @@
|
|||||||
NIL)
|
NIL)
|
||||||
(T :CREATE))))
|
(T :CREATE))))
|
||||||
(CL:LOOP (* \;
|
(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))
|
(LET* ((NAME (PREDICT-NAME PATHNAME))
|
||||||
(CL:NAMESTRING (MKSTRING NAME)))
|
(CL:NAMESTRING (MKSTRING NAME)))
|
||||||
(IF NAME
|
(IF NAME
|
||||||
THEN (* \; "file exists")
|
THEN (* \; "file exists")
|
||||||
(IF FOR-OUTPUT
|
(IF FOR-OUTPUT
|
||||||
THEN
|
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
|
(* |;;| "open for input/both")
|
||||||
(: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")
|
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
||||||
|
`((TYPE ,FILE-TYPE)
|
||||||
|
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||||
|
(RETURN NIL)
|
||||||
|
|else|
|
||||||
|
|
||||||
(SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD
|
(* |;;| "open for probe")
|
||||||
`((TYPE ,FILE-TYPE)
|
|
||||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
|
||||||
(RETURN NIL)
|
|
||||||
|else|
|
|
||||||
|
|
||||||
(* |;;| "open for probe")
|
(SETQ STREAM (|create| STREAM
|
||||||
|
FULLFILENAME _ (FULLNAME CL:NAMESTRING)))
|
||||||
(SETQ STREAM (|create| STREAM
|
(RETURN NIL))
|
||||||
FULLFILENAME _ (FULLNAME CL:NAMESTRING)))
|
|
||||||
(RETURN NIL))
|
|
||||||
|else|
|
|else|
|
||||||
|
|
||||||
(* |;;| "file does not exist")
|
(* |;;| "file does not exist")
|
||||||
|
|
||||||
(|if| FOR-OUTPUT
|
(|if| FOR-OUTPUT
|
||||||
|then| (CASE IF-DOES-NOT-EXIST
|
|then| (CASE IF-DOES-NOT-EXIST
|
||||||
(:ERROR
|
(:ERROR
|
||||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||||
:PATHNAME PATHNAME)
|
:PATHNAME PATHNAME)
|
||||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||||
(:CREATE
|
(:CREATE
|
||||||
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
(SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW
|
||||||
`((TYPE ,FILE-TYPE)
|
`((TYPE ,FILE-TYPE)
|
||||||
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
(EXTERNALFORMAT ,EXTERNAL-FORMAT))))
|
||||||
(RETURN NIL))
|
(RETURN NIL))
|
||||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||||
IF-DOES-NOT-EXIST)))
|
IF-DOES-NOT-EXIST)))
|
||||||
|elseif| FOR-INPUT
|
|elseif| FOR-INPUT
|
||||||
|then| (CASE IF-DOES-NOT-EXIST
|
|then| (CASE IF-DOES-NOT-EXIST
|
||||||
(:ERROR
|
(:ERROR
|
||||||
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
(CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND
|
||||||
:PATHNAME PATHNAME)
|
:PATHNAME PATHNAME)
|
||||||
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
(CL:FORMAT *QUERY-IO* "~&New file name: ")
|
||||||
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
(SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*))))
|
||||||
(:CREATE (%NEW-FILE PATHNAME))
|
(:CREATE (%NEW-FILE PATHNAME))
|
||||||
((NIL) (CL:RETURN-FROM OPEN NIL))
|
((NIL) (CL:RETURN-FROM OPEN NIL))
|
||||||
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
(T (CL:ERROR "~S is not a valid value for :if-does-not-exist."
|
||||||
IF-DOES-NOT-EXIST)))
|
IF-DOES-NOT-EXIST)))
|
||||||
|else| (* \; "Open for probe.")
|
|else| (* \; "Open for probe.")
|
||||||
(RETURN NIL)))))
|
(RETURN NIL)))))
|
||||||
(STREAMPROP STREAM :FILE-STREAM-P T)
|
(STREAMPROP STREAM :FILE-STREAM-P T)
|
||||||
STREAM))
|
STREAM))
|
||||||
@@ -264,18 +251,18 @@
|
|||||||
|
|
||||||
(|if| (STREAMP STREAM)
|
(|if| (STREAMP STREAM)
|
||||||
|then| (|if| (OPENP 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)
|
(LET ((ABORTABLE (AND (DIRTYABLE STREAM)
|
||||||
(NOT (APPENDONLY STREAM)))))
|
(NOT (APPENDONLY STREAM)))))
|
||||||
(CLOSEF STREAM)
|
(CLOSEF STREAM)
|
||||||
(|if| (AND ABORT ABORTABLE)
|
(|if| (AND ABORT ABORTABLE)
|
||||||
|then| (* \;
|
|then| (* \;
|
||||||
"eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.")
|
"eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.")
|
||||||
(DELFILE (CL:NAMESTRING STREAM)))))
|
(DELFILE (CL:NAMESTRING STREAM)))))
|
||||||
|else| (ERROR "Closing a non-stream" STREAM))
|
|else| (ERROR "Closing a non-stream" STREAM))
|
||||||
T)
|
T)
|
||||||
|
|
||||||
@@ -323,15 +310,19 @@
|
|||||||
DEVICE _ %SYNONYM-STREAM-DEVICE
|
DEVICE _ %SYNONYM-STREAM-DEVICE
|
||||||
ACCESS _ 'BOTH
|
ACCESS _ 'BOTH
|
||||||
F1 _ CL:SYMBOL
|
F1 _ CL:SYMBOL
|
||||||
LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE
|
LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE CL:SYMBOL))
|
||||||
CL:SYMBOL))
|
|
||||||
OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN))))
|
OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN))))
|
||||||
(STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T)
|
(STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T)
|
||||||
|
|
||||||
(* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE")
|
(* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE")
|
||||||
|
|
||||||
(|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE
|
(|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (CONS STREAM
|
||||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE)))
|
(|fetch| (FDEV
|
||||||
|
OPENFILELST
|
||||||
|
)
|
||||||
|
|of|
|
||||||
|
%SYNONYM-STREAM-DEVICE
|
||||||
|
)))
|
||||||
STREAM))
|
STREAM))
|
||||||
|
|
||||||
(CL:DEFUN XCL:SYNONYM-STREAM-P (STREAM)
|
(CL:DEFUN XCL:SYNONYM-STREAM-P (STREAM)
|
||||||
@@ -355,14 +346,14 @@
|
|||||||
|
|
||||||
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
||||||
THEN (LET ((STREAM (|create| STREAM
|
THEN (LET ((STREAM (|create| STREAM
|
||||||
DEVICE _ %BROADCAST-STREAM-DEVICE
|
DEVICE _ %BROADCAST-STREAM-DEVICE
|
||||||
ACCESS _ 'OUTPUT
|
ACCESS _ 'OUTPUT
|
||||||
F1 _ STREAMS
|
F1 _ STREAMS
|
||||||
OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
|
OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN))))
|
||||||
(STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
|
(STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T)
|
||||||
STREAM)
|
STREAM)
|
||||||
ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP 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)
|
(CL:DEFUN XCL:BROADCAST-STREAM-P (STREAM)
|
||||||
|
|
||||||
@@ -383,13 +374,13 @@
|
|||||||
|
|
||||||
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
(IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?))
|
||||||
THEN (LET ((STREAM (|create| STREAM
|
THEN (LET ((STREAM (|create| STREAM
|
||||||
DEVICE _ %CONCATENATED-STREAM-DEVICE
|
DEVICE _ %CONCATENATED-STREAM-DEVICE
|
||||||
ACCESS _ 'INPUT
|
ACCESS _ 'INPUT
|
||||||
F1 _ STREAMS)))
|
F1 _ STREAMS)))
|
||||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
|
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T)
|
||||||
STREAM)
|
STREAM)
|
||||||
ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP 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)
|
(CL:DEFUN XCL:CONCATENATED-STREAM-P (STREAM)
|
||||||
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P))
|
(STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P))
|
||||||
@@ -420,8 +411,13 @@
|
|||||||
|
|
||||||
(* |;;| "save STREAM in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE")
|
(* |;;| "save STREAM in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE")
|
||||||
|
|
||||||
(|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE
|
(|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE |with| (CONS STREAM
|
||||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE)))
|
(|fetch| (FDEV
|
||||||
|
OPENFILELST
|
||||||
|
)
|
||||||
|
|of|
|
||||||
|
%TWO-WAY-STREAM-DEVICE
|
||||||
|
)))
|
||||||
STREAM))
|
STREAM))
|
||||||
|
|
||||||
(CL:DEFUN XCL:TWO-WAY-STREAM-P (STREAM)
|
(CL:DEFUN XCL:TWO-WAY-STREAM-P (STREAM)
|
||||||
@@ -457,8 +453,13 @@
|
|||||||
|
|
||||||
(* |;;| "save STREAM in the OPENFILELST field of %ECHO-STREAM-DEVICE")
|
(* |;;| "save STREAM in the OPENFILELST field of %ECHO-STREAM-DEVICE")
|
||||||
|
|
||||||
(|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE
|
(|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE |with| (CONS STREAM
|
||||||
|with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE)))
|
(|fetch| (FDEV
|
||||||
|
OPENFILELST
|
||||||
|
)
|
||||||
|
|of|
|
||||||
|
%ECHO-STREAM-DEVICE
|
||||||
|
)))
|
||||||
STREAM))
|
STREAM))
|
||||||
|
|
||||||
(CL:DEFUN XCL:ECHO-STREAM-P (STREAM)
|
(CL:DEFUN XCL:ECHO-STREAM-P (STREAM)
|
||||||
@@ -476,12 +477,12 @@
|
|||||||
(FETCH (STREAM F2) OF STREAM)))
|
(FETCH (STREAM F2) OF STREAM)))
|
||||||
|
|
||||||
(CL:DEFUN CL:MAKE-STRING-INPUT-STREAM (STRING &OPTIONAL (CL::START 0)
|
(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")
|
(* |;;;| "A CommonLisp function for producing a stream from a string. See CLtL p. 330")
|
||||||
|
|
||||||
(OPENSTRINGSTREAM (|if| (OR (NOT (CL:ZEROP CL::START))
|
(OPENSTRINGSTREAM (|if| (OR (NOT (CL:ZEROP CL::START))
|
||||||
(NOT (NULL CL::END)))
|
(NOT (NULL CL::END)))
|
||||||
|then|
|
|then|
|
||||||
|
|
||||||
(* |;;| "A displaced array is ok here because the stream's uses GETBASEBYTE directly and doesn't go through the array code at all. ")
|
(* |;;| "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)
|
NIL)
|
||||||
((NULL (CL:REST STRINGS))
|
((NULL (CL:REST STRINGS))
|
||||||
(CL:MAKE-STRING-INPUT-STREAM (CL:FIRST STRINGS)))
|
(CL:MAKE-STRING-INPUT-STREAM (CL:FIRST STRINGS)))
|
||||||
(T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS
|
(T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS COLLECT (
|
||||||
COLLECT (CL:MAKE-STRING-INPUT-STREAM
|
CL:MAKE-STRING-INPUT-STREAM
|
||||||
STRING))))))
|
STRING))))))
|
||||||
|
|
||||||
(CL:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS ()
|
(CL:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS ()
|
||||||
(CL:MAKE-ARRAY '(256)
|
(CL:MAKE-ARRAY '(256)
|
||||||
@@ -507,8 +508,8 @@
|
|||||||
'CL:STRING-CHAR :EXTENDABLE T :FILL-POINTER 0))
|
'CL:STRING-CHAR :EXTENDABLE T :FILL-POINTER 0))
|
||||||
|
|
||||||
(DEFMACRO CL:WITH-OPEN-STREAM ((VAR STREAM)
|
(DEFMACRO CL:WITH-OPEN-STREAM ((VAR STREAM)
|
||||||
&BODY
|
&BODY
|
||||||
(BODY DECLS))
|
(BODY DECLS))
|
||||||
(LET ((ABORTP (GENSYM)))
|
(LET ((ABORTP (GENSYM)))
|
||||||
`(LET ((,VAR ,STREAM)
|
`(LET ((,VAR ,STREAM)
|
||||||
(,ABORTP T))
|
(,ABORTP T))
|
||||||
@@ -519,15 +520,15 @@
|
|||||||
(CL:CLOSE ,VAR :ABORT ,ABORTP)))))
|
(CL:CLOSE ,VAR :ABORT ,ABORTP)))))
|
||||||
|
|
||||||
(DEFMACRO CL:WITH-INPUT-FROM-STRING ((CL::VAR STRING &KEY (CL::INDEX NIL CL::INDEXP)
|
(DEFMACRO CL:WITH-INPUT-FROM-STRING ((CL::VAR STRING &KEY (CL::INDEX NIL CL::INDEXP)
|
||||||
(CL::START 0 CL::STARTP)
|
(CL::START 0 CL::STARTP)
|
||||||
(CL::END NIL CL:ENDP))
|
(CL::END NIL CL:ENDP))
|
||||||
&BODY
|
&BODY
|
||||||
(CL::BODY CL::DECLS))
|
(CL::BODY CL::DECLS))
|
||||||
`(LET* ((CL::$STRING$ ,STRING)
|
`(LET* ((CL::$STRING$ ,STRING)
|
||||||
(CL::$START$ ,CL::START))
|
(CL::$START$ ,CL::START))
|
||||||
(DECLARE (LOCALVARS CL::$STRING$ CL::$START$))
|
(DECLARE (LOCALVARS CL::$STRING$ CL::$START$))
|
||||||
(CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$
|
(CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$ CL::$START$
|
||||||
CL::$START$ ,CL::END))
|
,CL::END))
|
||||||
,@CL::DECLS
|
,@CL::DECLS
|
||||||
,@(CL:IF CL::INDEXP
|
,@(CL:IF CL::INDEXP
|
||||||
|
|
||||||
@@ -541,8 +542,8 @@
|
|||||||
CL::BODY))))
|
CL::BODY))))
|
||||||
|
|
||||||
(DEFMACRO CL:WITH-OUTPUT-TO-STRING ((VAR &OPTIONAL (STRING NIL ST-P))
|
(DEFMACRO CL:WITH-OUTPUT-TO-STRING ((VAR &OPTIONAL (STRING NIL ST-P))
|
||||||
&BODY
|
&BODY
|
||||||
(FORMS DECLS))
|
(FORMS DECLS))
|
||||||
(COND
|
(COND
|
||||||
(ST-P `(CL:WITH-OPEN-STREAM (,VAR (MAKE-FILL-POINTER-OUTPUT-STREAM ,STRING))
|
(ST-P `(CL:WITH-OPEN-STREAM (,VAR (MAKE-FILL-POINTER-OUTPUT-STREAM ,STRING))
|
||||||
,@DECLS
|
,@DECLS
|
||||||
@@ -552,8 +553,8 @@
|
|||||||
(PROGN ,@FORMS (CL:GET-OUTPUT-STREAM-STRING ,VAR))))))
|
(PROGN ,@FORMS (CL:GET-OUTPUT-STREAM-STRING ,VAR))))))
|
||||||
|
|
||||||
(DEFMACRO CL:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS)
|
(DEFMACRO CL:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS)
|
||||||
&BODY
|
&BODY
|
||||||
(FORMS DECLS))
|
(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.")
|
(* |;;;| "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))
|
(MAKE-FILL-POINTER-OUTPUT-STREAM))
|
||||||
|
|
||||||
(CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (
|
(CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (%MAKE-INITIAL-STRING-STREAM-CONTENTS)))
|
||||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
|
||||||
)))
|
|
||||||
(DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE))
|
(DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE))
|
||||||
(|if| (NOT (CL:ARRAY-HAS-FILL-POINTER-P STRING))
|
(|if| (NOT (CL:ARRAY-HAS-FILL-POINTER-P STRING))
|
||||||
|then| (\\ILLEGAL.ARG STRING)
|
|then| (\\ILLEGAL.ARG STRING)
|
||||||
|else| (LET ((STREAM (|create| STREAM
|
|else| (LET ((STREAM (|create| STREAM
|
||||||
DEVICE _ \\FILL-POINTER-STREAM-DEVICE
|
DEVICE _ \\FILL-POINTER-STREAM-DEVICE
|
||||||
F1 _ STRING
|
F1 _ STRING
|
||||||
ACCESS _ 'OUTPUT
|
ACCESS _ 'OUTPUT
|
||||||
OTHERPROPS _ '(STRING-OUTPUT-STREAM T))))
|
OTHERPROPS _ '(STRING-OUTPUT-STREAM T))))
|
||||||
(* \;
|
(* \;
|
||||||
"give it a canned property list to save some consing.")
|
"give it a canned property list to save some consing.")
|
||||||
(|replace| (STREAM OUTCHARFN) |of| STREAM
|
(|replace| (STREAM OUTCHARFN) |of| STREAM |with| (|if| (EXTENDABLE-ARRAY-P STRING)
|
||||||
|with| (|if| (EXTENDABLE-ARRAY-P STRING)
|
|then| (FUNCTION
|
||||||
|then| (FUNCTION \\ADJUSTABLE-STRING-STREAM-OUTCHARFN)
|
\\ADJUSTABLE-STRING-STREAM-OUTCHARFN
|
||||||
|else| (FUNCTION \\STRING-STREAM-OUTCHARFN)))
|
)
|
||||||
(|replace| (STREAM STRMBOUTFN) |of| STREAM |with|
|
|else| (FUNCTION
|
||||||
(FUNCTION \\OUTCHAR))
|
\\STRING-STREAM-OUTCHARFN
|
||||||
STREAM)))
|
)))
|
||||||
|
(|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\OUTCHAR))
|
||||||
|
STREAM)))
|
||||||
|
|
||||||
(CL:DEFUN CL:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM)
|
(CL:DEFUN CL:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM)
|
||||||
|
|
||||||
@@ -600,17 +601,17 @@
|
|||||||
(|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM))
|
(|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM))
|
||||||
|then| (ERROR "Stream not a 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)
|
|else| (PROG1 (|fetch| (STREAM F1) |of| STRING-OUTPUT-STREAM)
|
||||||
(|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
|
(|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (
|
||||||
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
%MAKE-INITIAL-STRING-STREAM-CONTENTS
|
||||||
)))))
|
)))))
|
||||||
|
|
||||||
(CL:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR)
|
(CL:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR)
|
||||||
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||||
(EQ CHAR (CHARCODE EOL)))
|
(EQ CHAR (CHARCODE EOL)))
|
||||||
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||||
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||||
1))
|
1))
|
||||||
(CL:VECTOR-PUSH (CL:CHARACTER CHAR)
|
(CL:VECTOR-PUSH (CL:CHARACTER CHAR)
|
||||||
(FETCH (STREAM F1) OF STREAM)))
|
(FETCH (STREAM F1) OF STREAM)))
|
||||||
|
|
||||||
@@ -618,11 +619,11 @@
|
|||||||
(LET ((STRING (FETCH (STREAM F1) OF STREAM))
|
(LET ((STRING (FETCH (STREAM F1) OF STREAM))
|
||||||
(CH (CL:CHARACTER CHAR)))
|
(CH (CL:CHARACTER CHAR)))
|
||||||
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
(IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM)
|
||||||
(FETCH (STREAM LINELENGTH) OF STREAM))
|
(FETCH (STREAM LINELENGTH) OF STREAM))
|
||||||
(EQ CHAR (CHARCODE EOL)))
|
(EQ CHAR (CHARCODE EOL)))
|
||||||
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||||
ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM)
|
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.")
|
(* |;;| "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)))
|
(LET ((CURRENT-LENGTH (CL:ARRAY-TOTAL-SIZE STRING)))
|
||||||
(IF (>= CURRENT-LENGTH (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT))
|
(IF (>= CURRENT-LENGTH (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT))
|
||||||
THEN (PROCEED-CASE (CL:ERROR 'END-OF-FILE :STREAM STREAM)
|
THEN (PROCEED-CASE (CL:ERROR 'END-OF-FILE :STREAM STREAM)
|
||||||
(SI::RETRY-OUTCHAR NIL :REPORT
|
(SI::RETRY-OUTCHAR NIL :REPORT "VECTOR-PUSH the character anyway"
|
||||||
"VECTOR-PUSH the character anyway" :CONDITION END-OF-FILE
|
:CONDITION END-OF-FILE (CL:VECTOR-PUSH CH (FETCH (STREAM
|
||||||
(CL:VECTOR-PUSH CH (FETCH (STREAM F1) OF STREAM))
|
F1)
|
||||||
))
|
OF STREAM))))
|
||||||
ELSE (CL:ADJUST-ARRAY STRING (MIN (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT)
|
ELSE (CL:ADJUST-ARRAY STRING (MIN (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT)
|
||||||
(+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH
|
(+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH 1)
|
||||||
1)
|
|
||||||
|
|
||||||
*DEFAULT-PUSH-EXTENSION-SIZE*
|
*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.")
|
(* |;;| "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
|
(FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S NEWVALUE))))
|
||||||
NEWVALUE))))
|
|
||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(%concatenated-stream-device-bin
|
(%concatenated-stream-device-bin
|
||||||
@@ -723,7 +722,7 @@
|
|||||||
(LET ((STREAMS (FETCH (STREAM F1) OF STREAM)))
|
(LET ((STREAMS (FETCH (STREAM F1) OF STREAM)))
|
||||||
(IF STREAMS
|
(IF STREAMS
|
||||||
THEN (ACCESS-CHARSET (CAR STREAMS)
|
THEN (ACCESS-CHARSET (CAR STREAMS)
|
||||||
NEWVALUE)
|
NEWVALUE)
|
||||||
ELSE 0)))
|
ELSE 0)))
|
||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
@@ -933,7 +932,7 @@
|
|||||||
(CL:DEFUN %INITIALIZE-STANDARD-STREAMS ()
|
(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:SETQ *QUERY-IO* (CL:MAKE-TWO-WAY-STREAM (CL:MAKE-SYNONYM-STREAM '\\LINEBUF.OFD)
|
||||||
(CL:MAKE-SYNONYM-STREAM '\\TERM.OFD)))
|
(CL:MAKE-SYNONYM-STREAM '\\TERM.OFD)))
|
||||||
@@ -953,27 +952,51 @@
|
|||||||
(%INITIALIZE-STANDARD-STREAMS)
|
(%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))
|
(PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991))
|
||||||
(DECLARE\: DONTCOPY
|
(DECLARE\: DONTCOPY
|
||||||
(FILEMAP (NIL (34128 35316 (%BROADCAST-STREAM-DEVICE-BOUT 34138 . 34361) (
|
(FILEMAP (NIL (5167 14142 (OPEN 5167 . 14142)) (14144 15070 (CL:CLOSE 14144 . 15070)) (15072 15150 (
|
||||||
%BROADCAST-STREAM-DEVICE-OUTCHARFN 34363 . 34814) (%BROADCAST-STREAM-DEVICE-CLOSEFILE 34816 . 35055) (
|
CL:STREAM-EXTERNAL-FORMAT 15072 . 15150)) (15152 15219 (CL:STREAM-ELEMENT-TYPE 15152 . 15219)) (15221
|
||||||
%BROADCAST-STREAM-DEVICE-FORCEOUTPUT 35057 . 35314)) (35732 37791 (%CONCATENATED-STREAM-DEVICE-BIN
|
15455 (CL:INPUT-STREAM-P 15221 . 15455)) (15457 15693 (CL:OUTPUT-STREAM-P 15457 . 15693)) (15695 15832
|
||||||
35742 . 36147) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 36149 . 36462) (%CONCATENATED-STREAM-DEVICE-EOFP
|
(XCL:OPEN-STREAM-P 15695 . 15832)) (15834 15901 (FILE-STREAM-POSITION 15834 . 15901)) (15953 17296 (
|
||||||
36464 . 36828) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36830 . 37305) (
|
CL:MAKE-SYNONYM-STREAM 15953 . 17296)) (17298 17387 (XCL:SYNONYM-STREAM-P 17298 . 17387)) (17389 17527
|
||||||
%CONCATENATED-STREAM-DEVICE-BACKFILEPTR 37307 . 37789)) (38129 38348 (%ECHO-STREAM-DEVICE-BIN 38139 .
|
(XCL:SYNONYM-STREAM-SYMBOL 17389 . 17527)) (17529 17807 (XCL:FOLLOW-SYNONYM-STREAMS 17529 . 17807)) (
|
||||||
38346)) (38576 41921 (%SYNONYM-STREAM-DEVICE-BIN 38586 . 38774) (%SYNONYM-STREAM-DEVICE-BOUT 38776 .
|
17809 18568 (CL:MAKE-BROADCAST-STREAM 17809 . 18568)) (18570 18713 (XCL:BROADCAST-STREAM-P 18570 .
|
||||||
38977) (%SYNONYM-STREAM-DEVICE-OUTCHARFN 38979 . 39686) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 39688 .
|
18713)) (18715 18930 (XCL:BROADCAST-STREAM-STREAMS 18715 . 18930)) (18932 19617 (
|
||||||
40272) (%SYNONYM-STREAM-DEVICE-EOFP 40274 . 40465) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 40467 . 40705)
|
CL:MAKE-CONCATENATED-STREAM 18932 . 19617)) (19619 19718 (XCL:CONCATENATED-STREAM-P 19619 . 19718)) (
|
||||||
(%SYNONYM-STREAM-DEVICE-GETFILEINFO 40707 . 40944) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40946 . 41169) (
|
19720 19933 (XCL:CONCATENATED-STREAM-STREAMS 19720 . 19933)) (19935 21519 (CL:MAKE-TWO-WAY-STREAM
|
||||||
%SYNONYM-STREAM-DEVICE-READP 41171 . 41282) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 41284 . 41430) (
|
19935 . 21519)) (21521 21658 (XCL:TWO-WAY-STREAM-P 21521 . 21658)) (21660 21805 (
|
||||||
%SYNONYM-STREAM-DEVICE-SETFILEINFO 41432 . 41681) (%SYNONYM-STREAM-DEVICE-CHARSETFN 41683 . 41919)) (
|
XCL:TWO-WAY-STREAM-OUTPUT-STREAM 21660 . 21805)) (21807 21951 (XCL:TWO-WAY-STREAM-INPUT-STREAM 21807
|
||||||
41922 46247 (%TWO-WAY-STREAM-DEVICE-BIN 41932 . 42105) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 42107 .
|
. 21951)) (21953 23503 (CL:MAKE-ECHO-STREAM 21953 . 23503)) (23505 23634 (XCL:ECHO-STREAM-P 23505 .
|
||||||
42298) (%TWO-WAY-STREAM-DEVICE-BOUT 42300 . 42472) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 42474 . 42664)
|
23634)) (23636 23774 (XCL:ECHO-STREAM-INPUT-STREAM 23636 . 23774)) (23776 23915 (
|
||||||
(%TWO-WAY-STREAM-DEVICE-OUTCHARFN 42666 . 43528) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 43530 . 44953) (
|
XCL:ECHO-STREAM-OUTPUT-STREAM 23776 . 23915)) (23917 24644 (CL:MAKE-STRING-INPUT-STREAM 23917 . 24644)
|
||||||
%TWO-WAY-STREAM-DEVICE-EOFP 44955 . 45131) (%TWO-WAY-STREAM-DEVICE-READP 45133 . 45326) (
|
) (24646 25139 (MAKE-CONCATENATED-STRING-INPUT-STREAM 24646 . 25139)) (25141 25301 (
|
||||||
%TWO-WAY-STREAM-DEVICE-BACKFILEPTR 45328 . 45464) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 45466 . 45695) (
|
%MAKE-INITIAL-STRING-STREAM-CONTENTS 25141 . 25301)) (28348 29874 (MAKE-FILL-POINTER-OUTPUT-STREAM
|
||||||
%TWO-WAY-STREAM-DEVICE-PEEKBIN 45697 . 45910) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45912 . 46245)) (46835
|
28348 . 29874)) (29876 30597 (CL:GET-OUTPUT-STREAM-STRING 29876 . 30597)) (30599 31078 (
|
||||||
47074 (%SYNONYM-STREAM-DEVICE-GET-STREAM 46845 . 47072)) (47780 53743 (%INITIALIZE-CLSTREAM-TYPES
|
\\STRING-STREAM-OUTCHARFN 30599 . 31078)) (31080 32935 (\\ADJUSTABLE-STRING-STREAM-OUTCHARFN 31080 .
|
||||||
47790 . 53741)))))
|
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
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,13 +1,15 @@
|
|||||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED "16-May-90 14:59:25" {DSK}<usr>local>lde>lispcore>sources>COMPARE.;2 12260
|
|
||||||
|
|
||||||
changes to%: (VARS COMPARECOMS)
|
(FILECREATED " 5-Nov-2021 20:53:09" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;2 12484
|
||||||
|
|
||||||
previous date%: "20-Jan-87 12:44:37" {DSK}<usr>local>lde>lispcore>sources>COMPARE.;1)
|
changes to%: (FNS COMPAREPRINTN)
|
||||||
|
|
||||||
|
previous date%: "16-May-90 14:59:25"
|
||||||
|
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>COMPARE.;1)
|
||||||
|
|
||||||
|
|
||||||
(* ; "
|
(* ; "
|
||||||
Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
Copyright (c) 1987, 1990 by Venue & Xerox Corporation.
|
||||||
")
|
")
|
||||||
|
|
||||||
(PRETTYCOMPRINT COMPARECOMS)
|
(PRETTYCOMPRINT COMPARECOMS)
|
||||||
@@ -214,7 +216,11 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
|||||||
(TERPRI STREAM])
|
(TERPRI STREAM])
|
||||||
|
|
||||||
(COMPAREPRINTN
|
(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
|
[COND
|
||||||
((NEQ N 0)
|
((NEQ N 0)
|
||||||
(COND
|
(COND
|
||||||
@@ -223,9 +229,9 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
|||||||
(SELECTQ N
|
(SELECTQ N
|
||||||
(1 (PRIN1 '& STREAM))
|
(1 (PRIN1 '& STREAM))
|
||||||
(PROGN (COND
|
(PROGN (COND
|
||||||
((NOT (ILESSP (IPLUS (POSITION)
|
((NOT (ILESSP (IPLUS (POSITION STREAM)
|
||||||
7)
|
7)
|
||||||
(LINELENGTH)))
|
(LINELENGTH NIL STREAM)))
|
||||||
(TERPRI STREAM)))
|
(TERPRI STREAM)))
|
||||||
(PRIN1 '- STREAM)
|
(PRIN1 '- STREAM)
|
||||||
(PRIN2 N STREAM)
|
(PRIN2 N STREAM)
|
||||||
@@ -299,7 +305,7 @@ Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
|
|||||||
)
|
)
|
||||||
(PUTPROPS COMPARE COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
|
(PUTPROPS COMPARE COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (823 11885 (COMPARELST 833 . 1095) (COMPARE1 1097 . 2506) (COMPAREPRINT 2508 . 3465) (
|
(FILEMAP (NIL (847 12109 (COMPARELST 857 . 1119) (COMPARE1 1121 . 2530) (COMPAREPRINT 2532 . 3489) (
|
||||||
COMPAREPRINT1 3467 . 7731) (COMPARELISTS 7733 . 9020) (COMPAREPRINTN 9022 . 9666) (COMPARENCHARS 9668
|
COMPAREPRINT1 3491 . 7755) (COMPARELISTS 7757 . 9044) (COMPAREPRINTN 9046 . 9890) (COMPARENCHARS 9892
|
||||||
. 10226) (COMPAREFAIL 10228 . 11355) (COMPAREMAX 11357 . 11594) (COUNTDOWN 11596 . 11883)))))
|
. 10450) (COMPAREFAIL 10452 . 11579) (COMPAREMAX 11581 . 11818) (COUNTDOWN 11820 . 12107)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
148
sources/COREIO
148
sources/COREIO
@@ -1,14 +1,15 @@
|
|||||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED " 4-Oct-2018 14:13:06" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>COREIO.;4 55097
|
|
||||||
|
|
||||||
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"
|
changes to%: (FNS \CORE.SETFILEINFO)
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>COREIO.;3)
|
|
||||||
|
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)
|
(PRETTYCOMPRINT COREIOCOMS)
|
||||||
@@ -16,7 +17,7 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
|||||||
(RPAQQ COREIOCOMS
|
(RPAQQ COREIOCOMS
|
||||||
(
|
(
|
||||||
|
|
||||||
(* ;;; "Implementation of Core resident `files'")
|
(* ;;; "Implementation of Core resident `files'")
|
||||||
|
|
||||||
(FNS \CORE.CLOSEFILE \CORE.DELETEFILE \CORE.DIRECTORYNAMEP \CORE.FINDPAGE \CORE.GENERATEFILES
|
(FNS \CORE.CLOSEFILE \CORE.DELETEFILE \CORE.DIRECTORYNAMEP \CORE.FINDPAGE \CORE.GENERATEFILES
|
||||||
\CORE.NEXTFILEFN \CORE.FILEINFOFN \CORE.GETFILEHANDLE \CORE.GETFILEINFO
|
\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])
|
STREAM])
|
||||||
|
|
||||||
(\CORE.SETFILEINFO
|
(\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)))
|
(PROG ((INFOBLOCK (\CORE.GETINFOBLOCK STREAM 'OLD DEV)))
|
||||||
(SELECTQ ATTRIBUTE
|
(SELECTQ ATTRIBUTE
|
||||||
(CREATIONDATE (SETQ VALUE (OR (IDATE VALUE)
|
(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))
|
(replace IOFIBType of INFOBLOCK with VALUE))
|
||||||
(EOL (replace COREEOLC of INFOBLOCK
|
(EOL (replace COREEOLC of INFOBLOCK
|
||||||
with (SELECTQ VALUE
|
with (SELECTQ VALUE
|
||||||
(CR CR.EOLC)
|
(CR CR.EOLC)
|
||||||
(LF LF.EOLC)
|
(LF LF.EOLC)
|
||||||
(CRLF CRLF.EOLC)
|
(CRLF CRLF.EOLC)
|
||||||
(LISPERROR "ILLEGAL ARG" VALUE))))
|
(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])
|
NIL])
|
||||||
|
|
||||||
(\CORE.GETNEXTBUFFER
|
(\CORE.GETNEXTBUFFER
|
||||||
@@ -851,60 +863,48 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999,
|
|||||||
(RECORD CORE.PAGEENTRY (PAGENUMBER . PAGEPOINTER))
|
(RECORD CORE.PAGEENTRY (PAGENUMBER . PAGEPOINTER))
|
||||||
|
|
||||||
(DATATYPE COREFILEINFOBLK ((IOFIBCreationTime FIXP)
|
(DATATYPE COREFILEINFOBLK ((IOFIBCreationTime FIXP)
|
||||||
(IOFIBReadTime FIXP)
|
(IOFIBReadTime FIXP)
|
||||||
(IOFIBWriteTime FIXP)
|
(IOFIBWriteTime FIXP)
|
||||||
(IOFIBType POINTER)
|
(IOFIBType POINTER)
|
||||||
(IOFILEPAGES POINTER)
|
(IOFILEPAGES POINTER)
|
||||||
(IOFILEFULLNAME POINTER)
|
(IOFILEFULLNAME POINTER)
|
||||||
(IOEPAGE WORD)
|
(IOEPAGE WORD)
|
||||||
(IOEOFFSET WORD)
|
(IOEOFFSET WORD)
|
||||||
(COREEOLC BITS 2)
|
(COREEOLC BITS 2)
|
||||||
(IOFIBFileType WORD))
|
(IOFIBFileType WORD))
|
||||||
IOFIBCreationTime _ (IDATE)
|
IOFIBCreationTime _ (IDATE)
|
||||||
IOFILEPAGES _ (LIST (create CORE.PAGEENTRY
|
IOFILEPAGES _ (LIST (create CORE.PAGEENTRY
|
||||||
PAGENUMBER _ 0))
|
PAGENUMBER _ 0))
|
||||||
COREEOLC _ CR.EOLC)
|
COREEOLC _ CR.EOLC)
|
||||||
|
|
||||||
(RECORD CORESTREAM STREAM (SUBRECORD STREAM)
|
(RECORD CORESTREAM STREAM (SUBRECORD STREAM)
|
||||||
[ACCESSFNS CORESTREAM ((INFOBLK (fetch F1 of DATUM)
|
[ACCESSFNS CORESTREAM ((INFOBLK (fetch F1 of DATUM)
|
||||||
(replace F1 of DATUM with
|
(replace F1 of DATUM with NEWVALUE))
|
||||||
NEWVALUE))
|
(COREPAGECACHE (fetch F10 of DATUM)
|
||||||
(COREPAGECACHE (fetch F10 of DATUM)
|
(replace F10 of DATUM with NEWVALUE))
|
||||||
(replace F10 of DATUM with
|
(BEINGPRINTED (fetch IOBEINGPRINTED
|
||||||
NEWVALUE))
|
of (fetch INFOBLK of DATUM))
|
||||||
(BEINGPRINTED (fetch IOBEINGPRINTED
|
(replace IOBEINGPRINTED
|
||||||
of (fetch INFOBLK
|
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||||
of DATUM))
|
(FILEPAGES (fetch IOFILEPAGES
|
||||||
(replace IOBEINGPRINTED
|
of (fetch INFOBLK of DATUM))
|
||||||
of (fetch INFOBLK of DATUM)
|
(replace IOFILEPAGES
|
||||||
with NEWVALUE))
|
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||||
(FILEPAGES (fetch IOFILEPAGES
|
(CreationTime (fetch IOFIBCreationTime
|
||||||
of (fetch INFOBLK
|
of (fetch INFOBLK of DATUM))
|
||||||
of DATUM))
|
(replace IOFIBCreationTime
|
||||||
(replace IOFILEPAGES
|
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||||
of (fetch INFOBLK of DATUM)
|
(ReadTime (fetch IOFIBReadTime
|
||||||
with NEWVALUE))
|
of (fetch INFOBLK of DATUM))
|
||||||
(CreationTime (fetch IOFIBCreationTime
|
(replace IOFIBReadTime
|
||||||
of (fetch INFOBLK
|
of (fetch INFOBLK of DATUM) with NEWVALUE))
|
||||||
of DATUM))
|
(WriteTime (fetch IOFIBWriteTime
|
||||||
(replace IOFIBCreationTime
|
of (fetch INFOBLK of DATUM))
|
||||||
of (fetch INFOBLK of DATUM)
|
(replace IOFIBWriteTime
|
||||||
with NEWVALUE))
|
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)
|
(ACCESSFNS COREDEVICE ((COREDIRECTORY (FETCH DEVICEINFO OF DATUM)
|
||||||
(REPLACE DEVICEINFO OF DATUM WITH NEWVALUE))))
|
(REPLACE DEVICEINFO OF DATUM WITH NEWVALUE))))
|
||||||
|
|
||||||
(RECORD COREGENFILESTATE (COREFILELST))
|
(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
|
(PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||||
1993 1999 2018))
|
1993 1999 2018))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (1755 43279 (\CORE.CLOSEFILE 1765 . 2538) (\CORE.DELETEFILE 2540 . 4526) (
|
(FILEMAP (NIL (1710 44229 (\CORE.CLOSEFILE 1720 . 2493) (\CORE.DELETEFILE 2495 . 4481) (
|
||||||
\CORE.DIRECTORYNAMEP 4528 . 4789) (\CORE.FINDPAGE 4791 . 8020) (\CORE.GENERATEFILES 8022 . 10609) (
|
\CORE.DIRECTORYNAMEP 4483 . 4744) (\CORE.FINDPAGE 4746 . 7975) (\CORE.GENERATEFILES 7977 . 10564) (
|
||||||
\CORE.NEXTFILEFN 10611 . 11110) (\CORE.FILEINFOFN 11112 . 11341) (\CORE.GETFILEHANDLE 11343 . 13497) (
|
\CORE.NEXTFILEFN 10566 . 11065) (\CORE.FILEINFOFN 11067 . 11296) (\CORE.GETFILEHANDLE 11298 . 13452) (
|
||||||
\CORE.GETFILEINFO 13499 . 14462) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14464 . 16001) (\CORE.GETFILENAME
|
\CORE.GETFILEINFO 13454 . 14417) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14419 . 15956) (\CORE.GETFILENAME
|
||||||
16003 . 18292) (\CORE.GETINFOBLOCK 18294 . 20917) (\CORE.NAMESCAN 20919 . 22686) (\CORE.NAMESEGMENT
|
15958 . 18247) (\CORE.GETINFOBLOCK 18249 . 20872) (\CORE.NAMESCAN 20874 . 22641) (\CORE.NAMESEGMENT
|
||||||
22688 . 23125) (\CORE.OPENFILE 23127 . 26246) (\COREFILE.SETPARAMETERS 26248 . 28429) (
|
22643 . 23080) (\CORE.OPENFILE 23082 . 26201) (\COREFILE.SETPARAMETERS 26203 . 28384) (
|
||||||
\CORE.PACKFILENAME 28431 . 28826) (\CORE.RELEASEPAGES 28828 . 29429) (\CORE.SETFILEPTR 29431 . 30530)
|
\CORE.PACKFILENAME 28386 . 28781) (\CORE.RELEASEPAGES 28783 . 29384) (\CORE.SETFILEPTR 29386 . 30485)
|
||||||
(\CORE.UPDATEOF 30532 . 32161) (\CORE.BACKFILEPTR 32163 . 34371) (\CORE.SETEOFPTR 34373 . 36242) (
|
(\CORE.UPDATEOF 30487 . 32116) (\CORE.BACKFILEPTR 32118 . 34326) (\CORE.SETEOFPTR 34328 . 36197) (
|
||||||
\CORE.SETACCESSTIME 36244 . 36869) (\CORE.SETFILEINFO 36871 . 38062) (\CORE.GETNEXTBUFFER 38064 .
|
\CORE.SETACCESSTIME 36199 . 36824) (\CORE.SETFILEINFO 36826 . 39012) (\CORE.GETNEXTBUFFER 39014 .
|
||||||
42020) (\CORE.UNPACKFILENAME 42022 . 43277)) (43280 46913 (COREDEVICE 43290 . 43461) (
|
42970) (\CORE.UNPACKFILENAME 42972 . 44227)) (44230 47863 (COREDEVICE 44240 . 44411) (
|
||||||
\CREATECOREDEVICE 43463 . 46911)) (46914 49215 (\NODIRCOREFDEV 46924 . 47521) (\NODIRCORE.OPENFILE
|
\CREATECOREDEVICE 44413 . 47861)) (47864 50165 (\NODIRCOREFDEV 47874 . 48471) (\NODIRCORE.OPENFILE
|
||||||
47523 . 49213)))))
|
48473 . 50163)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,13 +1,14 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(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 "27-Nov-2021 13:28:18"
|
||||||
|
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;2 37858
|
||||||
|
|
||||||
previous date%: " 5-Feb-91 11:44:57" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>EDITINTERFACE.;5|)
|
previous date%: " 7-Nov-91 18:15:13"
|
||||||
|
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>EDITINTERFACE.;1)
|
||||||
|
|
||||||
|
|
||||||
(* ; "
|
(* ; "
|
||||||
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)
|
(PRETTYCOMPRINT EDITINTERFACECOMS)
|
||||||
@@ -93,8 +94,8 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
(RPAQQ DUMMY-EDIT-FUNCTION-BODY [LAMBDA (ARGS ...)
|
(RPAQQ DUMMY-EDIT-FUNCTION-BODY [LAMBDA (ARGS |...|)
|
||||||
BODY])
|
BODY])
|
||||||
|
|
||||||
(CL:DEFVAR *ED-OFFERS-PROPERTY-LIST* T
|
(CL:DEFVAR *ED-OFFERS-PROPERTY-LIST* T
|
||||||
"Controls whether ED offers property list as an editable aspect")
|
"Controls whether ED offers property list as an editable aspect")
|
||||||
@@ -102,7 +103,7 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
|
(DEFGLOBALVAR XCL::ED-LAST-INFO NIL
|
||||||
"used in ED to stash last call info so (ED NIL) will restart last edit")
|
"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.")
|
(* ;;; "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 +125,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:MEMBER 'DISPLAY CL::OPTIONS)))
|
(CL:MEMBER 'DISPLAY CL::OPTIONS)))
|
||||||
(CL::GIVEN-TYPES (for X inside CL::OPTIONS when (NEQ X T) bind TYPE
|
(CL::GIVEN-TYPES (for X inside CL::OPTIONS when (NEQ X T) bind TYPE
|
||||||
when (CL:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T CL::NAME))
|
when (CL:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T CL::NAME)) collect TYPE))
|
||||||
collect TYPE))
|
|
||||||
[CL::TYPES-WITH-DEFNS (TYPESOF CL::NAME CL::GIVEN-TYPES NIL
|
[CL::TYPES-WITH-DEFNS (TYPESOF CL::NAME CL::GIVEN-TYPES NIL
|
||||||
(CL:IF (OR (CL:MEMBER :CURRENT CL::OPTIONS)
|
(CL:IF (OR (CL:MEMBER :CURRENT CL::OPTIONS)
|
||||||
(CL:MEMBER 'CURRENT CL::OPTIONS))
|
(CL:MEMBER 'CURRENT CL::OPTIONS))
|
||||||
@@ -138,9 +138,9 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
([AND (NULL CL::GIVEN-TYPES)
|
([AND (NULL CL::GIVEN-TYPES)
|
||||||
(CL:SYMBOLP CL::NAME)
|
(CL:SYMBOLP CL::NAME)
|
||||||
(NOT (NULL *ED-OFFERS-PROPERTY-LIST*))
|
(NOT (NULL *ED-OFFERS-PROPERTY-LIST*))
|
||||||
(find X on (GETPROPLIST CL::NAME)
|
(find X on (GETPROPLIST CL::NAME) by (CDDR X)
|
||||||
by (CDDR X) suchthat (NULL (GET (CAR X)
|
suchthat (NULL (GET (CAR X)
|
||||||
'PROPTYPE]
|
'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.")
|
(* ;; "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 +150,55 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
(CL:WHEN (CL:MEMBER 'PROPERTY-LIST CL::OPTIONS)
|
(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 CL::POSSIBLE-TYPES '(PROPERTY-LIST)))
|
||||||
[CL:SETQ TYPE (if (CL:MEMBER :NEW CL::OPTIONS)
|
[CL:SETQ TYPE (if (CL:MEMBER :NEW CL::OPTIONS)
|
||||||
then
|
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)
|
||||||
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME (OR CL::TYPES-WITH-DEFNS
|
:NEW)
|
||||||
CL::GIVEN-TYPES)
|
(CL:RETURN-FROM ED NIL))
|
||||||
:NEW)
|
|
||||||
(CL:RETURN-FROM ED NIL))
|
|
||||||
elseif (CDR CL::POSSIBLE-TYPES)
|
elseif (CDR CL::POSSIBLE-TYPES)
|
||||||
then
|
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
|
||||||
(if CL::FROM-DISPLAY
|
ITEMS _ CL::POSSIBLE-TYPES
|
||||||
then (OR (MENU (create MENU
|
TITLE _ (CL:FORMAT NIL
|
||||||
ITEMS _ CL::POSSIBLE-TYPES
|
|
||||||
TITLE _ (CL:FORMAT NIL
|
|
||||||
"Edit which definition of ~S ?"
|
"Edit which definition of ~S ?"
|
||||||
CL::NAME)))
|
CL::NAME)))
|
||||||
(CL:RETURN-FROM ED NIL))
|
(CL:RETURN-FROM ED NIL))
|
||||||
else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES)
|
else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES)
|
||||||
(CL:FORMAT NIL "Edit which ~A definition of ~S ? "
|
(CL:FORMAT NIL "Edit which ~A definition of ~S ? "
|
||||||
CL::POSSIBLE-TYPES CL::NAME)
|
CL::POSSIBLE-TYPES CL::NAME)
|
||||||
CL::POSSIBLE-TYPES))
|
CL::POSSIBLE-TYPES))
|
||||||
elseif (NOT (NULL CL::POSSIBLE-TYPES))
|
elseif (NOT (NULL CL::POSSIBLE-TYPES))
|
||||||
then
|
then
|
||||||
|
(* ;; "Exactly one type was found.")
|
||||||
|
|
||||||
(* ;; "Exactly one type was found.")
|
(if CL::FROM-DISPLAY
|
||||||
|
then (* ; "prepare the prompt window")
|
||||||
(if CL::FROM-DISPLAY
|
(TERPRI PROMPTWINDOW))
|
||||||
then (* ; "prepare the prompt window")
|
(CL:FORMAT (if CL::FROM-DISPLAY
|
||||||
(TERPRI PROMPTWINDOW))
|
then PROMPTWINDOW
|
||||||
(CL:FORMAT (if CL::FROM-DISPLAY
|
else T)
|
||||||
then PROMPTWINDOW
|
"Editing ~A ~A ~S.~%%"
|
||||||
else T)
|
(CAR CL::POSSIBLE-TYPES)
|
||||||
"Editing ~A ~A ~S.~%%"
|
(CL:IF (EQ (CAR CL::POSSIBLE-TYPES)
|
||||||
(CAR CL::POSSIBLE-TYPES)
|
'PROPERTY-LIST)
|
||||||
(CL:IF (EQ (CAR CL::POSSIBLE-TYPES)
|
"of"
|
||||||
'PROPERTY-LIST)
|
"definition of")
|
||||||
"of"
|
CL::NAME)
|
||||||
"definition of")
|
(CAR CL::POSSIBLE-TYPES)
|
||||||
CL::NAME)
|
|
||||||
(CAR CL::POSSIBLE-TYPES)
|
|
||||||
else
|
else
|
||||||
|
(* ;; "No types were found. Use the DefDefiner prototyping machinery.")
|
||||||
|
|
||||||
(* ;;
|
(OR (INSTALL-PROTOTYPE-DEFN CL::NAME CL::GIVEN-TYPES)
|
||||||
"No types were found. Use the DefDefiner prototyping machinery.")
|
(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)
|
(CL:IF (EQ TYPE 'PROPERTY-LIST)
|
||||||
(EDITE (GETPROPLIST CL::NAME)
|
(EDITE (GETPROPLIST CL::NAME)
|
||||||
NIL CL::NAME 'PROPLST NIL CL::OPTIONS)
|
NIL CL::NAME 'PROPLST NIL CL::OPTIONS)
|
||||||
@@ -232,17 +227,16 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
PROTOTYPE-TYPE)
|
PROTOTYPE-TYPE)
|
||||||
(IF (AND NEW-DEFN-FLG TYPES-WITH-PROTOTYPES)
|
(IF (AND NEW-DEFN-FLG TYPES-WITH-PROTOTYPES)
|
||||||
THEN (IF (CDR TYPES-WITH-PROTOTYPES)
|
THEN (IF (CDR TYPES-WITH-PROTOTYPES)
|
||||||
THEN (CL:FORMAT T "Installing new definition for ~S~%%" NAME)
|
THEN (CL:FORMAT T "Installing new definition for ~S~%%" NAME)
|
||||||
ELSE (CL:FORMAT T "Installing new ~S definition for ~S~%%" (CAR
|
ELSE (CL:FORMAT T "Installing new ~S definition for ~S~%%" (CAR TYPES-WITH-PROTOTYPES
|
||||||
TYPES-WITH-PROTOTYPES
|
)
|
||||||
)
|
NAME))
|
||||||
NAME))
|
|
||||||
ELSEIF (NULL REQUESTED-TYPES)
|
ELSEIF (NULL REQUESTED-TYPES)
|
||||||
THEN (CL:FORMAT T "~S has no definitions.~%%" NAME)
|
THEN (CL:FORMAT T "~S has no definitions.~%%" NAME)
|
||||||
ELSEIF (NULL (CDR REQUESTED-TYPES))
|
ELSEIF (NULL (CDR REQUESTED-TYPES))
|
||||||
THEN (CL:FORMAT T "~S has no ~A definition.~%%" NAME (CAR 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
|
ELSE (CL:FORMAT T "~S has no definition of any of these types:~%% ~A~%%" NAME REQUESTED-TYPES
|
||||||
REQUESTED-TYPES))
|
))
|
||||||
[IF (NULL TYPES-WITH-PROTOTYPES)
|
[IF (NULL TYPES-WITH-PROTOTYPES)
|
||||||
THEN (CL:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL)
|
THEN (CL:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL)
|
||||||
ELSEIF (NULL (CDR TYPES-WITH-PROTOTYPES))
|
ELSEIF (NULL (CDR TYPES-WITH-PROTOTYPES))
|
||||||
@@ -258,13 +252,10 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
(APPEND
|
(APPEND
|
||||||
[FOR TYPE IN TYPES-WITH-PROTOTYPES
|
[FOR TYPE IN TYPES-WITH-PROTOTYPES
|
||||||
COLLECT `(,TYPE '(:TYPE ,TYPE)
|
COLLECT `(,TYPE '(:TYPE ,TYPE)
|
||||||
"Displays a menu of definers for this type."
|
"Displays a menu of definers for this type."
|
||||||
(SUBITEMS ,@(FOR DEFINER IN (
|
(SUBITEMS ,@(FOR DEFINER IN (XCL::PROTOTYPE-DEFINERS-FOR-TYPE TYPE)
|
||||||
XCL::PROTOTYPE-DEFINERS-FOR-TYPE
|
COLLECT `(,DEFINER '(:DEFINER ,TYPE ,DEFINER)
|
||||||
TYPE)
|
,DEFINER-HELP-STRING]
|
||||||
COLLECT `(,DEFINER '(:DEFINER ,TYPE
|
|
||||||
,DEFINER)
|
|
||||||
,DEFINER-HELP-STRING]
|
|
||||||
(LIST '("Don't make a dummy defn" NIL]
|
(LIST '("Don't make a dummy defn" NIL]
|
||||||
(RESULT (MENU MENU)))
|
(RESULT (MENU MENU)))
|
||||||
(CL:ECASE (CL:FIRST RESULT)
|
(CL:ECASE (CL:FIRST RESULT)
|
||||||
@@ -281,7 +272,7 @@ Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All ri
|
|||||||
(LIST '("Don't make a dummy defn" NIL]
|
(LIST '("Don't make a dummy defn" NIL]
|
||||||
(IF DEFINER
|
(IF DEFINER
|
||||||
THEN (MAKE-AND-INSTALL PROTOTYPE-TYPE DEFINER)
|
THEN (MAKE-AND-INSTALL PROTOTYPE-TYPE DEFINER)
|
||||||
PROTOTYPE-TYPE
|
PROTOTYPE-TYPE
|
||||||
ELSE NIL])
|
ELSE NIL])
|
||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
@@ -745,10 +736,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))
|
(PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (14507 31290 (EDITDEF.FNS 14517 . 15853) (EDITF 15855 . 16735) (EDITFB 16737 . 17585) (
|
(FILEMAP (NIL (3710 10009 (ED 3710 . 10009)) (10011 13987 (INSTALL-PROTOTYPE-DEFN 10011 . 13987)) (
|
||||||
EDITFNS 17587 . 18907) (EDITLOADFNS? 18909 . 22709) (EDITMODE 22711 . 24721) (EDITP 24723 . 25234) (
|
13988 30771 (EDITDEF.FNS 13998 . 15334) (EDITF 15336 . 16216) (EDITFB 16218 . 17066) (EDITFNS 17068 .
|
||||||
EDITV 25236 . 25875) (DC 25877 . 26558) (DF 26560 . 27602) (DP 27604 . 28688) (DV 28690 . 29262) (
|
18388) (EDITLOADFNS? 18390 . 22190) (EDITMODE 22192 . 24202) (EDITP 24204 . 24715) (EDITV 24717 .
|
||||||
EDITPROP 29264 . 29483) (EF 29485 . 29814) (EP 29816 . 29999) (EV 30001 . 30180) (EDITE 30182 . 31060)
|
25356) (DC 25358 . 26039) (DF 26041 . 27083) (DP 27085 . 28169) (DV 28171 . 28743) (EDITPROP 28745 .
|
||||||
(EDITL 31062 . 31288)) (31640 37712 (NEW/EDITDATE 31650 . 31872) (FIXEDITDATE 31874 . 33716) (
|
28964) (EF 28966 . 29295) (EP 29297 . 29480) (EV 29482 . 29661) (EDITE 29663 . 30541) (EDITL 30543 .
|
||||||
EDITDATE? 33718 . 34896) (EDITDATE 34898 . 35715) (SETINITIALS 35717 . 37710)))))
|
30769)) (31121 37193 (NEW/EDITDATE 31131 . 31353) (FIXEDITDATE 31355 . 33197) (EDITDATE? 33199 . 34377
|
||||||
|
) (EDITDATE 34379 . 35196) (SETINITIALS 35198 . 37191)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
255
sources/FASLOAD
255
sources/FASLOAD
@@ -1,11 +1,12 @@
|
|||||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL")
|
(DEFINE-FILE-INFO PACKAGE "FASL" READTABLE "XCL" BASE 10)
|
||||||
(IL:FILECREATED "10-Jun-2021 18:26:43"
|
|
||||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;8| 35584
|
|
||||||
|
|
||||||
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:|changes| IL:|to:| (IL:FNS CONVERT-FASL-DATE)
|
||||||
IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|
||||||
|
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.
|
; 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: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: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:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILES (NIL IL:SOURCE)
|
||||||
IL:FASL-SUPPORT))
|
IL:FASL-SUPPORT))
|
||||||
@@ -33,26 +34,26 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
(IL:FUNCTIONS TABLE-STATS))
|
(IL:FUNCTIONS TABLE-STATS))
|
||||||
(IL:COMS
|
(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:STRUCTURES OPTABLE)
|
||||||
(IL:FUNCTIONS MAKE-OPTABLE DEFINE-OPCODE-RANGE DEFINE-SINGLE-OPCODE
|
(IL:FUNCTIONS MAKE-OPTABLE DEFINE-OPCODE-RANGE DEFINE-SINGLE-OPCODE
|
||||||
ADD-OP-TRANSLATION OPCODE-SEQUENCE)
|
ADD-OP-TRANSLATION OPCODE-SEQUENCE)
|
||||||
(IL:* IL:\; "Opcode definers")
|
(IL:* IL:\; "Opcode definers")
|
||||||
(IL:FUNCTIONS DEFOP DEFRANGE))
|
(IL:FUNCTIONS DEFOP DEFRANGE))
|
||||||
(IL:FUNCTIONS FASL-END-OF-BLOCK FASL-EXTENDED SETESCAPE UNIMPLEMENTED-OPCODE)
|
(IL:FUNCTIONS FASL-END-OF-BLOCK FASL-EXTENDED SETESCAPE UNIMPLEMENTED-OPCODE)
|
||||||
(IL:VARIABLES *DEFAULT-OPTABLE* *CURRENT-OPTABLE* INITIAL-VALUE-TABLE-SIZE
|
(IL:VARIABLES *DEFAULT-OPTABLE* *CURRENT-OPTABLE* INITIAL-VALUE-TABLE-SIZE
|
||||||
VALUE-TABLE-INCREMENT *VALUE-TABLE* *BLOCK-LEVEL* DEBUG-READER DEBUG-STREAM)
|
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 PROCESS-FILE PROCESS-SEGMENT)
|
||||||
(IL:FUNCTIONS WITH-OPTABLE CHECK-VERSION READ-TEXT PROCESS-BLOCK SKIP-TEXT
|
(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
|
NEXT-VALUE DO-OP NEW-VALUE-TABLE CLEAR-TABLE STORE-VALUE FETCH-VALUE
|
||||||
COLLECT-LIST)
|
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-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
|
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))
|
FASL-FUNCALL FASL-BITMAP16 FASL-STRUCTURE))
|
||||||
(XCL:OPTIMIZERS FIXUP-NTOFFSET)
|
(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:P (IL:MOVD? 'IL:PRIN1 'PRINC)
|
||||||
(IL:MOVD? 'IL:TERPRI 'TERPRI))
|
(IL:MOVD? 'IL:TERPRI 'TERPRI))
|
||||||
(IL:COMS
|
(IL:COMS
|
||||||
|
|
||||||
(IL:* IL:|;;|
|
(IL:* IL:|;;|
|
||||||
"ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files.")
|
"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: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:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
|
||||||
IL:FASLOAD)))
|
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")
|
"End-of-data marker: if first byte of a segment, terminate processing")
|
||||||
|
|
||||||
(DEFCONSTANT VERSION-RANGE '(8 . 8)
|
(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)
|
(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)
|
(DEFUN DEFINE-OPCODE-RANGE (NAME FIRST-OPCODE RANGE OFFSET TABLE)
|
||||||
|
|
||||||
(IL:* IL:|;;|
|
(IL:* IL:|;;|
|
||||||
"For implementation of DEFRANGE definer--define a range of opcodes having the same implementation.")
|
"For implementation of DEFRANGE definer--define a range of opcodes having the same implementation.")
|
||||||
|
|
||||||
(LET ((PACKAGE (SYMBOL-PACKAGE NAME))
|
(LET ((PACKAGE (SYMBOL-PACKAGE NAME))
|
||||||
(PNAME (SYMBOL-NAME NAME)))
|
(PNAME (SYMBOL-NAME NAME)))
|
||||||
(DOTIMES (I RANGE) (IL:* IL:\;
|
(DOTIMES (I RANGE) (IL:* IL:\;
|
||||||
"Using IL:CONCAT here to minimize bootstrap woes")
|
"Using IL:CONCAT here to minimize bootstrap woes")
|
||||||
(DEFINE-SINGLE-OPCODE NAME (+ I FIRST-OPCODE)
|
(DEFINE-SINGLE-OPCODE NAME (+ I FIRST-OPCODE)
|
||||||
TABLE
|
TABLE
|
||||||
(INTERN (IL:CONCAT PNAME (+ I OFFSET))
|
(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)
|
(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)
|
(SETF (ELT (OPTABLE-VECTOR TABLE)
|
||||||
OPCODE)
|
OPCODE)
|
||||||
@@ -213,7 +214,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
(OPTABLE-OPNAMES TABLE)))))
|
(OPTABLE-OPNAMES TABLE)))))
|
||||||
|
|
||||||
(DEFUN OPCODE-SEQUENCE (OPNAME &OPTIONAL (TABLE *DEFAULT-OPTABLE*)
|
(DEFUN OPCODE-SEQUENCE (OPNAME &OPTIONAL (TABLE *DEFAULT-OPTABLE*)
|
||||||
&AUX ENTRY)
|
&AUX ENTRY)
|
||||||
(COND
|
(COND
|
||||||
((NULL TABLE)
|
((NULL TABLE)
|
||||||
NIL)
|
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)
|
(XCL:DEFDEFINER DEFOP FASL-OPS (IL:NAME (OPCODE &KEY (INDIRECT 0)
|
||||||
(TABLE '*DEFAULT-OPTABLE*))
|
(TABLE '*DEFAULT-OPTABLE*))
|
||||||
&BODY BODY)
|
&BODY BODY)
|
||||||
(IF (ZEROP INDIRECT)
|
(IF (ZEROP INDIRECT)
|
||||||
`(PROGN (DEFUN ,IL:NAME (STREAM OPCODE)
|
`(PROGN (DEFUN ,IL:NAME (STREAM OPCODE)
|
||||||
,@BODY)
|
,@BODY)
|
||||||
@@ -245,8 +246,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
,@BODY))))
|
,@BODY))))
|
||||||
|
|
||||||
(XCL:DEFDEFINER DEFRANGE FASL-OPS (IL:NAME (FIRST-OPCODE &KEY (INDIRECT 0)
|
(XCL:DEFDEFINER DEFRANGE FASL-OPS (IL:NAME (FIRST-OPCODE &KEY (INDIRECT 0)
|
||||||
(TABLE '*DEFAULT-OPTABLE*))
|
(TABLE '*DEFAULT-OPTABLE*))
|
||||||
RANGE OFFSET &BODY BODY)
|
RANGE OFFSET &BODY BODY)
|
||||||
(IF (ZEROP INDIRECT)
|
(IF (ZEROP INDIRECT)
|
||||||
`(PROGN (DEFUN ,IL:NAME (STREAM OPCODE)
|
`(PROGN (DEFUN ,IL:NAME (STREAM OPCODE)
|
||||||
,@BODY)
|
,@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)
|
(DEFUN PROCESS-FILE (STREAM &KEY (TEXT-FN (AND *LOAD-VERBOSE* #'(LAMBDA (TEXT)
|
||||||
(PRINC TEXT)
|
(PRINC TEXT)
|
||||||
(TERPRI))))
|
(TERPRI))))
|
||||||
(ITEM-FN NIL))
|
(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)
|
(UNLESS (EQL (IL:BIN STREAM)
|
||||||
SIGNATURE)
|
SIGNATURE)
|
||||||
@@ -310,8 +311,8 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
(LET ((IL:FILEPKGFLG NIL)
|
(LET ((IL:FILEPKGFLG NIL)
|
||||||
(IL:DFNFLG T)
|
(IL:DFNFLG T)
|
||||||
(IL:LISPXHIST NIL)
|
(IL:LISPXHIST NIL)
|
||||||
(IL:ADDSPELLFLG NIL)) (IL:* IL:\;
|
(IL:ADDSPELLFLG NIL)) (IL:* IL:\;
|
||||||
"Bind these so that LOADing a FASL file is like LOADing SYSLOAD.")
|
"Bind these so that LOADing a FASL file is like LOADing SYSLOAD.")
|
||||||
(DECLARE (SPECIAL IL:FILEPKGFLG IL:DFNFLG IL:LISPXHIST IL:ADDSPELLFLG))
|
(DECLARE (SPECIAL IL:FILEPKGFLG IL:DFNFLG IL:LISPXHIST IL:ADDSPELLFLG))
|
||||||
(IF (< (CHECK-VERSION STREAM)
|
(IF (< (CHECK-VERSION STREAM)
|
||||||
5)
|
5)
|
||||||
@@ -346,9 +347,9 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
|
|
||||||
(DEFUN READ-TEXT (STREAM)
|
(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))
|
(DO ((RESULT (MAKE-ARRAY 512 :ELEMENT-TYPE 'CHARACTER :ADJUSTABLE T :FILL-POINTER 0))
|
||||||
(BYTE (IL:BIN STREAM)
|
(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*
|
(IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT*
|
||||||
(CATCH 'FASL-BLOCK-FINISHED
|
(CATCH 'FASL-BLOCK-FINISHED
|
||||||
(WITH-OPTABLE OPTABLE (DO ((*VALUE-TABLE* (NEW-VALUE-TABLE))
|
(WITH-OPTABLE OPTABLE (DO ((*VALUE-TABLE* (NEW-VALUE-TABLE))
|
||||||
VAL)
|
VAL)
|
||||||
()
|
()
|
||||||
(SETF VAL (DO-OP STREAM 0))
|
(SETF VAL (DO-OP STREAM 0))
|
||||||
(WHEN ITEM-FN (FUNCALL ITEM-FN VAL)))))))
|
(WHEN ITEM-FN (FUNCALL ITEM-FN VAL)))))))
|
||||||
|
|
||||||
(DEFUN SKIP-TEXT (STREAM)
|
(DEFUN SKIP-TEXT (STREAM)
|
||||||
(DO ((BYTE (IL:BIN 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*))
|
(DEFUN STORE-VALUE (OBJ &OPTIONAL (TABLE *VALUE-TABLE*))
|
||||||
|
|
||||||
(IL:* IL:|;;|
|
(IL:* IL:|;;|
|
||||||
"This may want to change to another representation if we can't make VECTOR-PUSH-EXTEND fast enough.")
|
"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)
|
(VECTOR-PUSH-EXTEND OBJ TABLE VALUE-TABLE-INCREMENT)
|
||||||
OBJ)
|
OBJ)
|
||||||
@@ -416,7 +417,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
(WHEN DOTTED (DECF NELTS))
|
(WHEN DOTTED (DECF NELTS))
|
||||||
(LET ((RESULT (IL:|to| NELTS IL:|collect| (DO-OP STREAM))))
|
(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
|
(WHEN DOTTED
|
||||||
(SETF (CDR (LAST RESULT))
|
(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)
|
(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))
|
(LET* ((NCHARS (NEXT-VALUE))
|
||||||
(STRING (IL:ALLOCSTRING NCHARS)))
|
(STRING (IL:ALLOCSTRING NCHARS)))
|
||||||
(IL:ACCESS-CHARSET STREAM 0) (IL:* IL:\;
|
(IL:ACCESS-CHARSET STREAM 0) (IL:* IL:\;
|
||||||
"Make sure we're in charset zero")
|
"Make sure we're in charset zero")
|
||||||
(UNWIND-PROTECT
|
(UNWIND-PROTECT
|
||||||
(DOTIMES (I NCHARS STRING)
|
(DOTIMES (I NCHARS STRING)
|
||||||
(SETF (SVREF STRING I)
|
(SETF (SVREF STRING I)
|
||||||
(CODE-CHAR (IL:READCCODE STREAM)))) (IL:* IL:\;
|
(CODE-CHAR (IL:READCCODE STREAM)))) (IL:* IL:\;
|
||||||
"Restore charset zero, in case anyone cares")
|
"Restore charset zero, in case anyone cares")
|
||||||
(IL:ACCESS-CHARSET STREAM 0))))
|
(IL:ACCESS-CHARSET STREAM 0))))
|
||||||
|
|
||||||
(DEFOP FASL-CHARACTER (142)
|
(DEFOP FASL-CHARACTER (142)
|
||||||
@@ -571,7 +572,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
|
|
||||||
(DEFOP FASL-DCODE (150)
|
(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)
|
(LET ((OVERHEADBYTES (* (IL:FETCH (IL:FNHEADER IL:OVERHEADWORDS) IL:OF T)
|
||||||
IL:BYTESPERWORD))
|
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:\\BINS STREAM RAW-CODE START-PC CODE-LEN)
|
||||||
(IL:REPLACE (IL:FNHEADER IL:STARTPC) IL:OF RAW-CODE IL:WITH START-PC))
|
(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))
|
(DO* ((I 0 (1+ I))
|
||||||
(INDEX OVERHEADBYTES (+ INDEX (IL:CONSTANT (IL:BYTESPERNAMEENTRY))))
|
(INDEX OVERHEADBYTES (+ INDEX (IL:CONSTANT (IL:BYTESPERNAMEENTRY))))
|
||||||
|
|
||||||
(IL:* IL:|;;|
|
(IL:* IL:|;;|
|
||||||
"NTSIZE and NTBYTESIZE the sizes of half the table in words and bytes resp.")
|
"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))))
|
(NTSIZE (IL:CEIL (1+ (IL:UNFOLD NT-COUNT (IL:CONSTANT (IL:WORDSPERNAMEENTRY))))
|
||||||
IL:WORDSPERQUAD))
|
IL:WORDSPERQUAD))
|
||||||
(NTBYTESIZE (* NTSIZE IL:BYTESPERWORD))
|
(NTBYTESIZE (* NTSIZE IL:BYTESPERWORD))
|
||||||
PFI OFFSET NAME FVAROFFSET)
|
PFI OFFSET NAME FVAROFFSET)
|
||||||
((>= I NT-COUNT)
|
((>= I NT-COUNT)
|
||||||
(IL:REPLACE (IL:FNHEADER IL:FVAROFFSET) IL:OF RAW-CODE IL:WITH (OR
|
(IL:REPLACE (IL:FNHEADER IL:FVAROFFSET) IL:OF RAW-CODE IL:WITH (OR FVAROFFSET 0))
|
||||||
FVAROFFSET
|
(IL:REPLACE (IL:FNHEADER IL:NTSIZE) IL:OF RAW-CODE IL:WITH (IF (ZEROP NT-COUNT)
|
||||||
0))
|
|
||||||
(IL:REPLACE (IL:FNHEADER IL:NTSIZE) IL:OF RAW-CODE IL:WITH
|
|
||||||
(IF (ZEROP NT-COUNT)
|
|
||||||
0
|
0
|
||||||
NTSIZE)))
|
NTSIZE)))
|
||||||
(SETF PFI (IL:BIN STREAM))
|
(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+))
|
(= PFI D-ASSEM:+FVAR-CODE+))
|
||||||
(SETF FVAROFFSET (FLOOR INDEX IL:BYTESPERWORD))))
|
(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)))
|
(LET ((FRAME-NAME (NEXT-VALUE)))
|
||||||
(IL:UNINTERRUPTABLY
|
(IL:UNINTERRUPTABLY
|
||||||
(IL:\\ADDREF FRAME-NAME)
|
(IL:\\ADDREF FRAME-NAME)
|
||||||
(IL:REPLACE (IL:FNHEADER IL:\#FRAMENAME) IL:OF RAW-CODE IL:WITH
|
(IL:REPLACE (IL:FNHEADER IL:\#FRAMENAME) IL:OF RAW-CODE IL:WITH FRAME-NAME)))
|
||||||
FRAME-NAME)))
|
|
||||||
(LET ((NLOCALS (IL:BIN STREAM))
|
(LET ((NLOCALS (IL:BIN STREAM))
|
||||||
(NFREEVARS (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:NLOCALS) IL:OF RAW-CODE IL:WITH NLOCALS)
|
||||||
(IL:REPLACE (IL:FNHEADER IL:PV) IL:OF RAW-CODE
|
(IL:REPLACE (IL:FNHEADER IL:PV) IL:OF RAW-CODE IL:WITH (1- (CEILING (+ NLOCALS NFREEVARS
|
||||||
IL:WITH (1- (CEILING (+ NLOCALS NFREEVARS)
|
)
|
||||||
IL:CELLSPERQUAD))))
|
IL:CELLSPERQUAD))))
|
||||||
(IL:REPLACE (IL:FNHEADER IL:ARGTYPE) IL:OF RAW-CODE IL:WITH (IL:BIN STREAM))
|
(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))
|
(IL:REPLACE (IL:FNHEADER IL:NA) IL:OF RAW-CODE IL:WITH (NEXT-VALUE))
|
||||||
(SETF CLOSURE-INFO (NEXT-VALUE))
|
(SETF CLOSURE-INFO (NEXT-VALUE))
|
||||||
(IL:REPLACE (IL:FNHEADER IL:CLOSUREP) IL:OF RAW-CODE IL:WITH (EQ CLOSURE-INFO
|
(IL:REPLACE (IL:FNHEADER IL:CLOSUREP) IL:OF RAW-CODE IL:WITH (EQ CLOSURE-INFO :CLOSURE))
|
||||||
:CLOSURE))
|
|
||||||
(IL:REPLACE (IL:FNHEADER IL:FIXED) IL:OF RAW-CODE IL:WITH T)
|
(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))
|
(D-ASSEM:FIXUP-PTR RAW-CODE (- START-PC (IL:BIG-VMEM-CODE 4 3))
|
||||||
(NEXT-VALUE))
|
(NEXT-VALUE))
|
||||||
|
|
||||||
(IL:* IL:|;;| "Do fixups")
|
(IL:* IL:|;;| "Do fixups")
|
||||||
|
|
||||||
(DO ((FN-FIXUP-COUNT (NEXT-VALUE))
|
(DO ((FN-FIXUP-COUNT (NEXT-VALUE))
|
||||||
(I 0 (1+ I))
|
(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)
|
(D-ASSEM:FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
|
||||||
(IL:\\RESOLVE.TYPENUMBER VALUE)))
|
(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)
|
(IF (EQ CLOSURE-INFO :FUNCTION)
|
||||||
(IL:MAKE-COMPILED-CLOSURE RAW-CODE NIL)
|
(IL:MAKE-COMPILED-CLOSURE RAW-CODE NIL)
|
||||||
RAW-CODE)))
|
RAW-CODE)))
|
||||||
|
|
||||||
(DEFOP FASL-LOCAL-FN-FIXUPS (151)
|
(DEFOP FASL-LOCAL-FN-FIXUPS (151)
|
||||||
(LET ((PASS-THROUGH (NEXT-VALUE))) (IL:* IL:\;
|
(LET ((PASS-THROUGH (NEXT-VALUE))) (IL:* IL:\;
|
||||||
"This will typically correspond to the DCODE that had the fixups, but can be anything.")
|
"This will typically correspond to the DCODE that had the fixups, but can be anything.")
|
||||||
(DO ((FIXUP-COUNT (NEXT-VALUE))
|
(DO ((FIXUP-COUNT (NEXT-VALUE))
|
||||||
(I 0 (IL:ADD1 I))
|
(I 0 (IL:ADD1 I))
|
||||||
CODE-TO-FIX OFFSET VALUE)
|
CODE-TO-FIX OFFSET VALUE)
|
||||||
@@ -701,8 +697,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
,THING))))
|
,THING))))
|
||||||
(IF (EQ CODE-TO-FIX VALUE)
|
(IF (EQ CODE-TO-FIX VALUE)
|
||||||
(LET ((CODE (GET-CODE CODE-TO-FIX)))
|
(LET ((CODE (GET-CODE CODE-TO-FIX)))
|
||||||
(D-ASSEM:FIXUP-PTR-NO-REF CODE (IL:IPLUS (IL:FETCH (IL:FNHEADER
|
(D-ASSEM:FIXUP-PTR-NO-REF CODE (IL:IPLUS (IL:FETCH (IL:FNHEADER IL:STARTPC)
|
||||||
IL:STARTPC)
|
|
||||||
IL:OF CODE)
|
IL:OF CODE)
|
||||||
OFFSET)
|
OFFSET)
|
||||||
VALUE))
|
VALUE))
|
||||||
@@ -740,7 +735,7 @@ IL:|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FASLOAD.;3|)
|
|||||||
|
|
||||||
(DEFOP FASL-BITMAP16 (158)
|
(DEFOP FASL-BITMAP16 (158)
|
||||||
|
|
||||||
(IL:* IL:|;;;| "Load an Interlisp BITMAP.")
|
(IL:* IL:|;;;| "Load an Interlisp BITMAP.")
|
||||||
|
|
||||||
(LET* ((WIDTH (NEXT-VALUE))
|
(LET* ((WIDTH (NEXT-VALUE))
|
||||||
(HEIGHT (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)
|
(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)
|
(IL:CREATE-STRUCTURE (CONS (NEXT-VALUE)
|
||||||
(NEXT-VALUE))))
|
(NEXT-VALUE))))
|
||||||
|
|
||||||
(XCL:DEFOPTIMIZER FIXUP-NTOFFSET (RAW-CODE OFFSET TYPE VALUE &ENVIRONMENT IL:ENV)
|
(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
|
(COND
|
||||||
((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE IL:ENV)
|
((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE IL:ENV))
|
||||||
)
|
|
||||||
|
|
||||||
(IL:* IL:|;;|
|
(IL:* IL:|;;| "3-byte case; the nametable entry is a full cell.")
|
||||||
"3-byte case; the nametable entry is a full cell.")
|
|
||||||
|
|
||||||
`(PROGN (D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET ,TYPE)
|
`(PROGN (D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET ,TYPE)
|
||||||
(D-ASSEM:FIXUP-WORD ,RAW-CODE (+ ,OFFSET
|
(D-ASSEM:FIXUP-WORD ,RAW-CODE (+ ,OFFSET IL:BYTESPERWORD
|
||||||
IL:BYTESPERWORD)
|
)
|
||||||
,VALUE)))
|
,VALUE)))
|
||||||
(T
|
(T
|
||||||
(IL:* IL:|;;| "Old nametable case, it's just a word.")
|
(IL:* IL:|;;| "Old nametable case, it's just a word.")
|
||||||
|
|
||||||
`(D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET (IL:IPLUS
|
`(D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET (IL:IPLUS ,TYPE
|
||||||
,TYPE
|
,VALUE)))))
|
||||||
,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:DEFINEQ
|
||||||
|
|
||||||
(IL:FASL-FILEDATE
|
(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:\;
|
(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:|;;|
|
(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.")
|
(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)
|
((EQL (IL:BIN STREAM)
|
||||||
SIGNATURE) (IL:* IL:\; " \"Aha, a Dfasl file\"")
|
SIGNATURE) (IL:* IL:\; " \"Aha, a Dfasl file\"")
|
||||||
(IL:SETFILEPTR STREAM 0)
|
(IL:SETFILEPTR STREAM 0)
|
||||||
(IL:SETQ IL:VALUE (CONVERT-FASL-DATE (PROCESS-FILE STREAM :TEXT-FN
|
(CONVERT-FASL-DATE (PROCESS-FILE STREAM :TEXT-FN #'(IL:LAMBDA (IL:X)
|
||||||
#'(IL:LAMBDA (IL:X)
|
(IL:RETFROM 'PROCESS-FILE IL:X))
|
||||||
(IL:RETFROM 'PROCESS-FILE IL:X))
|
:ITEM-FN
|
||||||
:ITEM-FN
|
'IL:NILL)
|
||||||
'IL:NILL)
|
IL:CFLG)))))
|
||||||
IL:CFLG))))))
|
|
||||||
|
|
||||||
(CONVERT-FASL-DATE
|
(CONVERT-FASL-DATE
|
||||||
(IL:LAMBDA (IL:DATESTRING IL:CFLG) (IL:* IL:\; "Edited 17-Apr-2018 07:55 by rmk:")
|
(IL:LAMBDA (IL:DATESTRING IL:CFLG) (IL:* IL:\; "Edited 23-Nov-2021 12:29 by rmk:")
|
||||||
(IL:* IL:\;
|
(IL:* IL:\; "Edited 17-Apr-2018 07:55 by rmk:")
|
||||||
"Edited 23-Jan-89 13:55 by gadener")
|
(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:* IL:|;;| "")
|
||||||
(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:|;;| "(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:* IL:\; "")
|
"END-POS is the end of the line that contains the key substring, last char could be period")
|
||||||
IL:SHORT-DATE-STRING)))
|
|
||||||
|
(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
|
(IL:PUTPROPS IL:FASLOAD IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992
|
||||||
2018 2021))
|
2018 2021))
|
||||||
(IL:DECLARE\: IL:DONTCOPY
|
(IL:DECLARE\: IL:DONTCOPY
|
||||||
(IL:FILEMAP (NIL (6461 6877 (TABLE-STATS 6461 . 6877)) (7039 7318 (MAKE-OPTABLE 7039 . 7318)) (7320
|
(IL:FILEMAP (NIL (6469 6885 (TABLE-STATS 6469 . 6885)) (7047 7326 (MAKE-OPTABLE 7047 . 7326)) (7328
|
||||||
7963 (DEFINE-OPCODE-RANGE 7320 . 7963)) (7965 8515 (DEFINE-SINGLE-OPCODE 7965 . 8515)) (8517 8775 (
|
7975 (DEFINE-OPCODE-RANGE 7328 . 7975)) (7977 8527 (DEFINE-SINGLE-OPCODE 7977 . 8527)) (8529 8787 (
|
||||||
ADD-OP-TRANSLATION 8517 . 8775)) (8777 9141 (OPCODE-SEQUENCE 8777 . 9141)) (10735 10901 (
|
ADD-OP-TRANSLATION 8529 . 8787)) (8789 9149 (OPCODE-SEQUENCE 8789 . 9149)) (10727 10893 (
|
||||||
FASL-END-OF-BLOCK 10735 . 10901)) (10903 11024 (FASL-EXTENDED 10903 . 11024)) (11026 11151 (SETESCAPE
|
FASL-END-OF-BLOCK 10727 . 10893)) (10895 11016 (FASL-EXTENDED 10895 . 11016)) (11018 11143 (SETESCAPE
|
||||||
11026 . 11151)) (11153 11249 (UNIMPLEMENTED-OPCODE 11153 . 11249)) (11610 12960 (PROCESS-FILE 11610 .
|
11018 . 11143)) (11145 11241 (UNIMPLEMENTED-OPCODE 11145 . 11241)) (11602 12942 (PROCESS-FILE 11602 .
|
||||||
12960)) (12962 13192 (PROCESS-SEGMENT 12962 . 13192)) (13297 13609 (CHECK-VERSION 13297 . 13609)) (
|
12942)) (12944 13174 (PROCESS-SEGMENT 12944 . 13174)) (13279 13591 (CHECK-VERSION 13279 . 13591)) (
|
||||||
13611 14272 (READ-TEXT 13611 . 14272)) (14274 14776 (PROCESS-BLOCK 14274 . 14776)) (14778 14917 (
|
13593 14254 (READ-TEXT 13593 . 14254)) (14256 14742 (PROCESS-BLOCK 14256 . 14742)) (14744 14883 (
|
||||||
SKIP-TEXT 14778 . 14917)) (14972 15579 (DO-OP 14972 . 15579)) (15581 15682 (NEW-VALUE-TABLE 15581 .
|
SKIP-TEXT 14744 . 14883)) (14938 15545 (DO-OP 14938 . 15545)) (15547 15648 (NEW-VALUE-TABLE 15547 .
|
||||||
15682)) (15684 15783 (CLEAR-TABLE 15684 . 15783)) (15785 16039 (STORE-VALUE 15785 . 16039)) (16041
|
15648)) (15650 15749 (CLEAR-TABLE 15650 . 15749)) (15751 16006 (STORE-VALUE 15751 . 16006)) (16008
|
||||||
16126 (FETCH-VALUE 16041 . 16126)) (16128 16656 (COLLECT-LIST 16128 . 16656)) (31623 35206 (
|
16093 (FETCH-VALUE 16008 . 16093)) (16095 16623 (COLLECT-LIST 16095 . 16623)) (30975 34345 (
|
||||||
IL:FASL-FILEDATE 31636 . 32797) (CONVERT-FASL-DATE 32799 . 35204)))))
|
IL:FASL-FILEDATE 30988 . 32271) (CONVERT-FASL-DATE 32273 . 34343)))))
|
||||||
IL:STOP
|
IL:STOP
|
||||||
|
|||||||
Binary file not shown.
360
sources/FILEPKG
360
sources/FILEPKG
@@ -1,12 +1,11 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
|
|
||||||
(FILECREATED "10-Oct-2021 20:36:54"
|
(FILECREATED " 8-Nov-2021 10:52:49" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;15 284792
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEPKG.;10 284821
|
|
||||||
|
|
||||||
changes to%: (FNS MAKEFILE)
|
changes to%: (FNS COMPAREDEFS)
|
||||||
|
|
||||||
previous date%: " 8-Oct-2021 23:56:39"
|
previous date%: "30-Oct-2021 20:03:07"
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILEPKG.;9)
|
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>FILEPKG.;14)
|
||||||
|
|
||||||
|
|
||||||
(* ; "
|
(* ; "
|
||||||
@@ -21,7 +20,7 @@ with the terms of said license.
|
|||||||
|
|
||||||
(RPAQQ FILEPKGCOMS
|
(RPAQQ FILEPKGCOMS
|
||||||
[(COMS (* ;
|
[(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)
|
(VARS FILEPKGTYPEPROPS)
|
||||||
(EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
|
(EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
|
||||||
(FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
|
(FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
|
||||||
@@ -87,7 +86,7 @@ with the terms of said license.
|
|||||||
(MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
|
(MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
|
||||||
(ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
|
(ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
|
||||||
[COMS (* ;
|
[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)
|
(FNS SAVEPUT)
|
||||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
|
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
|
||||||
(CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
|
(CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
|
||||||
@@ -95,7 +94,7 @@ with the terms of said license.
|
|||||||
(ADDVARS (LISPXFNS (PUT . SAVEPUT)
|
(ADDVARS (LISPXFNS (PUT . SAVEPUT)
|
||||||
(PUTPROP . SAVEPUT]
|
(PUTPROP . SAVEPUT]
|
||||||
(COMS (* ;
|
(COMS (* ;
|
||||||
"sub-functions for file package commands & types")
|
"sub-functions for file package commands & types")
|
||||||
(FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED
|
(FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED
|
||||||
MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS
|
MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS
|
||||||
PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS
|
PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS
|
||||||
@@ -109,7 +108,7 @@ with the terms of said license.
|
|||||||
LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS
|
LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS
|
||||||
PRETTYPRINTYPEMACROS USERMACROS))
|
PRETTYPRINTYPEMACROS USERMACROS))
|
||||||
(COMS (* ;
|
(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))
|
(USERMACROS M))
|
||||||
(COMS (* ; "GETDEF methods")
|
(COMS (* ; "GETDEF methods")
|
||||||
(FNS RENAME CHANGECALLERS)
|
(FNS RENAME CHANGECALLERS)
|
||||||
@@ -120,7 +119,7 @@ with the terms of said license.
|
|||||||
(* ; "Must come after PUTDEF")
|
(* ; "Must come after PUTDEF")
|
||||||
(FNS FIXEDITDATE EDITDATE?)
|
(FNS FIXEDITDATE EDITDATE?)
|
||||||
(* ;
|
(* ;
|
||||||
"Edit date support for all kinds of definers (from PARC 6/10/92)")
|
"Edit date support for all kinds of definers (from PARC 6/10/92)")
|
||||||
[VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
|
[VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
|
||||||
(EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
|
(EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
|
||||||
(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
|
(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
|
||||||
@@ -211,99 +210,91 @@ with the terms of said license.
|
|||||||
(* ; "standard records for accessing file package type/command parts. Exported for PRETTY")
|
(* ; "standard records for accessing file package type/command parts. Exported for PRETTY")
|
||||||
|
|
||||||
|
|
||||||
(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED
|
(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF
|
||||||
HASDEF EDITDEF CANFILEDEF FILEGETDEF))
|
EDITDEF CANFILEDEF FILEGETDEF))
|
||||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY
|
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||||
|
|
||||||
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
|
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
|
(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
|
||||||
(UNDOABLE (COND
|
(UNDOABLE (COND
|
||||||
(NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
|
(NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
|
||||||
(T (/REMPROP DATUM 'ADDTOPRETTYCOM]
|
(T (/REMPROP DATUM 'ADDTOPRETTYCOM]
|
||||||
[DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
|
[DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
|
||||||
(UNDOABLE (COND
|
(UNDOABLE (COND
|
||||||
(NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
|
(NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
|
||||||
(T (/REMPROP DATUM 'DELFROMPRETTYCOM]
|
(T (/REMPROP DATUM 'DELFROMPRETTYCOM]
|
||||||
[PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
|
[PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
|
||||||
(UNDOABLE (COND
|
(UNDOABLE (COND
|
||||||
(NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
|
(NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
|
||||||
(T (/REMPROP DATUM 'PRETTYTYPE]
|
(T (/REMPROP DATUM 'PRETTYTYPE]
|
||||||
[CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
|
[CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
|
||||||
(UNDOABLE (COND
|
(UNDOABLE (COND
|
||||||
(NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
|
(NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
|
||||||
(T (/REMPROP DATUM 'FILEPKGCONTENTS]
|
(T (/REMPROP DATUM 'FILEPKGCONTENTS]
|
||||||
(MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
|
(MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
|
||||||
(STANDARD [COND
|
(STANDARD [COND
|
||||||
[NEWVALUE (PUTASSOC DATUM NEWVALUE
|
[NEWVALUE (PUTASSOC DATUM NEWVALUE
|
||||||
(OR (LISTP (GETTOPVAL
|
(OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
|
||||||
|
(SETTOPVAL 'PRETTYDEFMACROS
|
||||||
|
(LIST (LIST DATUM]
|
||||||
|
(T (SETTOPVAL 'PRETTYDEFMACROS
|
||||||
|
(REMOVE (FASSOC DATUM (GETTOPVAL
|
||||||
'PRETTYDEFMACROS))
|
'PRETTYDEFMACROS))
|
||||||
(SETTOPVAL 'PRETTYDEFMACROS
|
(GETTOPVAL 'PRETTYDEFMACROS]
|
||||||
(LIST (LIST DATUM]
|
UNDOABLE
|
||||||
(T (SETTOPVAL 'PRETTYDEFMACROS
|
(COND
|
||||||
(REMOVE (FASSOC DATUM (GETTOPVAL
|
[NEWVALUE (/PUTASSOC DATUM NEWVALUE
|
||||||
'PRETTYDEFMACROS))
|
(OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
|
||||||
(GETTOPVAL 'PRETTYDEFMACROS]
|
(/SETTOPVAL 'PRETTYDEFMACROS
|
||||||
UNDOABLE
|
(LIST (LIST DATUM]
|
||||||
(COND
|
(T (/SETTOPVAL 'PRETTYDEFMACROS
|
||||||
[NEWVALUE (/PUTASSOC DATUM NEWVALUE
|
(REMOVE (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS))
|
||||||
(OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
|
(GETTOPVAL 'PRETTYDEFMACROS]
|
||||||
(/SETTOPVAL 'PRETTYDEFMACROS
|
|
||||||
(LIST (LIST DATUM]
|
|
||||||
(T (/SETTOPVAL 'PRETTYDEFMACROS
|
|
||||||
(REMOVE (FASSOC DATUM (GETTOPVAL
|
|
||||||
'PRETTYDEFMACROS))
|
|
||||||
(GETTOPVAL 'PRETTYDEFMACROS]
|
|
||||||
(* Not an atom record cause want
|
(* Not an atom record cause want
|
||||||
REMPROP on NILs.)
|
REMPROP on NILs.)
|
||||||
(* NOTE%: PRETTCOM on PRETTY has
|
(* NOTE%: PRETTCOM on PRETTY has
|
||||||
open-coded access to the MACRO
|
open-coded access to the MACRO
|
||||||
property.)
|
property.)
|
||||||
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
|
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
|
||||||
FILEPKGCONTENTS)))
|
FILEPKGCONTENTS)))
|
||||||
|
|
||||||
(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED
|
(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF
|
||||||
HASDEF EDITDEF FILEGETDEF CANFILEDEF)
|
EDITDEF FILEGETDEF CANFILEDEF)
|
||||||
(ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
|
(ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
|
||||||
(CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
|
(CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE)))
|
||||||
)
|
(CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM))
|
||||||
(CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
|
)
|
||||||
DATUM)))
|
(STANDARD (SETTOPVAL (CAR (SEARCHPRETTYTYPELST
|
||||||
(STANDARD (SETTOPVAL (CAR (
|
DATUM NEWVALUE))
|
||||||
SEARCHPRETTYTYPELST
|
NEWVALUE)
|
||||||
DATUM NEWVALUE)
|
UNDOABLE
|
||||||
)
|
(/SETTOPVAL (CAR (SEARCHPRETTYTYPELST
|
||||||
NEWVALUE)
|
DATUM NEWVALUE))
|
||||||
UNDOABLE
|
NEWVALUE)))
|
||||||
(/SETTOPVAL (CAR (
|
(DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST DATUM)))
|
||||||
SEARCHPRETTYTYPELST
|
(CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST DATUM
|
||||||
DATUM NEWVALUE))
|
NEWVALUE))
|
||||||
NEWVALUE)))
|
NEWVALUE)))
|
||||||
(DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
|
(ALLFIELDS NIL (/SETTOPVAL 'PRETTYTYPELST
|
||||||
DATUM)))
|
(REMOVE (SEARCHPRETTYTYPELST
|
||||||
(CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
|
DATUM)
|
||||||
DATUM NEWVALUE))
|
(GETTOPVAL
|
||||||
NEWVALUE)))
|
'PRETTYTYPELST]
|
||||||
(ALLFIELDS NIL (/SETTOPVAL
|
|
||||||
'PRETTYTYPELST
|
|
||||||
(REMOVE (SEARCHPRETTYTYPELST
|
|
||||||
DATUM)
|
|
||||||
(GETTOPVAL 'PRETTYTYPELST]
|
|
||||||
(* NOTE%: PRETTYCOM on PRETTY has
|
(* NOTE%: PRETTYCOM on PRETTY has
|
||||||
open-coded access to GETDEF property)
|
open-coded access to GETDEF property)
|
||||||
(INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
|
(INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
|
||||||
(MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
|
(MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
|
||||||
(PUT X
|
(PUT X 'PROPTYPE
|
||||||
'PROPTYPE
|
'FILEPKGCOMS]
|
||||||
'FILEPKGCOMS]
|
(ADDTOVAR PRETTYTYPELST ))))
|
||||||
(ADDTOVAR PRETTYTYPELST ))))
|
|
||||||
|
|
||||||
(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
|
(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
|
||||||
[ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
|
[ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
|
||||||
(STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
|
(STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
|
||||||
UNDOABLE
|
UNDOABLE
|
||||||
(/PUTPROP DATUM 'FILE NEWVALUE])
|
(/PUTPROP DATUM 'FILE NEWVALUE])
|
||||||
|
|
||||||
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
|
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
|
||||||
|
|
||||||
@@ -956,12 +947,12 @@ compiling " T)
|
|||||||
(RPAQ? NILCOMS )
|
(RPAQ? NILCOMS )
|
||||||
|
|
||||||
(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF
|
(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF
|
||||||
FORMAT (REC . RC)
|
FORMAT (REC . RC)
|
||||||
(BREC . RC)
|
(BREC . RC)
|
||||||
(TC . C)
|
(TC . C)
|
||||||
(BC . C)
|
(BC . C)
|
||||||
(TCOMPL . C)
|
(TCOMPL . C)
|
||||||
(BCOMPL . C))
|
(BCOMPL . C))
|
||||||
|
|
||||||
(RPAQ? MAKEFILEREMAKEFLG T)
|
(RPAQ? MAKEFILEREMAKEFLG T)
|
||||||
|
|
||||||
@@ -2705,7 +2696,7 @@ compiling " T)
|
|||||||
)
|
)
|
||||||
|
|
||||||
(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
|
(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
|
||||||
(PUTPROP . SAVEPUT))
|
(PUTPROP . SAVEPUT))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -3119,14 +3110,14 @@ compiling " T)
|
|||||||
|
|
||||||
|
|
||||||
(ADDTOVAR USERMACROS
|
(ADDTOVAR USERMACROS
|
||||||
|
(M NIL (MAKE FILE FILE))
|
||||||
(M (X . Y)
|
(M (X . Y)
|
||||||
(E (MARKASCHANGED (COND ((LISTP 'X)
|
(E (MARKASCHANGED (COND ((LISTP 'X)
|
||||||
(CAR 'X))
|
(CAR 'X))
|
||||||
(T 'X))
|
(T 'X))
|
||||||
'USERMACROS)
|
'USERMACROS)
|
||||||
T)
|
T)
|
||||||
(ORIGINAL (M X . Y)))
|
(ORIGINAL (M X . Y))))
|
||||||
(M NIL (MAKE FILE FILE)))
|
|
||||||
|
|
||||||
(ADDTOVAR EDITMACROS
|
(ADDTOVAR EDITMACROS
|
||||||
(M (X . Y)
|
(M (X . Y)
|
||||||
@@ -3272,11 +3263,15 @@ compiling " T)
|
|||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(SHOWDEF
|
(SHOWDEF
|
||||||
[LAMBDA (NAME TYPE FILE) (* ; "Edited 16-Apr-2018 21:35 by rmk:")
|
[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")
|
(* ;
|
||||||
|
"prettyprint NAME as it would be dumped as a TYPE (in the current reader environment)")
|
||||||
(RESETLST
|
(RESETLST
|
||||||
(PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
|
(PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP (SOURCEFILENV (MAKE-READER-ENVIRONMENT
|
||||||
|
|
||||||
|
*DEFAULT-MAKEFILE-ENVIRONMENT*
|
||||||
|
)))
|
||||||
(DECLARE (SPECVARS . T))
|
(DECLARE (SPECVARS . T))
|
||||||
[AND FILE (NEQ FILE (OUTPUT))
|
[AND FILE (NEQ FILE (OUTPUT))
|
||||||
(if (SETQ FL (OPENP FILE 'OUTPUT))
|
(if (SETQ FL (OPENP FILE 'OUTPUT))
|
||||||
@@ -3955,7 +3950,9 @@ compiling " T)
|
|||||||
(RETURN TYPE])
|
(RETURN TYPE])
|
||||||
|
|
||||||
(COMPAREDEFS
|
(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
|
(COND
|
||||||
((AND (LISTP TYPE)
|
((AND (LISTP TYPE)
|
||||||
(GETFILEPKGTYPE SOURCES NIL T))
|
(GETFILEPKGTYPE SOURCES NIL T))
|
||||||
@@ -3969,41 +3966,45 @@ compiling " T)
|
|||||||
(MEMBER NAME (CDR (ASSOC TYPE
|
(MEMBER NAME (CDR (ASSOC TYPE
|
||||||
(fetch TOBEDUMPED
|
(fetch TOBEDUMPED
|
||||||
of (fetch FILEPROP
|
of (fetch FILEPROP
|
||||||
of FILE]
|
of FILE]
|
||||||
(push SRCS 'CURRENT]
|
(push SRCS 'CURRENT]
|
||||||
(SETQ SRCS (for SRC in SRCS
|
(SETQ SRCS (for SRC in SRCS when (COND
|
||||||
when (COND
|
((NEQ [SETQ DEF (GETDEF NAME TYPE SRC
|
||||||
((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
|
'(NOERROR NOCOPY]
|
||||||
(fetch NULLDEF of TYPE))
|
(fetch NULLDEF of TYPE))
|
||||||
(OR [SOME DEFS (FUNCTION (LAMBDA (DP)
|
(OR [SOME DEFS (FUNCTION (LAMBDA (DP)
|
||||||
(COMPARELST DEF (CDR DP]
|
(COMPARELST DEF
|
||||||
(push DEFS (CONS SRC DEF)))
|
(CDR DP]
|
||||||
T)
|
(push DEFS (CONS SRC DEF)))
|
||||||
(T (PRINTOUT T "No " SRC " definition found for " NAME T)
|
T)
|
||||||
NIL)) collect SRC))
|
(T (PRINTOUT T "No " SRC " definition found for " NAME
|
||||||
|
T)
|
||||||
|
NIL)) collect SRC))
|
||||||
(RETURN (COND
|
(RETURN (COND
|
||||||
((NULL SRCS)
|
((NULL SRCS)
|
||||||
'(no definitions found))
|
'(no definitions found))
|
||||||
((NULL (CDR SRCS))
|
((NULL (CDR SRCS))
|
||||||
'(only one definition found))
|
'(only one definition found))
|
||||||
((CDR DEFS)
|
((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)
|
do (for S2 on (CDR S1) do (PRIN2 NAME T T)
|
||||||
(AND (CAAR S1)
|
(AND (CAAR S1)
|
||||||
(PRIN1 " from " T)
|
(PRIN1 " from " T)
|
||||||
(PRIN2 (CAAR S1)
|
(PRIN2 (CAAR S1)
|
||||||
T T))
|
T T))
|
||||||
(PRIN1 " and " T)
|
(TAB (IDIFFERENCE FILECOL (CONSTANT (NCHARS
|
||||||
(PRIN2 NAME T T)
|
" and "
|
||||||
(COND
|
)))
|
||||||
((CAAR S2)
|
NIL T)
|
||||||
(PRIN1 " from " T)
|
(PRIN1 " and " T)
|
||||||
(PRIN2 (CAAR S2)
|
(COND
|
||||||
T T)))
|
((CAAR S2)
|
||||||
(PRIN1 " differ:" T)
|
(PRIN2 (CAAR S2)
|
||||||
(TERPRI T)
|
T T)))
|
||||||
(COMPARELISTS (CDAR S1)
|
(TERPRI T)
|
||||||
(CDAR S2]
|
(COMPARELISTS (CDAR S1)
|
||||||
|
(CDAR S2]
|
||||||
'DIFFERENT)
|
'DIFFERENT)
|
||||||
(T 'SAME])
|
(T 'SAME])
|
||||||
|
|
||||||
@@ -4508,7 +4509,7 @@ compiling " T)
|
|||||||
(P (CONSTANTS . X])
|
(P (CONSTANTS . X])
|
||||||
|
|
||||||
(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
|
(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
|
||||||
(VARIABLES VARS CONSTANTS))
|
(VARIABLES VARS CONSTANTS))
|
||||||
|
|
||||||
(RPAQ? SAVEDDEFS )
|
(RPAQ? SAVEDDEFS )
|
||||||
|
|
||||||
@@ -4971,10 +4972,10 @@ compiling " T)
|
|||||||
)
|
)
|
||||||
|
|
||||||
(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
|
(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
|
||||||
((Y "es")
|
((Y "es")
|
||||||
(N "o")
|
(N "o")
|
||||||
(E . "verything")
|
(E . "verything")
|
||||||
(F "ilemaps only
|
(F "ilemaps only
|
||||||
"))))
|
"))))
|
||||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||||
|
|
||||||
@@ -5031,8 +5032,7 @@ compiling " T)
|
|||||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||||
|
|
||||||
(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS
|
(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS
|
||||||
MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS
|
MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS PRETTYDEFMACROS)
|
||||||
PRETTYDEFMACROS)
|
|
||||||
|
|
||||||
(ADDTOVAR NLAML )
|
(ADDTOVAR NLAML )
|
||||||
|
|
||||||
@@ -5041,46 +5041,46 @@ compiling " T)
|
|||||||
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989
|
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989
|
||||||
1990 1991 1992 1993 1995 2018 2020 2021))
|
1990 1991 1992 1993 1995 2018 2020 2021))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (20618 22323 (SEARCHPRETTYTYPELST 20628 . 21607) (PRETTYDEFMACROS 21609 . 22067) (
|
(FILEMAP (NIL (19760 21465 (SEARCHPRETTYTYPELST 19770 . 20749) (PRETTYDEFMACROS 20751 . 21209) (
|
||||||
FILEPKGCOMPROPS 22069 . 22321)) (23125 57943 (CLEANUP 23135 . 24523) (COMPILEFILES 24525 . 24801) (
|
FILEPKGCOMPROPS 21211 . 21463)) (22267 57085 (CLEANUP 22277 . 23665) (COMPILEFILES 23667 . 23943) (
|
||||||
COMPILEFILES0 24803 . 25523) (CONTINUEDIT 25525 . 26945) (MAKEFILE 26947 . 39284) (FILECHANGES 39286
|
COMPILEFILES0 23945 . 24665) (CONTINUEDIT 24667 . 26087) (MAKEFILE 26089 . 38426) (FILECHANGES 38428
|
||||||
. 41621) (FILEPKG.MERGECHANGES 41623 . 42446) (FILEPKG.CHANGEDFNS 42448 . 42760) (MAKEFILE1 42762 .
|
. 40763) (FILEPKG.MERGECHANGES 40765 . 41588) (FILEPKG.CHANGEDFNS 41590 . 41902) (MAKEFILE1 41904 .
|
||||||
46989) (COMPILE-FILE? 46991 . 48548) (MAKEFILES 48550 . 50243) (ADDFILE 50245 . 52766) (ADDFILE0 52768
|
46131) (COMPILE-FILE? 46133 . 47690) (MAKEFILES 47692 . 49385) (ADDFILE 49387 . 51908) (ADDFILE0 51910
|
||||||
. 56904) (LISTFILES 56906 . 57941)) (58639 93879 (FILEPKGCHANGES 58649 . 59999) (GETFILEPKGTYPE 60001
|
. 56046) (LISTFILES 56048 . 57083)) (57757 92997 (FILEPKGCHANGES 57767 . 59117) (GETFILEPKGTYPE 59119
|
||||||
. 63074) (MARKASCHANGED 63076 . 64713) (FILECOMS 64715 . 65099) (WHEREIS 65101 . 66521) (
|
. 62192) (MARKASCHANGED 62194 . 63831) (FILECOMS 63833 . 64217) (WHEREIS 64219 . 65639) (
|
||||||
SMASHFILECOMS 66523 . 66758) (FILEFNSLST 66760 . 66922) (FILECOMSLST 66924 . 67408) (UPDATEFILES 67410
|
SMASHFILECOMS 65641 . 65876) (FILEFNSLST 65878 . 66040) (FILECOMSLST 66042 . 66526) (UPDATEFILES 66528
|
||||||
. 72710) (INFILECOMS? 72712 . 74615) (INFILECOMTAIL 74617 . 75757) (INFILECOMS 75759 . 75920) (
|
. 71828) (INFILECOMS? 71830 . 73733) (INFILECOMTAIL 73735 . 74875) (INFILECOMS 74877 . 75038) (
|
||||||
INFILECOM 75922 . 86131) (INFILECOMSVALS 86133 . 86460) (INFILECOMSVAL 86462 . 87464) (INFILECOMSPROP
|
INFILECOM 75040 . 85249) (INFILECOMSVALS 85251 . 85578) (INFILECOMSVAL 85580 . 86582) (INFILECOMSPROP
|
||||||
87466 . 88295) (IFCPROPS 88297 . 89558) (IFCEXPRTYPE 89560 . 90071) (IFCPROPSCAN 90073 . 91126) (
|
86584 . 87413) (IFCPROPS 87415 . 88676) (IFCEXPRTYPE 88678 . 89189) (IFCPROPSCAN 89191 . 90244) (
|
||||||
IFCDECLARE 91128 . 92439) (INFILEPAIRS 92441 . 92773) (INFILECOMSMACRO 92775 . 93877)) (93914 125334 (
|
IFCDECLARE 90246 . 91557) (INFILEPAIRS 91559 . 91891) (INFILECOMSMACRO 91893 . 92995)) (93032 124452 (
|
||||||
FILES? 93924 . 96117) (FILES?1 96119 . 96817) (FILES?PRINTLST 96819 . 97601) (ADDTOFILES? 97603 .
|
FILES? 93042 . 95235) (FILES?1 95237 . 95935) (FILES?PRINTLST 95937 . 96719) (ADDTOFILES? 96721 .
|
||||||
108649) (ADDTOFILE 108651 . 109567) (WHATIS 109569 . 111545) (ADDTOCOMS 111547 . 113191) (ADDTOCOM
|
107767) (ADDTOFILE 107769 . 108685) (WHATIS 108687 . 110663) (ADDTOCOMS 110665 . 112309) (ADDTOCOM
|
||||||
113193 . 119740) (ADDTOCOM1 119742 . 120913) (ADDNEWCOM 120915 . 121965) (MAKENEWCOM 121967 . 123810)
|
112311 . 118858) (ADDTOCOM1 118860 . 120031) (ADDNEWCOM 120033 . 121083) (MAKENEWCOM 121085 . 122928)
|
||||||
(DEFAULTMAKENEWCOM 123812 . 125332)) (125404 128221 (MERGEINSERT 125414 . 127757) (MERGEINSERT1 127759
|
(DEFAULTMAKENEWCOM 122930 . 124450)) (124522 127339 (MERGEINSERT 124532 . 126875) (MERGEINSERT1 126877
|
||||||
. 128219)) (128375 129732 (ADDTOFILEKEYLST 128385 . 129730)) (129849 140761 (DELFROMFILES 129859 .
|
. 127337)) (127493 128850 (ADDTOFILEKEYLST 127503 . 128848)) (128967 139879 (DELFROMFILES 128977 .
|
||||||
130709) (DELFROMCOMS 130711 . 132390) (DELFROMCOM 132392 . 138260) (DELFROMCOM1 138262 . 139059) (
|
129827) (DELFROMCOMS 129829 . 131508) (DELFROMCOM 131510 . 137378) (DELFROMCOM1 137380 . 138177) (
|
||||||
REMOVEITEM 139061 . 139935) (MOVETOFILE 139937 . 140759)) (140975 143344 (SAVEPUT 140985 . 143342)) (
|
REMOVEITEM 138179 . 139053) (MOVETOFILE 139055 . 139877)) (140093 142462 (SAVEPUT 140103 . 142460)) (
|
||||||
143469 151793 (UNMARKASCHANGED 143479 . 145187) (PREEDITFN 145189 . 147700) (POSTEDITPROPS 147702 .
|
142587 150911 (UNMARKASCHANGED 142597 . 144305) (PREEDITFN 144307 . 146818) (POSTEDITPROPS 146820 .
|
||||||
150203) (POSTEDITALISTS 150205 . 151791)) (151942 172496 (ALISTS.GETDEF 151952 . 152331) (
|
149321) (POSTEDITALISTS 149323 . 150909)) (151056 171610 (ALISTS.GETDEF 151066 . 151445) (
|
||||||
ALISTS.WHENCHANGED 152333 . 152977) (CLEARCLISPARRAY 152979 . 154153) (EXPRESSIONS.WHENCHANGED 154155
|
ALISTS.WHENCHANGED 151447 . 152091) (CLEARCLISPARRAY 152093 . 153267) (EXPRESSIONS.WHENCHANGED 153269
|
||||||
. 154529) (MAKEALISTCOMS 154531 . 155604) (MAKEFILESCOMS 155606 . 157043) (MAKELISPXMACROSCOMS 157045
|
. 153643) (MAKEALISTCOMS 153645 . 154718) (MAKEFILESCOMS 154720 . 156157) (MAKELISPXMACROSCOMS 156159
|
||||||
. 159063) (MAKEPROPSCOMS 159065 . 159763) (MAKEUSERMACROSCOMS 159765 . 161565) (PROPS.WHENCHANGED
|
. 158177) (MAKEPROPSCOMS 158179 . 158877) (MAKEUSERMACROSCOMS 158879 . 160679) (PROPS.WHENCHANGED
|
||||||
161567 . 162188) (FILEGETDEF.LISPXMACROS 162190 . 163632) (FILEGETDEF.ALISTS 163634 . 164253) (
|
160681 . 161302) (FILEGETDEF.LISPXMACROS 161304 . 162746) (FILEGETDEF.ALISTS 162748 . 163367) (
|
||||||
FILEGETDEF.RECORDS 164255 . 165186) (FILEGETDEF.PROPS 165188 . 165980) (FILEGETDEF.MACROS 165982 .
|
FILEGETDEF.RECORDS 163369 . 164300) (FILEGETDEF.PROPS 164302 . 165094) (FILEGETDEF.MACROS 165096 .
|
||||||
167042) (FILEGETDEF.VARS 167044 . 167460) (FILEGETDEF.FNS 167462 . 168826) (FILEPKGCOMS.PUTDEF 168828
|
166156) (FILEGETDEF.VARS 166158 . 166574) (FILEGETDEF.FNS 166576 . 167940) (FILEPKGCOMS.PUTDEF 167942
|
||||||
. 171268) (FILES.PUTDEF 171270 . 172227) (VARS.PUTDEF 172229 . 172372) (FILES.WHENCHANGED 172374 .
|
. 170382) (FILES.PUTDEF 170384 . 171341) (VARS.PUTDEF 171343 . 171486) (FILES.WHENCHANGED 171488 .
|
||||||
172494)) (174518 181951 (RENAME 174528 . 175929) (CHANGECALLERS 175931 . 181949)) (181952 229900 (
|
171608)) (173632 181065 (RENAME 173642 . 175043) (CHANGECALLERS 175045 . 181063)) (181066 229922 (
|
||||||
SHOWDEF 181962 . 182755) (COPYDEF 182757 . 185231) (GETDEF 185233 . 187509) (GETDEFCOM 187511 . 188477
|
SHOWDEF 181076 . 182269) (COPYDEF 182271 . 184745) (GETDEF 184747 . 187023) (GETDEFCOM 187025 . 187991
|
||||||
) (GETDEFCOM0 188479 . 189825) (GETDEFCURRENT 189827 . 196247) (GETDEFERR 196249 . 197550) (
|
) (GETDEFCOM0 187993 . 189339) (GETDEFCURRENT 189341 . 195761) (GETDEFERR 195763 . 197064) (
|
||||||
GETDEFFROMFILE 197552 . 201832) (GETDEFSAVED 201834 . 202938) (PUTDEF 202940 . 203643) (EDITDEF 203645
|
GETDEFFROMFILE 197066 . 201346) (GETDEFSAVED 201348 . 202452) (PUTDEF 202454 . 203157) (EDITDEF 203159
|
||||||
. 204622) (DEFAULT.EDITDEF 204624 . 207460) (EDITDEF.FILES 207462 . 207663) (LOADDEF 207665 . 207841)
|
. 204136) (DEFAULT.EDITDEF 204138 . 206974) (EDITDEF.FILES 206976 . 207177) (LOADDEF 207179 . 207355)
|
||||||
(DWIMDEF 207843 . 208697) (DELDEF 208699 . 211713) (DELFROMLIST 211715 . 212219) (HASDEF 212221 .
|
(DWIMDEF 207357 . 208211) (DELDEF 208213 . 211227) (DELFROMLIST 211229 . 211733) (HASDEF 211735 .
|
||||||
218543) (GETFILEDEF 218545 . 219067) (SAVEDEF 219069 . 220728) (UNSAVEDEF 220730 . 221626) (
|
218057) (GETFILEDEF 218059 . 218581) (SAVEDEF 218583 . 220242) (UNSAVEDEF 220244 . 221140) (
|
||||||
COMPAREDEFS 221628 . 224930) (COMPARE 224932 . 225636) (TYPESOF 225638 . 229898)) (229967 235010 (
|
COMPAREDEFS 221142 . 224952) (COMPARE 224954 . 225658) (TYPESOF 225660 . 229920)) (229989 235032 (
|
||||||
FIXEDITDATE 229977 . 233480) (EDITDATE? 233482 . 235008)) (235429 244200 (FILEPKGCOM 235439 . 240372)
|
FIXEDITDATE 229999 . 233502) (EDITDATE? 233504 . 235030)) (235451 244222 (FILEPKGCOM 235461 . 240394)
|
||||||
(FILEPKGTYPE 240374 . 244198)) (256237 271169 (FINDCALLERS 256247 . 256762) (EDITCALLERS 256764 .
|
(FILEPKGTYPE 240396 . 244220)) (256255 271187 (FINDCALLERS 256265 . 256780) (EDITCALLERS 256782 .
|
||||||
264674) (EDITFROMFILE 264676 . 270484) (FINDATS 270486 . 270758) (LOOKIN 270760 . 271167)) (271170
|
264692) (EDITFROMFILE 264694 . 270502) (FINDATS 270504 . 270776) (LOOKIN 270778 . 271185)) (271188
|
||||||
272897 (SEPRCASE 271180 . 272895)) (273414 278971 (IMPORTFILE 273424 . 274398) (IMPORTEVAL 274400 .
|
272915 (SEPRCASE 271198 . 272913)) (273432 278989 (IMPORTFILE 273442 . 274416) (IMPORTEVAL 274418 .
|
||||||
275280) (IMPORTFILESCAN 275282 . 275703) (CHECKIMPORTS 275705 . 277041) (GATHEREXPORTS 277043 . 278381
|
275298) (IMPORTFILESCAN 275300 . 275721) (CHECKIMPORTS 275723 . 277059) (GATHEREXPORTS 277061 . 278399
|
||||||
) (\DUMPEXPORTS 278383 . 278969)) (279309 281517 (CLEARFILEPKG 279319 . 281515)))))
|
) (\DUMPEXPORTS 278401 . 278987)) (279327 281535 (CLEARFILEPKG 279337 . 281533)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
|
|
||||||
(FILECREATED "17-Oct-2021 13:52:47"
|
(FILECREATED "17-Oct-2021 16:06:59"
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;15 6457
|
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;17 6482
|
||||||
|
|
||||||
changes to%: (VARS EXPORTFILES)
|
changes to%: (VARS EXPORTFILES)
|
||||||
|
|
||||||
previous date%: "17-Oct-2021 12:43:39"
|
previous date%: "17-Oct-2021 13:52:47"
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>FILESETS.;14)
|
{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
|
(MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR
|
||||||
LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY
|
LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY
|
||||||
ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
|
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))
|
(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
|
||||||
|
|
||||||
|
|||||||
@@ -1,12 +1,11 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(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)
|
(FILECREATED "30-Oct-2021 19:09:48" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>IMAGEIO.;7 80279
|
||||||
(FNS \DISPLAYINIT \4DISPLAYINIT \8DISPLAYINIT \24DISPLAYINIT)
|
|
||||||
|
|
||||||
previous date%: " 2-Aug-2021 19:41:35"
|
changes to%: (FNS \NOIMAGE.DSPFONT)
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;2)
|
|
||||||
|
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])
|
IMDRAWPOINT _ (FUNCTION NILL])
|
||||||
|
|
||||||
(\NOIMAGE.DSPFONT
|
(\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.")
|
(* ;; "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
|
(PROG1 OLDFONT
|
||||||
[AND (NEQ OLDFONT 0)
|
[AND (NEQ OLDFONT 0)
|
||||||
(LET [(FONTN (OR (SMALLP FONT)
|
(LET ([FONTN (OR (SMALLP FONT)
|
||||||
(AND (type? FONTCLASS FONT)
|
(AND (type? FONTCLASS FONT)
|
||||||
(fetch (FONTCLASS PRETTYFONT#) of FONT]
|
(fetch (FONTCLASS PRETTYFONT#) of FONT]
|
||||||
|
CHARPOS)
|
||||||
(COND
|
(COND
|
||||||
((AND FONTN (NEQ FONTN OLDFONT))
|
((AND FONTN (NEQ FONTN OLDFONT))
|
||||||
|
|
||||||
@@ -773,9 +776,11 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
|||||||
|
|
||||||
(COND
|
(COND
|
||||||
((NEQ FONTN 0)
|
((NEQ FONTN 0)
|
||||||
|
(SETQ CHARPOS (FFETCH (STREAM CHARPOSITION) OF STREAM))
|
||||||
(\OUTCHAR STREAM (CONSTANT (CHCON1 FONTESCAPECHAR)))
|
(\OUTCHAR STREAM (CONSTANT (CHCON1 FONTESCAPECHAR)))
|
||||||
(\OUTCHAR STREAM FONTN)))
|
(\OUTCHAR STREAM FONTN)
|
||||||
(freplace IMAGEDATA of STREAM with FONTN])])
|
(FREPLACE (STREAM CHARPOSITION) OF STREAM WITH CHARPOS)))
|
||||||
|
(freplace (STREAM IMAGEDATA) of STREAM with FONTN])])
|
||||||
|
|
||||||
(\UNIMPIMAGEOP
|
(\UNIMPIMAGEOP
|
||||||
[LAMBDA (STREAM OP) (* rmk%: "26-Jun-84 13:28")
|
[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
|
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR)
|
(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR)
|
||||||
BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1)
|
BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1)
|
||||||
)
|
)
|
||||||
|
|
||||||
(* "END EXPORTED DEFINITIONS")
|
(* "END EXPORTED DEFINITIONS")
|
||||||
@@ -922,17 +927,18 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation.
|
|||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS IMAGEOP MACRO [ARGS (CONS 'SPREADAPPLY*
|
(PUTPROPS IMAGEOP MACRO [ARGS (CONS 'SPREADAPPLY* (CONS (COND
|
||||||
(CONS (COND
|
[(EQ (CAR (LISTP (CAR ARGS)))
|
||||||
[(EQ (CAR (LISTP (CAR ARGS)))
|
'QUOTE)
|
||||||
'QUOTE)
|
(LIST 'fetch (LIST 'IMAGEOPS (CADAR
|
||||||
(LIST 'fetch (LIST 'IMAGEOPS (CADAR ARGS))
|
ARGS))
|
||||||
'of
|
|
||||||
(LIST 'fetch '(STREAM IMAGEOPS)
|
|
||||||
'of
|
'of
|
||||||
(CADR ARGS]
|
(LIST 'fetch '(STREAM IMAGEOPS)
|
||||||
(T (HELP "IMAGEOP - OPNAME not quoted:" ARGS)))
|
'of
|
||||||
(CDDR ARGS])
|
(CADR ARGS]
|
||||||
|
(T (HELP "IMAGEOP - OPNAME not quoted:"
|
||||||
|
ARGS)))
|
||||||
|
(CDDR ARGS])
|
||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE
|
(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
|
(PUTPROPS IMAGEIO COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||||
1993 1994 1999 2021))
|
1993 1994 1999 2021))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (3423 12180 (IMAGESTREAMP 3433 . 4265) (IMAGESTREAMTYPE 4267 . 4480) (IMAGESTREAMTYPEP
|
(FILEMAP (NIL (3343 12100 (IMAGESTREAMP 3353 . 4185) (IMAGESTREAMTYPE 4187 . 4400) (IMAGESTREAMTYPEP
|
||||||
4482 . 5117) (OPENIMAGESTREAM 5119 . 10073) (\GOOD.DASHLST 10075 . 12178)) (12215 14512 (
|
4402 . 5037) (OPENIMAGESTREAM 5039 . 9993) (\GOOD.DASHLST 9995 . 12098)) (12135 14432 (DRAWDASHEDLINE
|
||||||
DRAWDASHEDLINE 12225 . 14510)) (14513 21853 (DSPBACKCOLOR 14523 . 14895) (DSPBOTTOMMARGIN 14897 .
|
12145 . 14430)) (14433 21773 (DSPBACKCOLOR 14443 . 14815) (DSPBOTTOMMARGIN 14817 . 15202) (DSPCOLOR
|
||||||
15282) (DSPCOLOR 15284 . 15648) (DSPCLIPPINGREGION 15650 . 16355) (DSPRESET 16357 . 16637) (DSPFONT
|
15204 . 15568) (DSPCLIPPINGREGION 15570 . 16275) (DSPRESET 16277 . 16557) (DSPFONT 16559 . 16923) (
|
||||||
16639 . 17003) (DSPLEFTMARGIN 17005 . 17386) (DSPLINEFEED 17388 . 17688) (DSPOPERATION 17690 . 18067)
|
DSPLEFTMARGIN 16925 . 17306) (DSPLINEFEED 17308 . 17608) (DSPOPERATION 17610 . 17987) (DSPRIGHTMARGIN
|
||||||
(DSPRIGHTMARGIN 18069 . 18452) (DSPTOPMARGIN 18454 . 18833) (DSPSCALE 18835 . 19202) (DSPSPACEFACTOR
|
17989 . 18372) (DSPTOPMARGIN 18374 . 18753) (DSPSCALE 18755 . 19122) (DSPSPACEFACTOR 19124 . 19517) (
|
||||||
19204 . 19597) (DSPXPOSITION 19599 . 19904) (DSPYPOSITION 19906 . 20211) (DSPROTATE 20213 . 20508) (
|
DSPXPOSITION 19519 . 19824) (DSPYPOSITION 19826 . 20131) (DSPROTATE 20133 . 20428) (DSPPUSHSTATE 20430
|
||||||
DSPPUSHSTATE 20510 . 20756) (DSPPOPSTATE 20758 . 21001) (DSPDEFAULTSTATE 21003 . 21255) (DSPSCALE2
|
. 20676) (DSPPOPSTATE 20678 . 20921) (DSPDEFAULTSTATE 20923 . 21175) (DSPSCALE2 21177 . 21468) (
|
||||||
21257 . 21548) (DSPTRANSLATE 21550 . 21851)) (21854 30655 (DSPNEWPAGE 21864 . 22556) (DRAWBETWEEN
|
DSPTRANSLATE 21470 . 21771)) (21774 30575 (DSPNEWPAGE 21784 . 22476) (DRAWBETWEEN 22478 . 23180) (
|
||||||
22558 . 23260) (DRAWCIRCLE 23262 . 23758) (DRAWARC 23760 . 24277) (DRAWCURVE 24279 . 24956) (
|
DRAWCIRCLE 23182 . 23678) (DRAWARC 23680 . 24197) (DRAWCURVE 24199 . 24876) (DRAWELLIPSE 24878 . 25664
|
||||||
DRAWELLIPSE 24958 . 25744) (DRAWLINE 25746 . 26136) (DRAWPOLYGON 26138 . 26593) (DRAWPOINT 26595 .
|
) (DRAWLINE 25666 . 26056) (DRAWPOLYGON 26058 . 26513) (DRAWPOINT 26515 . 26934) (FILLPOLYGON 26936 .
|
||||||
27014) (FILLPOLYGON 27016 . 27582) (DRAWTO 27584 . 28002) (FILLCIRCLE 28004 . 28227) (MOVETO 28229 .
|
27502) (DRAWTO 27504 . 27922) (FILLCIRCLE 27924 . 28147) (MOVETO 28149 . 28513) (RELDRAWTO 28515 .
|
||||||
28593) (RELDRAWTO 28595 . 29512) (BITMAPIMAGESIZE 29514 . 29685) (SCALEDBITBLT 29687 . 30653)) (30656
|
29432) (BITMAPIMAGESIZE 29434 . 29605) (SCALEDBITBLT 29607 . 30573)) (30576 37615 (\DRAWPOINT.GENERIC
|
||||||
37695 (\DRAWPOINT.GENERIC 30666 . 31013) (\DRAWPOLYGON.GENERIC 31015 . 33323) (\DRAWCIRCLE.GENERIC
|
30586 . 30933) (\DRAWPOLYGON.GENERIC 30935 . 33243) (\DRAWCIRCLE.GENERIC 33245 . 34903) (
|
||||||
33325 . 34983) (\DRAWELLIPSE.GENERIC 34985 . 37693)) (37696 43082 (\IMAGEIOINIT 37706 . 41839) (
|
\DRAWELLIPSE.GENERIC 34905 . 37613)) (37616 43413 (\IMAGEIOINIT 37626 . 41759) (\NOIMAGE.DSPFONT 41761
|
||||||
\NOIMAGE.DSPFONT 41841 . 42916) (\UNIMPIMAGEOP 42918 . 43080)) (43205 46329 (INSURE.BRUSH 43215 .
|
. 43247) (\UNIMPIMAGEOP 43249 . 43411)) (43536 46660 (INSURE.BRUSH 43546 . 44920) (BRUSHP 44922 .
|
||||||
44589) (BRUSHP 44591 . 45381) (\POSSIBLECOLOR 45383 . 45934) (NEGSHADE 45936 . 46327)) (46885 47569 (
|
45712) (\POSSIBLECOLOR 45714 . 46265) (NEGSHADE 46267 . 46658)) (47216 47900 (DASHINGP 47226 . 47556)
|
||||||
DASHINGP 46895 . 47225) (INSURE.DASHING 47227 . 47567)) (58050 78596 (\DisplayEventFn 58060 . 58570) (
|
(INSURE.DASHING 47558 . 47898)) (58546 79092 (\DisplayEventFn 58556 . 59066) (\DISPLAYINIT 59068 .
|
||||||
\DISPLAYINIT 58572 . 64155) (\4DISPLAYINIT 64157 . 68858) (\8DISPLAYINIT 68860 . 73563) (
|
64651) (\4DISPLAYINIT 64653 . 69354) (\8DISPLAYINIT 69356 . 74059) (\24DISPLAYINIT 74061 . 78833) (
|
||||||
\24DISPLAYINIT 73565 . 78337) (\DISPLAYSTREAMTYPEBPP 78339 . 78594)))))
|
\DISPLAYSTREAMTYPEBPP 78835 . 79090)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
|
|
||||||
(FILECREATED "24-Oct-2021 23:57:27"
|
(FILECREATED "26-Oct-2021 10:07:31"
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;3 90360
|
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;5 90395
|
||||||
|
|
||||||
changes to%: (VARS IOCHARCOMS)
|
changes to%: (VARS IOCHARCOMS)
|
||||||
|
|
||||||
previous date%: "24-Oct-2021 23:53:23"
|
previous date%: "24-Oct-2021 23:57:27"
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;2)
|
{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)
|
\OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
|
||||||
(OPTIMIZERS DATEFORMAT)
|
(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)
|
(INITVARS (\TimeZoneComp 8)
|
||||||
(\BeginDST 74)
|
(\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? \TimeZoneComp 8)
|
||||||
|
|
||||||
(RPAQ? \BeginDST 74)
|
(RPAQ? \BeginDST 74)
|
||||||
@@ -1374,15 +1383,15 @@ DONTCOPY
|
|||||||
(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||||
1991 2018 2020))
|
1991 2018 2020))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (3448 7242 (CHCON 3458 . 4308) (UNPACK 4310 . 5204) (DCHCON 5206 . 6473) (DUNPACK 6475
|
(FILEMAP (NIL (3484 7278 (CHCON 3494 . 4344) (UNPACK 4346 . 5240) (DCHCON 5242 . 6509) (DUNPACK 6511
|
||||||
. 7240)) (7243 18758 (UALPHORDER 7253 . 7349) (ALPHORDER 7351 . 9154) (CONCAT 9156 . 9801) (
|
. 7276)) (7279 18794 (UALPHORDER 7289 . 7385) (ALPHORDER 7387 . 9190) (CONCAT 9192 . 9837) (
|
||||||
CONCATCODES 9803 . 9989) (PACKC 9991 . 12594) (PACK 12596 . 13175) (PACK* 13177 . 14899) (\PACK.ITEM
|
CONCATCODES 9839 . 10025) (PACKC 10027 . 12630) (PACK 12632 . 13211) (PACK* 13213 . 14935) (\PACK.ITEM
|
||||||
14901 . 15356) (STRPOS 15358 . 18756)) (18760 19049 (XCL:PACK 18760 . 19049)) (19051 19301 (XCL:PACK*
|
14937 . 15392) (STRPOS 15394 . 18792)) (18796 19085 (XCL:PACK 18796 . 19085)) (19087 19337 (XCL:PACK*
|
||||||
19051 . 19301)) (20019 22410 (STRPOSL 20029 . 21655) (MAKEBITTABLE 21657 . 22408)) (22572 23049 (
|
19087 . 19337)) (20055 22446 (STRPOSL 20065 . 21691) (MAKEBITTABLE 21693 . 22444)) (22608 23085 (
|
||||||
CASEARRAY 22582 . 22772) (UPPERCASEARRAY 22774 . 23047)) (23371 46973 (FILEPOS 23381 . 33293) (
|
CASEARRAY 22618 . 22808) (UPPERCASEARRAY 22810 . 23083)) (23407 47009 (FILEPOS 23417 . 33329) (
|
||||||
FFILEPOS 33295 . 44408) (\SETUP.FFILEPOS 44410 . 46971)) (47761 89008 (DATE 47771 . 47857) (DATEFORMAT
|
FFILEPOS 33331 . 44444) (\SETUP.FFILEPOS 44446 . 47007)) (47797 89044 (DATE 47807 . 47893) (DATEFORMAT
|
||||||
47859 . 47951) (GDATE 47953 . 48064) (IDATE 48066 . 59737) (\IDATESCANTOKEN 59739 . 61018) (
|
47895 . 47987) (GDATE 47989 . 48100) (IDATE 48102 . 59773) (\IDATESCANTOKEN 59775 . 61054) (
|
||||||
\IDATE-PARSE-MONTH 61020 . 64716) (\OUTDATE 64718 . 77466) (\OUTDATE-STRING 77468 . 78083) (\RPLRIGHT
|
\IDATE-PARSE-MONTH 61056 . 64752) (\OUTDATE 64754 . 77502) (\OUTDATE-STRING 77504 . 78119) (\RPLRIGHT
|
||||||
78085 . 78323) (\UNPACKDATE 78325 . 84116) (\PACKDATE 84118 . 87438) (\DTSCAN 87440 . 87582) (\ISDST?
|
78121 . 78359) (\UNPACKDATE 78361 . 84152) (\PACKDATE 84154 . 87474) (\DTSCAN 87476 . 87618) (\ISDST?
|
||||||
87584 . 88091) (\CHECKDSTCHANGE 88093 . 89006)))))
|
87620 . 88127) (\CHECKDSTCHANGE 88129 . 89042)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
406
sources/LLBASIC
406
sources/LLBASIC
@@ -1,19 +1,19 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED "31-Jan-98 09:55:50" {DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>LLBASIC.;13 118684
|
|
||||||
|
|
||||||
changes to%: (RECORDS PNAMEINDEX)
|
(FILECREATED "27-Oct-2021 21:23:51" {DSK}<home>larry>medley>sources>LLBASIC.;2 120519
|
||||||
|
|
||||||
previous date%: "31-Jan-98 09:30:10"
|
changes to%: (FNS \SETGLOBALVAL.UFN \CREATE.SYMBOL)
|
||||||
{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>LLBASIC.;12)
|
|
||||||
|
previous date%: "31-Jan-98 09:55:50" {DSK}<home>larry>medley>sources>LLBASIC.;1)
|
||||||
|
|
||||||
|
|
||||||
(* ; "
|
(* ; "
|
||||||
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994, 1995, 1998 by Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved.
|
Copyright (c) 1981-1988, 1990-1995, 1998 by Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets.
|
||||||
")
|
")
|
||||||
|
|
||||||
(PRETTYCOMPRINT LLBASICCOMS)
|
(PRETTYCOMPRINT LLBASICCOMS)
|
||||||
|
|
||||||
(RPAQQ LLBASICCOMS
|
(RPAQQ LLBASICCOMS
|
||||||
((FNS LISTP LITATOM FIXP SMALLP NLISTP ARRAYP FLOATP NUMBERP STACKP)
|
((FNS LISTP LITATOM FIXP SMALLP NLISTP ARRAYP FLOATP NUMBERP STACKP)
|
||||||
(FUNCTIONS ATOM)
|
(FUNCTIONS ATOM)
|
||||||
(DECLARE%: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 IPLUS16 SMALLPOSP SETXVAR
|
(DECLARE%: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 IPLUS16 SMALLPOSP SETXVAR
|
||||||
@@ -207,56 +207,59 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS CHECK MACRO (ARGS (COND
|
(PUTPROPS CHECK MACRO [ARGS (COND
|
||||||
[(AND (BOUNDP 'CHECK)
|
[(AND (BOUNDP 'CHECK)
|
||||||
CHECK)
|
CHECK)
|
||||||
(CONS 'PROGN (for I in ARGS
|
(CONS 'PROGN
|
||||||
collect (LIST 'OR I
|
(for I in ARGS
|
||||||
(LIST 'RAID
|
collect (LIST 'OR I
|
||||||
(KWOTE (LIST
|
(LIST 'RAID
|
||||||
'Check-failure%:
|
(KWOTE (LIST
|
||||||
I]
|
'
|
||||||
(T (CONS COMMENTFLG ARGS]
|
Check-failure%:
|
||||||
|
I]
|
||||||
|
(T (CONS COMMENTFLG ARGS])
|
||||||
|
|
||||||
(PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N)
|
(PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N)
|
||||||
(\PUTBASE N 0 0)
|
(\PUTBASE N 0 0)
|
||||||
(\PUTBASE N 1 0)))
|
(\PUTBASE N 1 0)))
|
||||||
|
|
||||||
[PUTPROPS \StatsAdd1 DMACRO (OPENLAMBDA (A)
|
(PUTPROPS \StatsAdd1 DMACRO [OPENLAMBDA (A)
|
||||||
(PROG ((LO (IPLUS16 (\GETBASE A 1)
|
(PROG ((LO (IPLUS16 (\GETBASE A 1)
|
||||||
1)))
|
1)))
|
||||||
(DECLARE (LOCALVARS LO))
|
(DECLARE (LOCALVARS LO))
|
||||||
(* ; "Increment double word at A by 1")
|
(* ; "Increment double word at A by 1")
|
||||||
(\PUTBASE A 1 LO)
|
(\PUTBASE A 1 LO)
|
||||||
(COND
|
(COND
|
||||||
((EQ LO 0)
|
((EQ LO 0)
|
||||||
(\PUTBASE A 0 (ADD1 (\GETBASE A 0]
|
(\PUTBASE A 0 (ADD1 (\GETBASE A 0])
|
||||||
|
|
||||||
[PUTPROPS IPLUS16 MACRO ((X Y) (* ; "Kludge to do 16-bit plus")
|
(PUTPROPS IPLUS16 MACRO ((X Y) (* ; "Kludge to do 16-bit plus")
|
||||||
(\LOLOC (\ADDBASE X Y]
|
(\LOLOC (\ADDBASE X Y))))
|
||||||
|
|
||||||
[PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X)
|
(PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X)
|
||||||
(AND (SMALLP X)
|
(AND (SMALLP X)
|
||||||
(IGEQ X 0]
|
(IGEQ X 0))))
|
||||||
|
|
||||||
[PROGN [PUTPROPS SETXVAR MACRO (X `(SETQ.NOREF %, (CADAR X)
|
[PROGN (PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X)
|
||||||
%,
|
%,
|
||||||
(CADR X]
|
(CADR X])
|
||||||
(PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X)
|
(PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X)
|
||||||
'QUOTE)
|
'QUOTE)
|
||||||
(LITATOM (CADAR X)))
|
(LITATOM (CADAR X)))
|
||||||
(SHOULDNT))
|
(SHOULDNT))
|
||||||
(GLOBALVARS \VALSPACE)
|
(GLOBALVARS \VALSPACE)
|
||||||
(LIST 'SETQ.NOREF (CADAR X)
|
(LIST 'SETQ.NOREF (CADAR X)
|
||||||
(CADR X]
|
(CADR X))))]
|
||||||
|
|
||||||
(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL)
|
(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL)
|
||||||
(\PUTBASEPTR (LOCF (fetch (LITATOM VALUE) of 'VAR))
|
(\PUTBASEPTR (LOCF (fetch (LITATOM VALUE)
|
||||||
0 VAL)))
|
of 'VAR))
|
||||||
|
0 VAL)))
|
||||||
|
|
||||||
(PROGN (PUTPROPS IEQ MACRO ((X Y)
|
(PROGN (PUTPROPS IEQ MACRO ((X Y)
|
||||||
(IEQP X Y)))
|
(IEQP X Y)))
|
||||||
(PUTPROPS IEQ DMACRO (= . EQ)))
|
(PUTPROPS IEQ DMACRO (= . EQ)))
|
||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
@@ -318,8 +321,12 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(replace (LITATOM VALUE) of ATM with VAL])
|
(replace (LITATOM VALUE) of ATM with VAL])
|
||||||
|
|
||||||
(\SETGLOBALVAL.UFN
|
(\SETGLOBALVAL.UFN
|
||||||
[LAMBDA (V A) (* bvm%: " 6-Jun-85 11:54")
|
[LAMBDA (V A) (* ;
|
||||||
(replace (VALINDEX VALUE) of A with V])
|
"Edited 27-Oct-2021 21:18 by larry")
|
||||||
|
(* ;
|
||||||
|
"Edited 27-Oct-2021 21:13 by larry")
|
||||||
|
(* bvm%: " 6-Jun-85 11:54")
|
||||||
|
(replace (VCELL VALUE) of (\VALCELL A) with V])
|
||||||
|
|
||||||
(\SETFVAR.UFN
|
(\SETFVAR.UFN
|
||||||
[LAMBDA (V VCELL) (* edited%: " 3-Apr-85 16:40")
|
[LAMBDA (V VCELL) (* edited%: " 3-Apr-85 16:40")
|
||||||
@@ -370,8 +377,8 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS \PROPCELL MACRO ((ATOM)
|
(PUTPROPS \PROPCELL MACRO ((ATOM)
|
||||||
(\ATOMCELL ATOM (CONSTANT \PLIST.HI]
|
(\ATOMCELL ATOM (CONSTANT \PLIST.HI))))
|
||||||
)
|
)
|
||||||
|
|
||||||
(DEFOPTIMIZER \ATOMCELL (&REST X)
|
(DEFOPTIMIZER \ATOMCELL (&REST X)
|
||||||
@@ -492,7 +499,11 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
NEWATOM))])
|
NEWATOM))])
|
||||||
|
|
||||||
(\CREATE.SYMBOL
|
(\CREATE.SYMBOL
|
||||||
[LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (* ; "Edited 8-Feb-93 16:48 by jds")
|
[LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (* ;
|
||||||
|
"Edited 27-Oct-2021 21:21 by larry")
|
||||||
|
(* ;
|
||||||
|
"Edited 27-Oct-2021 21:13 by larry")
|
||||||
|
(* ; "Edited 8-Feb-93 16:48 by jds")
|
||||||
|
|
||||||
(* ;;; "Creates a new symbol whose pname is as indicated. FATP means the presented string is fat, while FATCHARSEENP means that there actually is a fat char in there (otherwise we will store a thin pname) --- Must be called UNINTERRUPTABLY and the caller is responsible for interning the symbol wherever it belongs")
|
(* ;;; "Creates a new symbol whose pname is as indicated. FATP means the presented string is fat, while FATCHARSEENP means that there actually is a fat char in there (otherwise we will store a thin pname) --- Must be called UNINTERRUPTABLY and the caller is responsible for interning the symbol wherever it belongs")
|
||||||
|
|
||||||
@@ -522,7 +533,7 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(* ;; "Now, just create us a NEW-ATOM, and keep going:")
|
(* ;; "Now, just create us a NEW-ATOM, and keep going:")
|
||||||
|
|
||||||
(SETQ ATM (CREATECELL \NEW-ATOM))
|
(SETQ ATM (CREATECELL \NEW-ATOM))
|
||||||
(REPLACE (VALINDEX VALUE) OF ATM WITH 'NOBIND))
|
(replace (VCELL VALUE) of (\VALCELL ATM) with 'NOBIND))
|
||||||
((EVENP ATM 256) (* ;
|
((EVENP ATM 256) (* ;
|
||||||
"Can fit 256 new atoms into 10 pages.")
|
"Can fit 256 new atoms into 10 pages.")
|
||||||
|
|
||||||
@@ -764,17 +775,18 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS MDSTYPE# MACRO ((PAGE#)
|
(PUTPROPS MDSTYPE# MACRO ((PAGE#)
|
||||||
(LOGAND (\GETBASE \MDSTypeTable (LRSH PAGE# 1))
|
(LOGAND (\GETBASE \MDSTypeTable (LRSH PAGE# 1))
|
||||||
\TT.TYPEMASK)))
|
\TT.TYPEMASK)))
|
||||||
|
|
||||||
[PUTPROPS .ALLOCATED.PER.PAGE. MACRO (OPENLAMBDA (SIZE) (* Maybe change this some day to a
|
(PUTPROPS .ALLOCATED.PER.PAGE. MACRO (OPENLAMBDA (SIZE)
|
||||||
|
(* Maybe change this some day to a
|
||||||
fetch of a flag from the DTD)
|
fetch of a flag from the DTD)
|
||||||
(AND (IGEQ (LISPVERSION)
|
(AND (IGEQ (LISPVERSION)
|
||||||
37384)
|
37384)
|
||||||
(ILESSP (IREMAINDER WORDSPERPAGE SIZE)
|
(ILESSP (IREMAINDER WORDSPERPAGE SIZE)
|
||||||
(LRSH SIZE 1))
|
(LRSH SIZE 1))
|
||||||
(ILESSP SIZE WORDSPERPAGE]
|
(ILESSP SIZE WORDSPERPAGE))))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
@@ -790,7 +802,7 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
|
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS READSYS.HAS.PACKAGES MACRO (NIL (NEQ 1 READSYS.PACKAGE.FROM.NAME)))
|
(PUTPROPS READSYS.HAS.PACKAGES MACRO (NIL (NEQ 1 READSYS.PACKAGE.FROM.NAME)))
|
||||||
)
|
)
|
||||||
|
|
||||||
(RPAQQ READSYS.PACKAGE.FROM.NAME 1)
|
(RPAQQ READSYS.PACKAGE.FROM.NAME 1)
|
||||||
@@ -1715,91 +1727,91 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS \DEFCELL MACRO ((ATOM)
|
(PUTPROPS \DEFCELL MACRO ((ATOM)
|
||||||
(\ATOMCELL ATOM \DEF.HI)))
|
(\ATOMCELL ATOM \DEF.HI)))
|
||||||
|
|
||||||
(PUTPROPS \VALCELL MACRO ((ATOM)
|
(PUTPROPS \VALCELL MACRO ((ATOM)
|
||||||
(\ATOMCELL ATOM \VAL.HI)))
|
(\ATOMCELL ATOM \VAL.HI)))
|
||||||
|
|
||||||
(PUTPROPS \PNAMECELL MACRO ((ATOM)
|
(PUTPROPS \PNAMECELL MACRO ((ATOM)
|
||||||
(\ATOMCELL ATOM \PNAME.HI)))
|
(\ATOMCELL ATOM \PNAME.HI)))
|
||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS \ATOMVALINDEX DMACRO (OPENLAMBDA (X)
|
(PUTPROPS \ATOMVALINDEX DMACRO [OPENLAMBDA (X)
|
||||||
(COND
|
(COND
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\LITATOM) (* ; "Original litatoms")
|
\LITATOM) (* ; "Original litatoms")
|
||||||
(\LOLOC X))
|
(\LOLOC X))
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\NEW-ATOM) (* ; "new 3-byte symbols")
|
\NEW-ATOM) (* ; "new 3-byte symbols")
|
||||||
X)
|
X)
|
||||||
(T (SHOULDNT]
|
(T (SHOULDNT])
|
||||||
|
|
||||||
[PUTPROPS \ATOMDEFINDEX DMACRO (OPENLAMBDA (X)
|
(PUTPROPS \ATOMDEFINDEX DMACRO [OPENLAMBDA (X)
|
||||||
(COND
|
(COND
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\LITATOM) (* ; "Original litatoms")
|
\LITATOM) (* ; "Original litatoms")
|
||||||
(\LOLOC X))
|
(\LOLOC X))
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\NEW-ATOM) (* ; "new 3-byte symbols")
|
\NEW-ATOM) (* ; "new 3-byte symbols")
|
||||||
X)
|
X)
|
||||||
(T (SHOULDNT]
|
(T (SHOULDNT])
|
||||||
|
|
||||||
[PUTPROPS \ATOMPNAMEINDEX DMACRO (OPENLAMBDA (X)
|
(PUTPROPS \ATOMPNAMEINDEX DMACRO [OPENLAMBDA (X)
|
||||||
(COND
|
(COND
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\LITATOM) (* ; "Original litatoms")
|
\LITATOM) (* ; "Original litatoms")
|
||||||
(\LOLOC X))
|
(\LOLOC X))
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\NEW-ATOM) (* ; "new 3-byte symbols")
|
\NEW-ATOM)(* ; "new 3-byte symbols")
|
||||||
X)
|
X)
|
||||||
(T (SHOULDNT]
|
(T (SHOULDNT])
|
||||||
|
|
||||||
[PUTPROPS \ATOMPROPINDEX DMACRO ((X)
|
(PUTPROPS \ATOMPROPINDEX DMACRO [(X)
|
||||||
(COND
|
(COND
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\LITATOM) (* ; "Original litatoms")
|
\LITATOM) (* ; "Original litatoms")
|
||||||
(\LOLOC X))
|
(\LOLOC X))
|
||||||
((EQ (NTYPX X)
|
((EQ (NTYPX X)
|
||||||
\NEW-ATOM) (* ; "new 3-byte symbols")
|
\NEW-ATOM) (* ; "new 3-byte symbols")
|
||||||
X)
|
X)
|
||||||
(T (SHOULDNT]
|
(T (SHOULDNT])
|
||||||
|
|
||||||
[PUTPROPS \INDEXATOMPNAME DMACRO (OPENLAMBDA (X)
|
(PUTPROPS \INDEXATOMPNAME DMACRO (OPENLAMBDA (X)
|
||||||
(COND
|
(COND
|
||||||
[(FIXP X) (* ; "Xerox Lisp traditional symbol")
|
[(FIXP X) (* ; "Xerox Lisp traditional symbol")
|
||||||
(COND
|
(COND
|
||||||
((SMALLP X)
|
((SMALLP X)
|
||||||
(\VAG2 \AtomHI X))
|
(\VAG2 \AtomHI X))
|
||||||
(T (\VAG2 (LRSH X 16)
|
(T (\VAG2 (LRSH X 16)
|
||||||
(LOGAND X 65535]
|
(LOGAND X 65535]
|
||||||
(T (* ; "New symbol")
|
(T (* ; "New symbol")
|
||||||
X]
|
X))))
|
||||||
|
|
||||||
[PUTPROPS \INDEXATOMVAL DMACRO (OPENLAMBDA (X)
|
(PUTPROPS \INDEXATOMVAL DMACRO (OPENLAMBDA (X)
|
||||||
(COND
|
(COND
|
||||||
[(FIXP X) (* ; "Xerox Lisp traditional symbol")
|
[(FIXP X) (* ; "Xerox Lisp traditional symbol")
|
||||||
(COND
|
(COND
|
||||||
((SMALLP X)
|
((SMALLP X)
|
||||||
(\VAG2 \AtomHI X))
|
(\VAG2 \AtomHI X))
|
||||||
(T (\VAG2 (LRSH X 16)
|
(T (\VAG2 (LRSH X 16)
|
||||||
(LOGAND X 65535]
|
(LOGAND X 65535]
|
||||||
(T (* ; "New symbol")
|
(T (* ; "New symbol")
|
||||||
X]
|
X))))
|
||||||
|
|
||||||
[PUTPROPS \INDEXATOMDEF DMACRO (OPENLAMBDA (X)
|
(PUTPROPS \INDEXATOMDEF DMACRO (OPENLAMBDA (X)
|
||||||
(COND
|
(COND
|
||||||
[(FIXP X) (* ; "Xerox Lisp traditional symbol")
|
[(FIXP X) (* ; "Xerox Lisp traditional symbol")
|
||||||
(COND
|
(COND
|
||||||
((SMALLP X)
|
((SMALLP X)
|
||||||
(\VAG2 \AtomHI X))
|
(\VAG2 \AtomHI X))
|
||||||
(T (\VAG2 (LRSH X 16)
|
(T (\VAG2 (LRSH X 16)
|
||||||
(LOGAND X 65535]
|
(LOGAND X 65535]
|
||||||
(T (* ; "New symbol")
|
(T (* ; "New symbol")
|
||||||
X]
|
X))))
|
||||||
|
|
||||||
(PUTPROPS \ATOMNUMBER DMACRO (= . \LOLOC))
|
(PUTPROPS \ATOMNUMBER DMACRO (= . \LOLOC))
|
||||||
)
|
)
|
||||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||||
|
|
||||||
@@ -1842,35 +1854,36 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS COMPUTE.ATOM.HASH MACRO ((BASE OFFST LEN FIRSTBYTE FATP)
|
(PUTPROPS COMPUTE.ATOM.HASH MACRO [(BASE OFFST LEN FIRSTBYTE FATP)
|
||||||
(* ;
|
(* ;
|
||||||
"Sets variable HASH to atom hash of indicated string")
|
"Sets variable HASH to atom hash of indicated string")
|
||||||
(SETQ HASH (LLSH FIRSTBYTE 8))
|
(SETQ HASH (LLSH FIRSTBYTE 8))
|
||||||
(for CHAR# from (ADD1 OFFST)
|
(for CHAR# from (ADD1 OFFST)
|
||||||
to (SUB1 (IPLUS OFFST LEN))
|
to (SUB1 (IPLUS OFFST LEN))
|
||||||
do (SETQ HASH
|
do (SETQ HASH
|
||||||
(IPLUS16 (IPLUS16 (SETQ HASH
|
(IPLUS16 (IPLUS16 (SETQ HASH
|
||||||
(IPLUS16 HASH
|
(IPLUS16 HASH
|
||||||
(LLSH (LOGAND HASH 4095)
|
(LLSH (LOGAND HASH
|
||||||
2)))
|
4095)
|
||||||
(LLSH (LOGAND HASH 255)
|
2)))
|
||||||
8))
|
(LLSH (LOGAND HASH 255)
|
||||||
(UNLESSRDSYS (COND
|
8))
|
||||||
(FATP (LOGAND (\GETBASEFAT
|
(UNLESSRDSYS
|
||||||
BASE CHAR#)
|
(COND
|
||||||
255))
|
(FATP (LOGAND (\GETBASEFAT BASE
|
||||||
(T (\GETBASETHIN BASE CHAR#)))
|
CHAR#)
|
||||||
(NTHCHARCODE BASE CHAR#]
|
255))
|
||||||
|
(T (\GETBASETHIN BASE CHAR#)))
|
||||||
|
(NTHCHARCODE BASE CHAR#])
|
||||||
|
|
||||||
[PUTPROPS ATOM.HASH.REPROBE MACRO ((HASH FIRSTBYTE)
|
(PUTPROPS ATOM.HASH.REPROBE MACRO [(HASH FIRSTBYTE)
|
||||||
(LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH]
|
(LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH])
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
(ADDTOVAR DONTCOMPILEFNS
|
(ADDTOVAR DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM READATOM MAKE.LOCAL.ATOM SYMBOL.VALUE
|
||||||
INITATOMS COPYATOM UNCOPYATOM READATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME
|
SYMBOL.PNAME SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL
|
||||||
SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME
|
FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME GETDEFN PUTDEFN FSETVAL)
|
||||||
GETDEFN PUTDEFN FSETVAL)
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
@@ -2079,17 +2092,17 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS .CLEARNWORDS. MACRO (OPENLAMBDA (BASE NWORDS)
|
(PUTPROPS .CLEARNWORDS. MACRO (OPENLAMBDA (BASE NWORDS)
|
||||||
|
|
||||||
(* ;; "Clear NWORDS words starting at base. Assumes NWORDS is smallp and greater than zero. Compiler refuses to optimize out an IGREATERP test here, so push back to caller")
|
(* ;; "Clear NWORDS words starting at base. Assumes NWORDS is smallp and greater than zero. Compiler refuses to optimize out an IGREATERP test here, so push back to caller")
|
||||||
|
|
||||||
(\PUTBASE BASE (SUB1 NWORDS)
|
(\PUTBASE BASE (SUB1 NWORDS)
|
||||||
0)
|
0)
|
||||||
[COND
|
[COND
|
||||||
((NEQ NWORDS 1)
|
((NEQ NWORDS 1)
|
||||||
(\BLT BASE (\ADDBASE BASE 1)
|
(\BLT BASE (\ADDBASE BASE 1)
|
||||||
(SUB1 NWORDS]
|
(SUB1 NWORDS]
|
||||||
NIL))
|
NIL))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -2100,10 +2113,10 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
|
(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
|
||||||
(\BLT (\ADDBASE DBASE DOFFSET)
|
(\BLT (\ADDBASE DBASE DOFFSET)
|
||||||
(\ADDBASE SBASE SOFFSET)
|
(\ADDBASE SBASE SOFFSET)
|
||||||
NWORDS)))
|
NWORDS)))
|
||||||
)
|
)
|
||||||
|
|
||||||
(* "END EXPORTED DEFINITIONS")
|
(* "END EXPORTED DEFINITIONS")
|
||||||
@@ -2181,39 +2194,38 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992,
|
|||||||
(\ATOMNUMBER . VATOMNUMBER)
|
(\ATOMNUMBER . VATOMNUMBER)
|
||||||
(\CREATE.SYMBOL . VNOSUCHATOM))
|
(\CREATE.SYMBOL . VNOSUCHATOM))
|
||||||
|
|
||||||
(ADDTOVAR RDCOMS
|
(ADDTOVAR RDCOMS (FNS UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME SYMBOL.PACKAGE
|
||||||
(FNS UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME SYMBOL.PACKAGE OLD.FIND.SYMBOL
|
OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME \MKATOM
|
||||||
LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME \MKATOM GETTOPVAL GETPROPLIST
|
GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \ATOMCELL)
|
||||||
SETTOPVAL GETDEFN \ATOMCELL)
|
(FNS LISTP)
|
||||||
(FNS LISTP)
|
(VARS (COPYATOMSTR)))
|
||||||
(VARS (COPYATOMSTR)))
|
|
||||||
|
|
||||||
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
|
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
|
||||||
|
|
||||||
(ADDTOVAR RDVALS (\AtomFrLst))
|
(ADDTOVAR RDVALS (\AtomFrLst))
|
||||||
)
|
)
|
||||||
|
|
||||||
(PUTPROPS LLBASIC FILETYPE CL:COMPILE-FILE)
|
(PUTPROPS LLBASIC FILETYPE CL:COMPILE-FILE)
|
||||||
(PUTPROPS LLBASIC COPYRIGHT (
|
(PUTPROPS LLBASIC COPYRIGHT (
|
||||||
"Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets"
|
"Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets"
|
||||||
1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993 1994 1995 1998))
|
1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993 1994 1995 1998))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (9820 12218 (LISTP 9830 . 10413) (LITATOM 10415 . 10682) (FIXP 10684 . 10921) (SMALLP
|
(FILEMAP (NIL (9717 12115 (LISTP 9727 . 10310) (LITATOM 10312 . 10579) (FIXP 10581 . 10818) (SMALLP
|
||||||
10923 . 11178) (NLISTP 11180 . 11393) (ARRAYP 11395 . 11650) (FLOATP 11652 . 11907) (NUMBERP 11909 .
|
10820 . 11075) (NLISTP 11077 . 11290) (ARRAYP 11292 . 11547) (FLOATP 11549 . 11804) (NUMBERP 11806 .
|
||||||
12055) (STACKP 12057 . 12216)) (15995 19501 (GETTOPVAL 16005 . 16161) (SETTOPVAL 16163 . 16532) (
|
11952) (STACKP 11954 . 12113)) (16335 20191 (GETTOPVAL 16345 . 16501) (SETTOPVAL 16503 . 16872) (
|
||||||
FSETVAL 16534 . 16881) (\SETGLOBALVAL.UFN 16883 . 17054) (\SETFVAR.UFN 17056 . 17226) (GETPROPLIST
|
FSETVAL 16874 . 17221) (\SETGLOBALVAL.UFN 17223 . 17744) (\SETFVAR.UFN 17746 . 17916) (GETPROPLIST
|
||||||
17228 . 17388) (\ATOMCELL 17390 . 19319) (SETPROPLIST 19321 . 19499)) (20325 34368 (\MKATOM 20335 .
|
17918 . 18078) (\ATOMCELL 18080 . 20009) (SETPROPLIST 20011 . 20189)) (21034 35427 (\MKATOM 21044 .
|
||||||
27567) (\CREATE.SYMBOL 27569 . 31866) (\MKATOM.FULL 31868 . 32345) (\INITATOMPAGE 32347 . 34366)) (
|
28276) (\CREATE.SYMBOL 28278 . 32925) (\MKATOM.FULL 32927 . 33404) (\INITATOMPAGE 33406 . 35425)) (
|
||||||
34369 43358 (MAPATOMS 34379 . 37686) (ATOMHASH#PROBES 37688 . 42551) (\SFLHASHLOOKUP 42553 . 43356)) (
|
35428 44417 (MAPATOMS 35438 . 38745) (ATOMHASH#PROBES 38747 . 43610) (\SFLHASHLOOKUP 43612 . 44415)) (
|
||||||
45385 74528 (INITATOMS 45395 . 47439) (COPYATOM 47441 . 51860) (UNCOPYATOM 51862 . 52659) (
|
46558 75701 (INITATOMS 46568 . 48612) (COPYATOM 48614 . 53033) (UNCOPYATOM 53035 . 53832) (
|
||||||
MAKE.LOCAL.ATOM 52661 . 53408) (SYMBOL.VALUE 53410 . 54190) (SYMBOL.PNAME 54192 . 55353) (
|
MAKE.LOCAL.ATOM 53834 . 54581) (SYMBOL.VALUE 54583 . 55363) (SYMBOL.PNAME 55365 . 56526) (
|
||||||
SYMBOL.PACKAGE 55355 . 56469) (OLD.FIND.SYMBOL 56471 . 63826) (LOOKUP-SYMBOL 63828 . 67022) (
|
SYMBOL.PACKAGE 56528 . 57642) (OLD.FIND.SYMBOL 57644 . 64999) (LOOKUP-SYMBOL 65001 . 68195) (
|
||||||
FIND.PACKAGE 67024 . 69226) (FIND.SYMBOL 69228 . 74357) (PACKAGE.NAME 74359 . 74526)) (74802 81505 (
|
FIND.PACKAGE 68197 . 70399) (FIND.SYMBOL 70401 . 75530) (PACKAGE.NAME 75532 . 75699)) (75975 82678 (
|
||||||
\DEFINEDP 74812 . 75015) (PUTD 75017 . 75815) (\PUTD 75817 . 78533) (GETD 78535 . 79167) (PUTDEFN
|
\DEFINEDP 75985 . 76188) (PUTD 76190 . 76988) (\PUTD 76990 . 79706) (GETD 79708 . 80340) (PUTDEFN
|
||||||
79169 . 81347) (GETDEFN 81349 . 81503)) (81506 85926 (\STKMIN 81516 . 85924)) (104646 107529 (
|
80342 . 82520) (GETDEFN 82522 . 82676)) (82679 87099 (\STKMIN 82689 . 87097)) (106399 109282 (
|
||||||
\RESETSYSTEMSTATE 104656 . 104813) (INITIALEVALQT 104815 . 106420) (SIMPLEPRINT 106422 . 107527)) (
|
\RESETSYSTEMSTATE 106409 . 106566) (INITIALEVALQT 106568 . 108173) (SIMPLEPRINT 108175 . 109280)) (
|
||||||
107624 108423 (PAGEFAULTS 107634 . 107828) (\SETTOTALTIME 107830 . 108247) (\SERIALNUMBER 108249 .
|
109377 110176 (PAGEFAULTS 109387 . 109581) (\SETTOTALTIME 109583 . 110000) (\SERIALNUMBER 110002 .
|
||||||
108421)) (108487 113398 (\BLT 108497 . 109395) (\MOVEBYTES 109397 . 110841) (\CLEARWORDS 110843 .
|
110174)) (110240 115151 (\BLT 110250 . 111148) (\MOVEBYTES 111150 . 112594) (\CLEARWORDS 112596 .
|
||||||
111537) (\CLEARBYTES 111539 . 112343) (\CLEARCELLS 112345 . 113396)) (114545 115996 (\MOVEWORDS 114555
|
113290) (\CLEARBYTES 113292 . 114096) (\CLEARCELLS 114098 . 115149)) (116344 117795 (\MOVEWORDS 116354
|
||||||
. 114758) (\ZEROBYTES 114760 . 114932) (\ZEROWORDS 114934 . 115994)))))
|
. 116557) (\ZEROBYTES 116559 . 116731) (\ZEROWORDS 116733 . 117793)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
293
sources/LLINTERP
293
sources/LLINTERP
@@ -1,13 +1,14 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED " 2-Feb-95 17:31:23" {DSK}<lispcore>sources>LLINTERP.;3 120814
|
|
||||||
|
|
||||||
changes to%: (VARS LLINTERPCOMS)
|
(FILECREATED "27-Oct-2021 21:03:21" {DSK}<home>larry>medley>sources>LLINTERP.;2 127414
|
||||||
|
|
||||||
previous date%: "31-Aug-94 14:38:32" {DSK}<lispcore>sources>LLINTERP.;2)
|
changes to%: (FNS \STKSCAN)
|
||||||
|
|
||||||
|
previous date%: " 2-Feb-95 17:31:23" {DSK}<home>larry>medley>sources>LLINTERP.;1)
|
||||||
|
|
||||||
|
|
||||||
(* ; "
|
(* ; "
|
||||||
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994, 1995 by Venue & Xerox Corporation. All rights reserved.
|
Copyright (c) 1981-1988, 1990-1992, 1994-1995 by Venue & Xerox Corporation.
|
||||||
The following program was created in 1981 but has not been published
|
The following program was created in 1981 but has not been published
|
||||||
within the meaning of the copyright law, is furnished under license,
|
within the meaning of the copyright law, is furnished under license,
|
||||||
and may not be used, copied and/or disclosed except in accordance
|
and may not be used, copied and/or disclosed except in accordance
|
||||||
@@ -16,7 +17,7 @@ with the terms of said license.
|
|||||||
|
|
||||||
(PRETTYCOMPRINT LLINTERPCOMS)
|
(PRETTYCOMPRINT LLINTERPCOMS)
|
||||||
|
|
||||||
(RPAQQ LLINTERPCOMS
|
(RPAQQ LLINTERPCOMS
|
||||||
[(COMS (* ; "Compilation pre-requisites")
|
[(COMS (* ; "Compilation pre-requisites")
|
||||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||||
LLBASIC LLSTK LLCODE LLPARAMS ACODE)))
|
LLBASIC LLSTK LLCODE LLPARAMS ACODE)))
|
||||||
@@ -368,35 +369,36 @@ with the terms of said license.
|
|||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS .APPLY. MACRO ((U V) (* body for APPLY, used by RETAPPLY
|
(PUTPROPS .APPLY. MACRO [(U V) (* body for APPLY, used by RETAPPLY
|
||||||
too)
|
too)
|
||||||
(PROG ((DEF U))
|
(PROG ((DEF U))
|
||||||
LP [COND
|
LP [COND
|
||||||
((LITATOM DEF)
|
((LITATOM DEF)
|
||||||
(COND
|
(COND
|
||||||
((NOT (fetch (LITATOM CCODEP) of DEF))
|
((NOT (fetch (LITATOM CCODEP) of DEF))
|
||||||
(* EXPR)
|
(* EXPR)
|
||||||
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
|
(SETQ DEF (fetch (LITATOM DEFPOINTER) of
|
||||||
((EQ (fetch (LITATOM ARGTYPE) of DEF)
|
DEF)))
|
||||||
3)
|
((EQ (fetch (LITATOM ARGTYPE) of DEF)
|
||||||
(GO NLSTAR))
|
3)
|
||||||
(T (GO NORMAL]
|
(GO NLSTAR))
|
||||||
[COND
|
(T (GO NORMAL]
|
||||||
((LISTP DEF)
|
[COND
|
||||||
(SELECTQ (CAR DEF)
|
((LISTP DEF)
|
||||||
(NLAMBDA (AND (NLISTP (CADR DEF))
|
(SELECTQ (CAR DEF)
|
||||||
(CADR DEF)
|
(NLAMBDA (AND (NLISTP (CADR DEF))
|
||||||
(GO NLSTAR)))
|
(CADR DEF)
|
||||||
(FUNARG (SETQ DEF (CADR DEF))
|
(GO NLSTAR)))
|
||||||
(GO LP))
|
(FUNARG (SETQ DEF (CADR DEF))
|
||||||
NIL))
|
(GO LP))
|
||||||
((NULL DEF)
|
NIL))
|
||||||
(RETURN (FAULTAPPLY U V]
|
((NULL DEF)
|
||||||
NORMAL
|
(RETURN (FAULTAPPLY U V]
|
||||||
(RETURN (SPREADAPPLY U V))
|
NORMAL
|
||||||
NLSTAR
|
(RETURN (SPREADAPPLY U V))
|
||||||
|
NLSTAR
|
||||||
(* NLAMBDA*)
|
(* NLAMBDA*)
|
||||||
(RETURN (SPREADAPPLY* U V]
|
(RETURN (SPREADAPPLY* U V])
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -444,7 +446,9 @@ with the terms of said license.
|
|||||||
(GO LP])])
|
(GO LP])])
|
||||||
|
|
||||||
(\STKSCAN
|
(\STKSCAN
|
||||||
[LAMBDA (VAR) (* ; "Edited 27-Jan-91 14:48 by jds")
|
[LAMBDA (VAR) (* ;
|
||||||
|
"Edited 27-Oct-2021 20:51 by larry")
|
||||||
|
(* ; "Edited 27-Jan-91 14:48 by jds")
|
||||||
|
|
||||||
(* ;; "Returns pointer to place where VAR is bound")
|
(* ;; "Returns pointer to place where VAR is bound")
|
||||||
|
|
||||||
@@ -455,7 +459,7 @@ with the terms of said license.
|
|||||||
[COND
|
[COND
|
||||||
((fetch (FX INVALIDP) of FX) (* ;
|
((fetch (FX INVALIDP) of FX) (* ;
|
||||||
"Reached top of stack without finding a binding")
|
"Reached top of stack without finding a binding")
|
||||||
(RETURN (fetch (VALINDEX VCELL) of ATOM#]
|
(RETURN (\VALCELL VAR]
|
||||||
(SETQ NT (fetch (FX NAMETABLE) of FX))
|
(SETQ NT (fetch (FX NAMETABLE) of FX))
|
||||||
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT))
|
(SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT))
|
||||||
(SETQ NT (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)))
|
(SETQ NT (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)))
|
||||||
@@ -1216,9 +1220,8 @@ with the terms of said license.
|
|||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
(RPAQ? OPENFNS
|
(RPAQ? OPENFNS '(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG ERSETQ NLSETQ
|
||||||
'(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG ERSETQ NLSETQ RESETFORM RESETLST
|
RESETFORM RESETLST RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ))
|
||||||
RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ))
|
|
||||||
|
|
||||||
(RPAQQ \BLIPNAMES (*TAIL* *FORM* *FN* *ARGVALS*))
|
(RPAQQ \BLIPNAMES (*TAIL* *FORM* *FN* *ARGVALS*))
|
||||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||||
@@ -1433,7 +1436,7 @@ with the terms of said license.
|
|||||||
)
|
)
|
||||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||||
|
|
||||||
(RPAQQ RAIDCOMS
|
(RPAQQ RAIDCOMS
|
||||||
((MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
|
((MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
|
||||||
(ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
|
(ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
|
||||||
READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY
|
READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY
|
||||||
@@ -1445,29 +1448,30 @@ with the terms of said license.
|
|||||||
NOSUCHATOM))))
|
NOSUCHATOM))))
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS PSTKFLD MACRO ((FLD STR TEST FMT STR2)
|
(PUTPROPS PSTKFLD MACRO [(FLD STR TEST FMT STR2)
|
||||||
(PROG ((FLD (fetch (FX FLD) of FRAME)))
|
(PROG ((FLD (fetch (FX FLD) of FRAME)))
|
||||||
(DECLARE (LOCALVARS FLD))
|
(DECLARE (LOCALVARS FLD))
|
||||||
(COND
|
(COND
|
||||||
(TEST (PRIN1 'STR)
|
(TEST (PRIN1 'STR)
|
||||||
(SELECTQ (CONSTANT (NTHCHAR 'STR -1))
|
(SELECTQ (CONSTANT (NTHCHAR 'STR -1))
|
||||||
(= (printout NIL %, FLD STR2))
|
(= (printout NIL %, FLD STR2))
|
||||||
NIL)
|
NIL)
|
||||||
T]
|
T])
|
||||||
|
|
||||||
[PUTPROPS PRINTSTKFIELDS MACRO (FIELDS (CONS 'PROGN (MAPCAR FIELDS (FUNCTION (LAMBDA (X)
|
(PUTPROPS PRINTSTKFIELDS MACRO [FIELDS (CONS 'PROGN (MAPCAR FIELDS (FUNCTION (LAMBDA (X)
|
||||||
(CONS 'PSTKFLD X]
|
(CONS
|
||||||
|
'PSTKFLD X])
|
||||||
|
|
||||||
(PUTPROPS PSTK MACRO ((N . FIELDS)
|
(PUTPROPS PSTK MACRO ((N . FIELDS)
|
||||||
(\PRINTSTK (IPLUS FRAME N))
|
(\PRINTSTK (IPLUS FRAME N))
|
||||||
(PRINTSTKFIELDS . FIELDS)
|
(PRINTSTKFIELDS . FIELDS)
|
||||||
(TERPRI)))
|
(TERPRI)))
|
||||||
|
|
||||||
[PUTPROPS PRINTVA MACRO (LAMBDA (X)
|
(PUTPROPS PRINTVA MACRO [LAMBDA (X)
|
||||||
(printout NIL "{" (HILOC X)
|
(printout NIL "{" (HILOC X)
|
||||||
","
|
","
|
||||||
(LOLOC X)
|
(LOLOC X)
|
||||||
"}"]
|
"}"])
|
||||||
)
|
)
|
||||||
|
|
||||||
(ADDTOVAR RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
|
(ADDTOVAR RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA
|
||||||
@@ -1628,29 +1632,29 @@ with the terms of said license.
|
|||||||
(* ; "Translation machinery for new LAMBDA words")
|
(* ; "Translation machinery for new LAMBDA words")
|
||||||
|
|
||||||
|
|
||||||
(PUTPROPS LAMBDATRANFNS VARTYPE ALIST)
|
(PUTPROPS LAMBDATRANFNS VARTYPE ALIST)
|
||||||
|
|
||||||
(ADDTOVAR LAMBDATRANFNS )
|
(ADDTOVAR LAMBDATRANFNS )
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(DECLARE%: EVAL@COMPILE
|
(DECLARE%: EVAL@COMPILE
|
||||||
|
|
||||||
[PUTPROPS \CCODENARGS MACRO ((FNH)
|
(PUTPROPS \CCODENARGS MACRO ((FNH)
|
||||||
([LAMBDA (N)
|
([LAMBDA (N)
|
||||||
(COND
|
(COND
|
||||||
((ILESSP N 0)
|
((ILESSP N 0)
|
||||||
1)
|
1)
|
||||||
(T N]
|
(T N]
|
||||||
(fetch (FNHEADER NA) of FNH]
|
(fetch (FNHEADER NA) of FNH))))
|
||||||
|
|
||||||
[PUTPROPS \CCODEFNTYP MACRO ((FNH)
|
(PUTPROPS \CCODEFNTYP MACRO ((FNH)
|
||||||
(SELECTQ (\CCODEARGTYPE FNH)
|
(SELECTQ (\CCODEARGTYPE FNH)
|
||||||
(0 'CEXPR)
|
(0 'CEXPR)
|
||||||
(1 'CFEXPR)
|
(1 'CFEXPR)
|
||||||
(2 'CEXPR*)
|
(2 'CEXPR*)
|
||||||
'CFEXPR*]
|
'CFEXPR*)))
|
||||||
|
|
||||||
(PUTPROPS \CCODEARGTYPE MACRO ((FNH)
|
(PUTPROPS \CCODEARGTYPE MACRO ((FNH)
|
||||||
(fetch (FNHEADER ARGTYPE) of FNH)))
|
(fetch (FNHEADER ARGTYPE) of FNH)))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
@@ -1714,9 +1718,8 @@ with the terms of said license.
|
|||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
(ADDTOVAR CONSTANTFOLDFNS
|
(ADDTOVAR CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT IMIN
|
||||||
PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT IMIN IMAX IABS LLSH LRSH
|
IMAX IABS LLSH LRSH LOGOR LOGXOR LOGAND OR AND)
|
||||||
LOGOR LOGXOR LOGAND OR AND)
|
|
||||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||||
|
|
||||||
(GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS)
|
(GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS)
|
||||||
@@ -1743,33 +1746,119 @@ with the terms of said license.
|
|||||||
|
|
||||||
(ADDTOVAR LAMA APPLY* \INTERPRETER)
|
(ADDTOVAR LAMA APPLY* \INTERPRETER)
|
||||||
)
|
)
|
||||||
|
(PRETTYCOMPRINT LLINTERPCOMS)
|
||||||
|
|
||||||
|
(RPAQQ LLINTERPCOMS
|
||||||
|
[(COMS (* ; "Compilation pre-requisites")
|
||||||
|
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||||
|
LLBASIC LLSTK LLCODE LLPARAMS ACODE)))
|
||||||
|
[E (* ;
|
||||||
|
"Don't fontify these common functions")
|
||||||
|
(SETQ FNSLST
|
||||||
|
(LDIFFERENCE FNSLST
|
||||||
|
'(EVALV PROG SET SETQ RETURN GO QUOTE AND OR PROGN COND PROG1 FUNCTION EVAL
|
||||||
|
APPLY]
|
||||||
|
(COMS (* ;
|
||||||
|
"For calling interpreted functions")
|
||||||
|
(FNS \INTERPRETER \INTERPRETER1 \SETUP-COMPILED-CLOSURE-CALL \STKNAME))
|
||||||
|
(COMS (* ; "EVCALL ufn.")
|
||||||
|
(FNS \ENVCALL.UFN \SETUP-ENVIRONMENT-CALL))
|
||||||
|
(COMS (* ; "recursive interpreter")
|
||||||
|
(FNS EVAL \EVAL \EVALFORM \EVALFORMASLAMBDA \EVALOTHER APPLY APPLY* \CHECKAPPLY*
|
||||||
|
\CKAPPLYARGS DEFEVAL)
|
||||||
|
(DECLARE%: DONTCOPY (MACROS .APPLY.))
|
||||||
|
(COMS (* ; "Free variable manipulation")
|
||||||
|
(FNS EVALV \EVALV1 \EVALVAR BOUNDP SET \SETVAR SETQ \STKSCAN \SETFVARSLOT))
|
||||||
|
(COMS (* ; "PROG and friends")
|
||||||
|
(FNS PROG \PROG0 \EVPROG1 RETURN GO EVALA \EVALA ERRORSET
|
||||||
|
SI::ERRORSET-PRINT-FUNCTION))
|
||||||
|
(COMS (* ;
|
||||||
|
"LET and friends -- need these in the init")
|
||||||
|
(FNS LET LET* \LET0 \LET*))
|
||||||
|
(FNS QUOTE AND OR PROGN COND \EVPROGN PROG1)
|
||||||
|
(COMS (VARS (\DEFEVALFNS NIL)
|
||||||
|
(\EVALHOOK))
|
||||||
|
(SPECVARS *EVALHOOK*)
|
||||||
|
(ADDVARS (LAMBDASPLST LAMBDA NLAMBDA CL:LAMBDA OPENLAMBDA))
|
||||||
|
(GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY)
|
||||||
|
(DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (CLISPARRAY))
|
||||||
|
(P (MOVD? 'SETQ 'SETN NIL T)))
|
||||||
|
(GLOBALVARS CLISPARRAY))
|
||||||
|
[COMS (* ;
|
||||||
|
"Evaluating in different stack environment")
|
||||||
|
(FNS ENVEVAL ENVAPPLY FUNCTION \FUNCT1 \MAKEFUNARGFRAME STKEVAL STKAPPLY RETEVAL
|
||||||
|
RETAPPLY)
|
||||||
|
(DECLARE%: DONTEVAL@LOAD DOCOPY (* ;
|
||||||
|
"For bootstrapping, IL:FUNCTION is as good as CL:FUNCTION")
|
||||||
|
(P (MOVD? 'FUNCTION 'CL:FUNCTION NIL T]
|
||||||
|
(COMS (* ; "Blip and other stack funniness")
|
||||||
|
(FNS BLIPVAL SETBLIPVAL BLIPSCAN)
|
||||||
|
(FNS \REALFRAMEP)
|
||||||
|
[INITVARS (OPENFNS '(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG
|
||||||
|
ERSETQ NLSETQ RESETFORM RESETLST RESETVARS RPTQ
|
||||||
|
SAVESETQ SETN UNDONLSETQ XNLSETQ]
|
||||||
|
(VARS \BLIPNAMES)
|
||||||
|
(GLOBALVARS BRKINFOLST)
|
||||||
|
(GLOBALVARS \BLIPNAMES OPENFNS)))
|
||||||
|
(COMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA
|
||||||
|
READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM)
|
||||||
|
(FNS BACKTRACE \BACKTRACE \SCANFORNTENTRY \PRINTSTK \PRINTFRAME \PRINTBF)
|
||||||
|
(DECLARE%: EVAL@COMPILE DONTCOPY (COMS * RAIDCOMS)))
|
||||||
|
(COMS (FNS CCODEP EXPRP SUBRP FNTYP ARGTYPE NARGS ARGLIST \CCODEARGLIST \CCODEIVARSCAN)
|
||||||
|
(COMS (* ;
|
||||||
|
"Translation machinery for new LAMBDA words")
|
||||||
|
(PROP VARTYPE LAMBDATRANFNS)
|
||||||
|
(ALISTS (LAMBDATRANFNS)))
|
||||||
|
(DECLARE%: DONTCOPY (MACROS \CCODENARGS \CCODEFNTYP \CCODEARGTYPE)))
|
||||||
|
(COMS (* ; "CONSTANTS mechanism")
|
||||||
|
(FNS CONSTANTS CONSTANTEXPRESSIONP)
|
||||||
|
(INITVARS (COMPVARMACROHASH (HASHARRAY 100)))
|
||||||
|
(* ; "We need this initialized for the INIT, so don't put it off. (It used to start out NIL and get set later)")
|
||||||
|
(ADDVARS (CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT
|
||||||
|
IQUOTIENT IMIN IMAX IABS LLSH LRSH LOGOR LOGXOR LOGAND OR AND))
|
||||||
|
(GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS))
|
||||||
|
(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))
|
||||||
|
(SPECVARS *TAIL* *FN* *FORM* *ARGVAL*)
|
||||||
|
(DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (LAMS FAULTEVAL FAULTAPPLY)))
|
||||||
|
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||||
|
(ADDVARS (NLAMA CONSTANTS PROG1 COND PROGN OR AND QUOTE LET* LET GO PROG SETQ)
|
||||||
|
(NLAML FUNCTION RETURN)
|
||||||
|
(LAMA BOUNDP APPLY* \INTERPRETER])
|
||||||
|
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||||
|
|
||||||
|
(ADDTOVAR NLAMA CONSTANTS PROG1 COND PROGN OR AND QUOTE LET* LET GO PROG SETQ)
|
||||||
|
|
||||||
|
(ADDTOVAR NLAML FUNCTION RETURN)
|
||||||
|
|
||||||
|
(ADDTOVAR LAMA BOUNDP APPLY* \INTERPRETER)
|
||||||
|
)
|
||||||
(PUTPROPS LLINTERP COPYRIGHT ("Venue & Xerox Corporation" T 1981 1982 1983 1984 1985 1986 1987 1988
|
(PUTPROPS LLINTERP COPYRIGHT ("Venue & Xerox Corporation" T 1981 1982 1983 1984 1985 1986 1987 1988
|
||||||
1990 1991 1992 1994 1995))
|
1990 1991 1992 1994 1995))
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (6448 23709 (\INTERPRETER 6458 . 11054) (\INTERPRETER1 11056 . 17624) (
|
(FILEMAP (NIL (6396 23657 (\INTERPRETER 6406 . 11002) (\INTERPRETER1 11004 . 17572) (
|
||||||
\SETUP-COMPILED-CLOSURE-CALL 17626 . 22773) (\STKNAME 22775 . 23707)) (23738 29150 (\ENVCALL.UFN 23748
|
\SETUP-COMPILED-CLOSURE-CALL 17574 . 22721) (\STKNAME 22723 . 23655)) (23686 29098 (\ENVCALL.UFN 23696
|
||||||
. 23880) (\SETUP-ENVIRONMENT-CALL 23882 . 29148)) (29189 34066 (EVAL 29199 . 29299) (\EVAL 29301 .
|
. 23828) (\SETUP-ENVIRONMENT-CALL 23830 . 29096)) (29137 34014 (EVAL 29147 . 29247) (\EVAL 29249 .
|
||||||
29511) (\EVALFORM 29513 . 30744) (\EVALFORMASLAMBDA 30746 . 30936) (\EVALOTHER 30938 . 31145) (APPLY
|
29459) (\EVALFORM 29461 . 30692) (\EVALFORMASLAMBDA 30694 . 30884) (\EVALOTHER 30886 . 31093) (APPLY
|
||||||
31147 . 31254) (APPLY* 31256 . 32371) (\CHECKAPPLY* 32373 . 33478) (\CKAPPLYARGS 33480 . 33823) (
|
31095 . 31202) (APPLY* 31204 . 32319) (\CHECKAPPLY* 32321 . 33426) (\CKAPPLYARGS 33428 . 33771) (
|
||||||
DEFEVAL 33825 . 34064)) (35868 43313 (EVALV 35878 . 36087) (\EVALV1 36089 . 36244) (\EVALVAR 36246 .
|
DEFEVAL 33773 . 34012)) (36106 43695 (EVALV 36116 . 36325) (\EVALV1 36327 . 36482) (\EVALVAR 36484 .
|
||||||
36609) (BOUNDP 36611 . 36827) (SET 36829 . 37195) (\SETVAR 37197 . 37567) (SETQ 37569 . 38241) (
|
36847) (BOUNDP 36849 . 37065) (SET 37067 . 37433) (\SETVAR 37435 . 37805) (SETQ 37807 . 38479) (
|
||||||
\STKSCAN 38243 . 41763) (\SETFVARSLOT 41765 . 43311)) (43347 56354 (PROG 43357 . 45873) (\PROG0 45875
|
\STKSCAN 38481 . 42145) (\SETFVARSLOT 42147 . 43693)) (43729 56736 (PROG 43739 . 46255) (\PROG0 46257
|
||||||
. 49505) (\EVPROG1 49507 . 49710) (RETURN 49712 . 50253) (GO 50255 . 51070) (EVALA 51072 . 53001) (
|
. 49887) (\EVPROG1 49889 . 50092) (RETURN 50094 . 50635) (GO 50637 . 51452) (EVALA 51454 . 53383) (
|
||||||
\EVALA 53003 . 55596) (ERRORSET 55598 . 56203) (SI::ERRORSET-PRINT-FUNCTION 56205 . 56352)) (56413
|
\EVALA 53385 . 55978) (ERRORSET 55980 . 56585) (SI::ERRORSET-PRINT-FUNCTION 56587 . 56734)) (56795
|
||||||
69065 (LET 56423 . 58566) (LET* 58568 . 60716) (\LET0 60718 . 64378) (\LET* 64380 . 69063)) (69066
|
69447 (LET 56805 . 58948) (LET* 58950 . 61098) (\LET0 61100 . 64760) (\LET* 64762 . 69445)) (69448
|
||||||
70642 (QUOTE 69076 . 69107) (AND 69109 . 69317) (OR 69319 . 69567) (PROGN 69569 . 69848) (COND 69850
|
71024 (QUOTE 69458 . 69489) (AND 69491 . 69699) (OR 69701 . 69949) (PROGN 69951 . 70230) (COND 70232
|
||||||
. 70184) (\EVPROGN 70186 . 70399) (PROG1 70401 . 70640)) (71130 78021 (ENVEVAL 71140 . 71390) (
|
. 70566) (\EVPROGN 70568 . 70781) (PROG1 70783 . 71022)) (71512 78403 (ENVEVAL 71522 . 71772) (
|
||||||
ENVAPPLY 71392 . 71649) (FUNCTION 71651 . 71881) (\FUNCT1 71883 . 74332) (\MAKEFUNARGFRAME 74334 .
|
ENVAPPLY 71774 . 72031) (FUNCTION 72033 . 72263) (\FUNCT1 72265 . 74714) (\MAKEFUNARGFRAME 74716 .
|
||||||
76531) (STKEVAL 76533 . 76681) (STKAPPLY 76683 . 76852) (RETEVAL 76854 . 77458) (RETAPPLY 77460 .
|
76913) (STKEVAL 76915 . 77063) (STKAPPLY 77065 . 77234) (RETEVAL 77236 . 77840) (RETAPPLY 77842 .
|
||||||
78019)) (78142 85650 (BLIPVAL 78152 . 82053) (SETBLIPVAL 82055 . 84797) (BLIPSCAN 84799 . 85648)) (
|
78401)) (78524 86032 (BLIPVAL 78534 . 82435) (SETBLIPVAL 82437 . 85179) (BLIPSCAN 85181 . 86030)) (
|
||||||
85651 86346 (\REALFRAMEP 85661 . 86344)) (86722 96117 (RAIDCOMMAND 86732 . 90338) (RAIDSHOWFRAME 90340
|
86033 86728 (\REALFRAMEP 86043 . 86726)) (87109 96504 (RAIDCOMMAND 87119 . 90725) (RAIDSHOWFRAME 90727
|
||||||
. 90723) (RAIDSTACKCMD 90725 . 91906) (RAIDROOTFRAME 91908 . 92170) (PRINTADDRS 92172 . 92698) (
|
. 91110) (RAIDSTACKCMD 91112 . 92293) (RAIDROOTFRAME 92295 . 92557) (PRINTADDRS 92559 . 93085) (
|
||||||
PRINTVA 92700 . 92845) (READVA 92847 . 92925) (READATOM 92927 . 93509) (READOCT 93511 . 94142) (
|
PRINTVA 93087 . 93232) (READVA 93234 . 93312) (READATOM 93314 . 93896) (READOCT 93898 . 94529) (
|
||||||
SHOWSTACKBLOCKS 94144 . 95390) (SHOWSTACKBLOCK1 95392 . 95543) (PRINCOPY 95545 . 95677) (NOSUCHATOM
|
SHOWSTACKBLOCKS 94531 . 95777) (SHOWSTACKBLOCK1 95779 . 95930) (PRINCOPY 95932 . 96064) (NOSUCHATOM
|
||||||
95679 . 96115)) (96118 104746 (BACKTRACE 96128 . 96485) (\BACKTRACE 96487 . 97593) (\SCANFORNTENTRY
|
96066 . 96502)) (96505 105133 (BACKTRACE 96515 . 96872) (\BACKTRACE 96874 . 97980) (\SCANFORNTENTRY
|
||||||
97595 . 99225) (\PRINTSTK 99227 . 99414) (\PRINTFRAME 99416 . 103399) (\PRINTBF 103401 . 104744)) (
|
97982 . 99612) (\PRINTSTK 99614 . 99801) (\PRINTFRAME 99803 . 103786) (\PRINTBF 103788 . 105131)) (
|
||||||
107255 116599 (CCODEP 107265 . 107540) (EXPRP 107542 . 107801) (SUBRP 107803 . 107858) (FNTYP 107860
|
107892 117236 (CCODEP 107902 . 108177) (EXPRP 108179 . 108438) (SUBRP 108440 . 108495) (FNTYP 108497
|
||||||
. 108620) (ARGTYPE 108622 . 109236) (NARGS 109238 . 109725) (ARGLIST 109727 . 110976) (\CCODEARGLIST
|
. 109257) (ARGTYPE 109259 . 109873) (NARGS 109875 . 110362) (ARGLIST 110364 . 111613) (\CCODEARGLIST
|
||||||
110978 . 115374) (\CCODEIVARSCAN 115376 . 116597)) (117516 119747 (CONSTANTS 117526 . 117817) (
|
111615 . 116011) (\CCODEIVARSCAN 116013 . 117234)) (118282 120513 (CONSTANTS 118292 . 118583) (
|
||||||
CONSTANTEXPRESSIONP 117819 . 119745)))))
|
CONSTANTEXPRESSIONP 118585 . 120511)))))
|
||||||
STOP
|
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)
|
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||||
(FILECREATED "13-Aug-2021 14:08:48" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;48 13416
|
(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"
|
previous date%: "13-Aug-2021 14:08:48"
|
||||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;45)
|
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>XCCS.;46)
|
||||||
|
|
||||||
|
|
||||||
(PRETTYCOMPRINT XCCSCOMS)
|
(PRETTYCOMPRINT XCCSCOMS)
|
||||||
@@ -210,9 +210,9 @@
|
|||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(\CREATE.XCCS.EXTERNALFORMAT
|
(\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 NAME (SETQ NAME :XCCS))
|
||||||
(CL:UNLESS EOL
|
(CL:UNLESS EOL
|
||||||
@@ -222,7 +222,7 @@
|
|||||||
(FUNCTION \XCCSBACKCCODE)
|
(FUNCTION \XCCSBACKCCODE)
|
||||||
(FUNCTION \XCCSOUTCHAR)
|
(FUNCTION \XCCSOUTCHAR)
|
||||||
(FUNCTION \XCCSFORMATBYTESTREAM)
|
(FUNCTION \XCCSFORMATBYTESTREAM)
|
||||||
EOL])
|
EOL T])
|
||||||
)
|
)
|
||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
@@ -268,9 +268,9 @@
|
|||||||
|
|
||||||
(PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM)
|
(PUTPROPS \RUNCODED MACRO (OPENLAMBDA (STREAM)
|
||||||
|
|
||||||
(* ;; "returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented")
|
(* ;; "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")
|
"note that neq is ok since charsets are known to be SMALLP's")
|
||||||
(NEQ (fetch CHARSET of STREAM)
|
(NEQ (fetch CHARSET of STREAM)
|
||||||
\NORUNCODE)))
|
\NORUNCODE)))
|
||||||
)
|
)
|
||||||
@@ -290,8 +290,8 @@
|
|||||||
(\CREATE.XCCS.EXTERNALFORMAT)
|
(\CREATE.XCCS.EXTERNALFORMAT)
|
||||||
)
|
)
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (1333 1562 (ACCESS-CHARSET 1343 . 1560)) (1563 10431 (\XCCSINCCODE 1573 . 4345) (
|
(FILEMAP (NIL (1319 1548 (ACCESS-CHARSET 1329 . 1546)) (1549 10417 (\XCCSINCCODE 1559 . 4331) (
|
||||||
\XCCSPEEKCCODE 4347 . 6883) (\XCCSOUTCHAR 6885 . 9105) (\XCCSBACKCCODE 9107 . 10102) (
|
\XCCSPEEKCCODE 4333 . 6869) (\XCCSOUTCHAR 6871 . 9091) (\XCCSBACKCCODE 9093 . 10088) (
|
||||||
\XCCSFORMATBYTESTREAM 10104 . 10429)) (10432 10988 (\CREATE.XCCS.EXTERNALFORMAT 10442 . 10986)) (10989
|
\XCCSFORMATBYTESTREAM 10090 . 10415)) (10418 10976 (\CREATE.XCCS.EXTERNALFORMAT 10428 . 10974)) (10977
|
||||||
11820 (\NSIN.24BITENCODING.ERROR 10999 . 11818)))))
|
11808 (\NSIN.24BITENCODING.ERROR 10987 . 11806)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
Reference in New Issue
Block a user