Compare commits
10 Commits
medley-211
...
medley-211
| Author | SHA1 | Date | |
|---|---|---|---|
|
ab4800054e | ||
|
|
b1634ef140 | ||
|
76a2235636 | ||
|
|
7c65b47fba | ||
|
|
c3a497d8f3 | ||
|
|
9cf54a1687 | ||
|
|
5490abb143 | ||
|
18f5da85fd | ||
|
|
01de5a2324 | ||
|
|
528776de19 |
62
.github/workflows/buildDocker.yml
vendored
62
.github/workflows/buildDocker.yml
vendored
@@ -3,11 +3,9 @@
|
||||
# Interlisp workflow to build Docker Image that support multiple architectures
|
||||
name: Build Medley Docker image
|
||||
|
||||
# Run this workflow on push to master
|
||||
# Run this workflow on demand
|
||||
on:
|
||||
push:
|
||||
branches:
|
||||
- master
|
||||
workflow_dispatch:
|
||||
|
||||
# Jobs that compose this workflow
|
||||
jobs:
|
||||
@@ -19,31 +17,57 @@ jobs:
|
||||
- name: Checkout
|
||||
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
|
||||
- name: Prepare
|
||||
id: prep
|
||||
run: |
|
||||
DOCKER_IMAGE=interlisp/${GITHUB_REPOSITORY#*/}
|
||||
DOCKERHUB_ACCOUNT=interlisp
|
||||
DOCKER_IMAGE=${DOCKERHUB_ACCOUNT}/${GITHUB_REPOSITORY#*/}
|
||||
VERSION=latest
|
||||
SHORTREF=${GITHUB_SHA::8}
|
||||
|
||||
# If this is git tag, use the tag name as a docker tag
|
||||
if [[ $GITHUB_REF == refs/tags/* ]]; then
|
||||
VERSION=${GITHUB_REF#refs/tags/v}
|
||||
fi
|
||||
TAGS="${DOCKER_IMAGE}:${VERSION},${DOCKER_IMAGE}:${SHORTREF}"
|
||||
|
||||
# If the VERSION looks like a version number, assume that
|
||||
# this is the most recent version of the image and also
|
||||
# tag it 'latest'.
|
||||
if [[ $VERSION =~ ^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$ ]]; then
|
||||
TAGS="$TAGS,${DOCKER_IMAGE}:latest"
|
||||
fi
|
||||
MAIKO_RELEASE=${{ steps.maiko_version.outputs.latest_tag }}
|
||||
MEDLEY_RELEASE=${{ steps.medley_version.outputs.latest_tag }}
|
||||
|
||||
TAGS="${DOCKER_IMAGE}:${MEDLEY_RELEASE},${DOCKER_IMAGE}:${VERSION},${DOCKER_IMAGE}:${MAIKO_RELEASE}"
|
||||
|
||||
# Set output parameters.
|
||||
echo ::set-output name=tags::${TAGS}
|
||||
echo ::set-output name=docker_image::${DOCKER_IMAGE}
|
||||
echo ::set-output name=build_time::$(date -u +'%Y-%m-%dT%H:%M:%SZ')
|
||||
echo ::set-output name=version::${VERSION}
|
||||
|
||||
# Download Medley Release Assets
|
||||
- name: Download Release Assets
|
||||
uses: robinraju/release-downloader@v1.2
|
||||
with:
|
||||
repository: Interlisp/medley
|
||||
token: ${{ secrets.GITHUB_TOKEN }}
|
||||
latest: true
|
||||
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
|
||||
- name: Set up QEMU
|
||||
|
||||
43
.github/workflows/buildLoadup.yml
vendored
43
.github/workflows/buildLoadup.yml
vendored
@@ -27,24 +27,37 @@ jobs:
|
||||
- name: Checkout Medley
|
||||
uses: actions/checkout@v2
|
||||
|
||||
- name: Get the latest Maiko Release
|
||||
uses: actions/checkout@v2
|
||||
# Get Maiko release information, retrieves the name of the latest
|
||||
# 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:
|
||||
repository: interlisp/maiko
|
||||
path: maiko
|
||||
owner: Interlisp
|
||||
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
|
||||
run: sudo apt-get update && sudo apt-get install -y make clang libx11-dev gcc x11vnc xvfb
|
||||
- name: Untar Maiko Release
|
||||
run: |
|
||||
tar -xvzf "${{ steps.latest_version.outputs.latest_tag }}-linux.x86_64.tgz"
|
||||
|
||||
- name: install vnc
|
||||
run: sudo apt-get install -y tightvncserver
|
||||
|
||||
- name: Compile Maiko
|
||||
working-directory: maiko/bin
|
||||
run: ./makeright x && ./makeright init
|
||||
run: sudo apt-get update && sudo apt-get install -y tightvncserver
|
||||
|
||||
- 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
|
||||
run: |
|
||||
@@ -66,7 +79,7 @@ jobs:
|
||||
--exclude "*~" --exclude "*#*" \
|
||||
medley/docs/dinfo \
|
||||
medley/docs/Documentation\ Tools \
|
||||
medley/greetfiles/SIMPLE-INIT \
|
||||
medley/greetfiles \
|
||||
medley/run-medley \
|
||||
medley/scripts \
|
||||
medley/fonts/displayfonts \
|
||||
@@ -81,13 +94,13 @@ jobs:
|
||||
|
||||
- name: Release notes
|
||||
run: |
|
||||
sed s/'$tag'/$tag/g < release-notes.md > tmp/release-notes.md &&
|
||||
ls tmp && env
|
||||
sed s/'$tag'/$tag/g < release-notes.md > tmp/release-notes.md
|
||||
|
||||
- name: push the release
|
||||
uses: ncipollo/release-action@v1.8.10
|
||||
with:
|
||||
artifacts: tmp/${{ env.tag }}-loadups.tgz,tmp/${{ env.tag }}-runtime.tgz
|
||||
tag: ${{ env.tag }}
|
||||
draft: true
|
||||
bodyfile: tmp/release-notes.md
|
||||
token: ${{ secrets.GITHUB_TOKEN }}
|
||||
24
BUILDING.md
24
BUILDING.md
@@ -1,16 +1,34 @@
|
||||
# How to build a medley release
|
||||
|
||||
Originally done only with shell scripts:
|
||||
|
||||
```
|
||||
./scripts/loadup-all.sh
|
||||
```
|
||||
to make the loadups
|
||||
```
|
||||
./scripts/loadup-and-release.sh
|
||||
|
||||
```
|
||||
to go on to make the tgz files and release them
|
||||
|
||||
# Using github actions
|
||||
|
||||
In the github medley repository (Interlisp/medley) go to the Actions tab.
|
||||
|
||||
It should list the available github actions, select the bottom one, Build Medley Release.
|
||||
It will list the available github actions, select: **Build Medley Release**.
|
||||
|
||||
In the middle of the screen there's a box labeled workflow runs.
|
||||
There should be a row in it that states 'This workflow has a workflow_dispatch event trigger' with a drop down menu (it really looks more like a button) on the right side labeled 'Run workflow'. Select that and you'll get a form allowing you to select the branch (I've only used Master) and enter the release name. Enter a name or leave it empty and press the green 'Run workflow' button. The workflow should queue up and run.
|
||||
|
||||
# How to create a Docker image for the latest Medley release
|
||||
|
||||
In the github medley repository (Interlisp/medley) go to the Actions tab.
|
||||
|
||||
It will list the available github actions, select: **Build Medley Docker image**.
|
||||
|
||||
A table is presented which lists the previous runs of the workflow. If the workflow has never been run, it will be empty. A the top of the list is a row labeled, 'This workflow has a workflow_dispatch event trigger.' with a drop down menu labeled 'Run workflow'. Select it.
|
||||
|
||||
A box will be presented asking, 'Use workflow from' with a drop down menu of all available branches. The default branch is **master**. Leave it selected and push the green 'Run workflow' button.
|
||||
|
||||
The workflow will be queued to run and start running.
|
||||
|
||||
The workflow pulls the latest Maiko image from Docker Hub and the Release Assets from the latest Medley release, generally defined as medley-YYMMDD. The Medley Docker image adds in Tight VNC Server and retrieves the two tarballs associated with a release, one containing the sysouts and the other the other needed files source, fonts, etc. The contents are uncompressed and loaded into the Medley directory structure.
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
FROM interlisp/maiko:latest
|
||||
FROM ubuntu:focal
|
||||
ARG BUILD_DATE
|
||||
LABEL name="Medley"
|
||||
# LABEL tags=${tags}
|
||||
LABEL description="The Medley Interlisp environment"
|
||||
LABEL url="https://github.com/Interlisp/medley"
|
||||
LABEL build-time=$BUILD_DATE
|
||||
@@ -9,8 +10,8 @@ RUN apt-get update && apt-get install -y tightvncserver
|
||||
|
||||
EXPOSE 5900
|
||||
|
||||
# Need to refine this down to only needed directories.
|
||||
COPY . /app/medley
|
||||
# Copy and uncompress loadup and required source files.
|
||||
ADD *.tgz /app
|
||||
|
||||
WORKDIR /app/medley
|
||||
|
||||
|
||||
29
README.md
29
README.md
@@ -125,16 +125,25 @@ files.
|
||||
|
||||
Each directory should have a README.md, but briefly
|
||||
|
||||
- docs -- Documentation files (either PDFs or online help)
|
||||
- fonts -- raster fonts (or font widths) in various resolutions for display, postscript, interpress, press formats
|
||||
- greetfiles -- various configuration setups
|
||||
- internal -- These _were_ internal to Venue; now internal/library and internal/test
|
||||
- library -- packages that were supported (30 years ago)
|
||||
- lispusers -- packages that were only half supported (ditto)
|
||||
- loadups -- has sysouts and other builds
|
||||
- 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
|
||||
* BUILDING.md -- instructions on how to make your own loadups
|
||||
* clos -- early implementation of Common Lisp Object System
|
||||
* 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.
|
||||
* Dockerfile -- used when building Docker containers with Medley
|
||||
* docs -- Documentation files (either PDFs or online help; see medley/wiki)
|
||||
* fonts -- raster fonts (or font widths) in various resolutions for display, postscript, interpress, press formats
|
||||
* greetfiles -- various configuration setups
|
||||
* internal -- These _were_ internal to Venue; now internal/library and internal/test
|
||||
* library -- packages that were supported (30 years ago)
|
||||
* 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
|
||||
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,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 1-Sep-2021 21:13:57" {DSK}<home>larry>medley>internal>library>MAKE-PS.;6 5503
|
||||
|
||||
changes to%: (VARS MAKE-PSCOMS)
|
||||
(FNS MAKE-PS-INIT)
|
||||
(FILECREATED "17-Oct-2021 16:06:41" {DSK}<home>larry>medley>internal>library>MAKE-PS.;2 5515
|
||||
|
||||
previous date%: "31-Aug-2021 22:30:13" {DSK}<home>larry>medley>internal>library>MAKE-PS.;4)
|
||||
changes to%: (FILES DOC-OBJECTS)
|
||||
(VARS MAKE-PSCOMS)
|
||||
|
||||
previous date%: " 1-Sep-2021 21:13:57" {DSK}<home>larry>medley>internal>library>MAKE-PS.;1)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MAKE-PSCOMS)
|
||||
@@ -14,7 +15,7 @@
|
||||
|
||||
(* ;; " Load known used image object types")
|
||||
|
||||
(FILES DOC-OBJECTS EQUATIONS IMINDEX IMNAME IMTEDIT IMTOOLS IMTRAN MATHTONS SKETCH)
|
||||
(FILES DOC-OBJECTS EQUATIONS IMINDEX IMNAME IMTEDIT IMTOOLS IMTRAN MATHTONS SKETCH TMAX)
|
||||
(ADVISE TEDIT.PROMPTPRINT)
|
||||
(INITVARS (BADFILESFILE)
|
||||
(BADFS)
|
||||
@@ -113,7 +114,7 @@
|
||||
(* ;; " Load known used image object types")
|
||||
|
||||
|
||||
(FILESLOAD DOC-OBJECTS EQUATIONS IMINDEX IMNAME IMTEDIT IMTOOLS IMTRAN MATHTONS SKETCH)
|
||||
(FILESLOAD DOC-OBJECTS EQUATIONS IMINDEX IMNAME IMTEDIT IMTOOLS IMTRAN MATHTONS SKETCH TMAX)
|
||||
|
||||
[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '((:LAST (PRIN1 MSG T]
|
||||
|
||||
@@ -129,5 +130,5 @@
|
||||
(MAKE-PS-INIT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (786 5110 (MAKE-PS 796 . 4293) (MAKE-PS-INIT 4295 . 4731) (BADFILE 4733 . 5108)))))
|
||||
(FILEMAP (NIL (793 5117 (MAKE-PS 803 . 4300) (MAKE-PS-INIT 4302 . 4738) (BADFILE 4740 . 5115)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,28 +1,124 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
|
||||
(FILECREATED "28-Mar-2021 10:17:29"
|
||||
|{DSK}<home>larry>ilisp>medley>internal>library>MEDLEY-UTILS.;4| 3190
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "25-Oct-2021 14:54:43" |{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;14| 9472
|
||||
|
||||
|changes| |to:| (VARS MEDLEY-UTILSCOMS)
|
||||
(FNS GATHER-INFO)
|
||||
|
||||
|previous| |date:| "24-Mar-2021 15:45:15"
|
||||
|{DSK}<home>larry>ilisp>medley>internal>library>MEDLEY-UTILS.;3|)
|
||||
|previous| |date:| "23-Oct-2021 14:53:16"
|
||||
|{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;2|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
|
||||
(RPAQQ MEDLEY-UTILSCOMS ((FNS MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
|
||||
(RPAQQ MEDLEY-UTILSCOMS ((FNS GATHER-INFO MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
|
||||
(VARS MEDLEY-FIX-DIRS)
|
||||
(FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)))
|
||||
(DEFINEQ
|
||||
|
||||
(GATHER-INFO
|
||||
(LAMBDA (PHASE) (* \;
|
||||
"Edited 24-Oct-2021 09:43 by larry")
|
||||
(SELECTQ PHASE
|
||||
(ALL (SETQ SYSFILES (UNION SYSFILES FILELST))
|
||||
(SETQ FILELST NIL)
|
||||
(FILESLOAD (SOURCE)
|
||||
SYSEDIT)
|
||||
(|for| I |from| 1 |to| 4 |do| (GATHER-INFO I)))
|
||||
(1 (SETQ LOADEDFILES (|for| X |in| LOADEDFILELST |collect| (FILENAMEFIELD
|
||||
X
|
||||
'NAME)))
|
||||
(FILESLOAD FILESETS)
|
||||
(SETQ ALLFILESETSFILES (|for| X |in| FILESETS |join| (APPEND (EVAL X))))
|
||||
(SETQ SOURCES (|for| X |in| (DIRECTORY (MEDLEYDIR "sources" "*.*;" T))
|
||||
|when| (NOT (MEMB (FILENAMEFIELD X 'EXTENSION)
|
||||
'(LCOM DFASL TEDIT TXT)))
|
||||
|collect| (FILENAMEFIELD X 'NAME))))
|
||||
(-1 (PRINTOUT T " loaded files not in SYSFILES or FILELST: "
|
||||
(|for| X |in| LOADEDFILES |when| (NOT (OR (FMEMB X SYSFILES)
|
||||
(FMEMB X FILELST)))
|
||||
|collect| X)
|
||||
T)
|
||||
(PRINTOUT T "Sources not loaded: " (CL:SET-DIFFERENCE SOURCES (APPEND ALLFILESETSFILES
|
||||
LOADEDFILES))
|
||||
T)
|
||||
(PRINTOUT T "Files in FILESETS not loaded " (CL:SET-DIFFERENCE ALLFILESETSFILES
|
||||
LOADEDFILES)
|
||||
T))
|
||||
(2 (SETQ DEFINEDFNS (LET ((DEFD NIL))
|
||||
(MAPATOMS (FUNCTION (CL:LAMBDA (X)
|
||||
(CL:WHEN (GETD X)
|
||||
(CL:SETQ DEFD (CONS X DEFD))))))
|
||||
DEFD))
|
||||
(|for| X |in| DEFINEDFNS |when| (CCODEP X)
|
||||
|do| (LET ((Y (PUTPROP X 'CCC (CALLSCCODE X))))
|
||||
(|for| REV |in| '(BLOCK-CALLED-BY CALLED-BY SPECIAL-BY GLOBAL-BY)
|
||||
|as| VAL |in| Y
|
||||
|do| (|for| S |in| VAL
|
||||
|do| (PUTPROP S REV (CONS X (GETPROP S REV)))))))
|
||||
(SETQ CALLEDFNS NIL)
|
||||
(MAPATOMS (FUNCTION (LAMBDA (X)
|
||||
(|if| (AND (NOT (GETD X))
|
||||
(GETPROP X 'CALLED-BY))
|
||||
|then| (CL:PUSH X CALLEDFNS))))))
|
||||
(-2 (PRINTOUT T "Functions called and not defined" CALLEDFNS T))
|
||||
(3 (|for| X |in| SYSFILES
|
||||
|do|
|
||||
(LOAD X 'PROP)
|
||||
(PUTPROP X 'CONTENT (READFILE X))
|
||||
(|for| EXR |in| (GETPROP X 'CONTENT)
|
||||
|do| (SELECTQ (CAR EXR)
|
||||
(DEFINEQ (|for| DFN |in| (CDR EXR)
|
||||
|do| (|if| (EQUAL (CADR DFN)
|
||||
(GETPROP (CAR DFN)
|
||||
'EXPR))
|
||||
|then| (PRINTOUT T (CAR DFN)
|
||||
" ")
|
||||
(PUTPROP (CAR DFN)
|
||||
'EXPR
|
||||
(CADR DFN))
|
||||
|else| (PRINTOUT T (CAR DFN)
|
||||
"* "))))
|
||||
NIL)))
|
||||
(SETQ ALLCONTENT (|for| X |in| SYSFILES |collect| (CONS X (GETPROP
|
||||
X
|
||||
'CONTENT))))
|
||||
(* \; " don't edit with SEDIT")
|
||||
(LET (DUPS)
|
||||
(|for| X |in| SYSFILES
|
||||
|do| (|for| FN |in| (FILEFNSLST X)
|
||||
|do| (|if| (GETPROP FN 'WHEREIS)
|
||||
|then| (NCONC1 (GETPROP FN 'WHEREIS)
|
||||
X)
|
||||
(OR (FMEMB FN DUPS)
|
||||
(SETQ DUPS (CONS FN DUPS)))
|
||||
|else| (PUTPROP FN 'WHEREIS (LIST X)))))
|
||||
(SETQ DUPFNS DUPS))
|
||||
(SETQ NO-SOURCE (|for| X |in| DEFINEDFNS |when| (NOT (GETPROP X 'EXPR))
|
||||
|collect| X)))
|
||||
(-3 (PRINTOUT T "Functions compiled but no expr" NO-SOURCE T)
|
||||
(PRINTOUT T "Functions on more than one file: " DUPFNS T))
|
||||
(4 (PRINTOUT T T "STARTING MASTERSCOPE PHASE ON " (DATE)
|
||||
T)
|
||||
(FILESLOAD (SOURCE)
|
||||
SYSEDIT)
|
||||
(|for| X |in| SYSFILES |do| (MSNOTICEFILE X))
|
||||
(|for| X |in| SYSFILES |do| (PRINTOUT T T "Analyzing " X T)
|
||||
(MASTERSCOPE `(ANALYZE ON ,(KWOTE X)))))
|
||||
(-4 "No queries yet")
|
||||
(HELP))))
|
||||
|
||||
(MEDLEY-FIX-LINKS
|
||||
(LAMBDA (UNIXPATH) (* \; "Edited 18-Jan-2021 12:01 by larry")
|
||||
(LAMBDA (UNIXPATH) (* \;
|
||||
"Edited 18-Jan-2021 12:01 by larry")
|
||||
(OR UNIXPATH (SETQ UNIXPATH (UNIX-GETENV "MEDLEYDIR"))
|
||||
(ERROR "No Directory")) (* \; "Edited 18-Jan-2021 11:45 by larry")
|
||||
(ERROR "No Directory")) (* \;
|
||||
"Edited 18-Jan-2021 11:45 by larry")
|
||||
(|ShellCommand| (CONCAT "cd " UNIXPATH " && /bin/sh scripts/fixlinks && /bin/sh /tmp/doit"))))
|
||||
|
||||
(MEDLEY-FIX-DATES
|
||||
(LAMBDA (DIRS) (* \; "Edited 28-Jan-2021 12:15 by larry")
|
||||
(LAMBDA (DIRS) (* \;
|
||||
"Edited 28-Jan-2021 12:15 by larry")
|
||||
(|for| X |in| (OR DIRS MEDLEY-FIX-DIRS) |join| (FIX-DIRECTORY-DATES
|
||||
(MEDLEYDIR (PRINT X T))))))
|
||||
)
|
||||
@@ -32,7 +128,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-EXPORTS-ALL
|
||||
(LAMBDA NIL (* \; "Edited 9-Mar-2021 16:11 by larry")
|
||||
(LAMBDA NIL (* \;
|
||||
"Edited 9-Mar-2021 16:11 by larry")
|
||||
(* "Edited May 3, 2018 by Ron Kaplan--relative to MEDLEYDIR/lispcore/. Don't know why it does the CORE/RENAME")
|
||||
(*
|
||||
"Edited Aug 17 94 by Sybalsky -- point it to /king/export/lispcore as the truth directory.")
|
||||
@@ -45,7 +142,8 @@
|
||||
(GATHEREXPORTS EXPORTFILES (MEDLEYDIR "tmp" "exports.all" T))))
|
||||
|
||||
(MAKE-WHEREIS-HASH
|
||||
(LAMBDA NIL (* \; "Edited 24-Mar-2021 13:26 by larry")
|
||||
(LAMBDA NIL (* \;
|
||||
"Edited 24-Mar-2021 13:26 by larry")
|
||||
(LET ((FILING.ENUMERATION.DEPTH 1)
|
||||
HASHFILE)
|
||||
(DRIBBLE (MEDLEYDIR "tmp" "whereis.dribble" T))
|
||||
@@ -59,6 +157,6 @@
|
||||
(DRIBBLE))))
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (567 1272 (MEDLEY-FIX-LINKS 577 . 966) (MEDLEY-FIX-DATES 968 . 1270)) (1430 3167 (
|
||||
MAKE-EXPORTS-ALL 1440 . 2389) (MAKE-WHEREIS-HASH 2391 . 3165)))))
|
||||
(FILEMAP (NIL (618 7420 (GATHER-INFO 628 . 6522) (MEDLEY-FIX-LINKS 6524 . 7047) (MEDLEY-FIX-DATES 7049
|
||||
. 7418)) (7578 9449 (MAKE-EXPORTS-ALL 7588 . 8604) (MAKE-WHEREIS-HASH 8606 . 9447)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,15 +1,15 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "13-Jun-2021 14:02:38"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>BIGBITMAPS.;5| 113115
|
||||
|
||||
|changes| |to:| (FNS \\DRAWLINE.BIGBM.DASH \\DRAWLINE.BIGBM.NODASH BIGBITMAPP)
|
||||
(FILECREATED "26-Oct-2021 14:51:38" |{DSK}<home>larry>medley>library>BIGBITMAPS.;7| 110451
|
||||
|
||||
|changes| |to:| (FNS UNCOLORIZEBITMAP COLORIZEBITMAP \\BWTOCOLORBLT)
|
||||
(VARS BIGBITMAPSCOMS)
|
||||
(MACROS |\\SFInvert|)
|
||||
|
||||
|previous| |date:| "10-May-2021 15:37:51"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>BIGBITMAPS.;1|)
|
||||
|previous| |date:| "13-Jun-2021 14:02:38" |{DSK}<home>larry>medley>library>BIGBITMAPS.;5|)
|
||||
|
||||
|
||||
; Copyright (c) 1991, 1993-1994, 2021 by Venue.
|
||||
; Copyright (c) 1991, 1993-1994 by Venue.
|
||||
|
||||
(PRETTYCOMPRINT BIGBITMAPSCOMS)
|
||||
|
||||
@@ -69,11 +69,7 @@
|
||||
|
||||
(PUTPROPS |\\SFInvert| MACRO ((|BitMap| \y)
|
||||
|
||||
(* |corrects| |for| |the| |fact| |that| |alto| |bitmaps| |are| |stored| |with|
|
||||
0\,0 |as| |upper| |left| |while| |lisp| |bitmaps| |have| 0\,0 |as| |lower|
|
||||
|left.| |The| |correction| |is| |actually| |off| |by| |one|
|
||||
(|greater|) |because| \a |majority| |of| |the| |places| |that| |it| |is|
|
||||
|called| |actually| |need| |one| |more| |than| |corrected| Y |value.|)
|
||||
(* |;;| "corrects for the fact that alto bitmaps are stored with 0,0 as upper left while lisp bitmaps have 0,0 as lower left. The correction is actually off by one (greater) because a majority of the places that it is called actually need one more than corrected Y value.")
|
||||
|
||||
(IDIFFERENCE (|fetch| (BITMAP BITMAPHEIGHT) |of|
|
||||
|BitMap|)
|
||||
@@ -1478,11 +1474,12 @@
|
||||
(DEFINEQ
|
||||
|
||||
(COLORIZEBITMAP
|
||||
(LAMBDA (BITMAP 0COLOR 1COLOR BITSPERPIXEL) (* \; "Edited 13-Jul-90 14:42 by matsuda")
|
||||
(LAMBDA (BITMAP 0COLOR 1COLOR BITSPERPIXEL) (* \;
|
||||
"Edited 26-Oct-2021 14:23 by larry")
|
||||
(* \;
|
||||
"Edited 13-Jul-90 14:42 by matsuda")
|
||||
|
||||
(* |creates| \a |copy| |of| BITMAP |that| |is| |in| |color| |form| |allowing|
|
||||
BITSPERPIXEL |per| |pixel.| 0COLOR |and| 1COLOR |are| |the| |color| |numbers|
|
||||
|that| |get| |translated| |from| 0 |and| 1 |respectively.|)
|
||||
(* |;;| "creates a copy of BITMAP that is in color form allowing BITSPERPIXEL per pixel. 0COLOR and 1COLOR are the color numbers that get translated from 0 and 1 respectively.")
|
||||
|
||||
(PROG (COLORBITMAP)
|
||||
(SETQ COLORBITMAP (BITMAPCREATE (|fetch| (BITMAP BITMAPWIDTH) |of| BITMAP)
|
||||
@@ -1516,14 +1513,20 @@
|
||||
(RETURN COLORBITMAP))))
|
||||
|
||||
(\\BWTOCOLORBLT
|
||||
(LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS)
|
||||
(* \; "Edited 8-May-2021 22:31 by rmk:")
|
||||
(LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS)
|
||||
(* \;
|
||||
"Edited 26-Oct-2021 14:36 by larry")
|
||||
(* \;
|
||||
"Edited 26-Oct-2021 14:32 by larry")
|
||||
(* \;
|
||||
"Edited 26-Oct-2021 14:26 by larry")
|
||||
(* \;
|
||||
"Edited 8-May-2021 22:31 by rmk:")
|
||||
|
||||
(* |;;| "blits from a black and white bitmap into a color bitmap which has DESTNBITS bits per pixel. DESTCOLORBM is a pointer to the color bitmap.")
|
||||
|
||||
(* |;;| "assumes all datatypes and bounds have been checked")
|
||||
|
||||
(* |blits| |from| \a |black| |and| |white| |bitmap| |into| \a |color| |bitmap|
|
||||
|which| |has| DESTNBITS |bits| |per| |pixel.|
|
||||
DESTCOLORBM |is| \a |pointer| |to| |the| |color| |bitmap.|)
|
||||
(* |assumes| |all| |datatypes| |and|
|
||||
|bounds| |have| |been| |checked|)
|
||||
(SELECTQ DESTNBITS
|
||||
(4 (PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF
|
||||
NBITS DESALIGNLEFT SCR)
|
||||
@@ -1538,24 +1541,24 @@
|
||||
(SETQ DESRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| DESTCOLORBM))
|
||||
(SETQ DESWRD (FOLDLO DLEFT 4))
|
||||
(SETQ DESOFF (MOD DLEFT 4))
|
||||
(SETQ NBITS 4) (* DESTCOLORBM |is| |used| |to|
|
||||
|allow| |one| |bit| |per| |pixel|
|
||||
|bitblt| |operations| |on| |the|
|
||||
|bitmap.|)
|
||||
(SETQ NBITS 4)
|
||||
|
||||
(* |;;|
|
||||
"DESTCOLORBM is used to allow one bit per pixel bitblt operations on the bitmap.")
|
||||
|
||||
(COND
|
||||
((NOT (EQ 0 DESOFF)) (* |save| |the| |left| |bits| |of|
|
||||
|the| |destination| |bitmap| |so|
|
||||
|it| |can| |be| |word| |aligned.|)
|
||||
((NOT (EQ 0 DESOFF))
|
||||
|
||||
(* |;;|
|
||||
"save the left bits of the destination bitmap so it can be word aligned.")
|
||||
|
||||
(SETQ SCR (BITMAPCREATE 4 HEIGHT 4))
|
||||
(BITBLT DESTCOLORBM (SETQ DESALIGNLEFT (LLSH DESWRD 2))
|
||||
DBOTTOM SCR 0 0 DESOFF HEIGHT 'INPUT 'REPLACE)))
|
||||
(|for| LINECOUNTER |from| 1 |to| HEIGHT
|
||||
|do|
|
||||
|
||||
(* |linecounter| |goes| |from| 1 |to| |height| |because| |bitmaps| |are|
|
||||
|stored| |internally| |with| |top| |first| |so| |subtracting| |height| |is|
|
||||
|necessary| |to| |get| |offset| |of| |line| |and| |the| 1 |corrects| |for|
|
||||
|height| |difference.|)
|
||||
(* |;;| "linecounter goes from 1 to height because bitmaps are stored internally with top first so subtracting height is necessary to get offset of line and the 1 corrects for height difference.")
|
||||
|
||||
(\\4BITLINEBLT (\\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT
|
||||
(IPLUS LINECOUNTER
|
||||
@@ -1570,9 +1573,11 @@
|
||||
DESWRD))
|
||||
WIDTH MAP 0COLOR 1COLOR))
|
||||
(COND
|
||||
(DESALIGNLEFT (* |move| |the| |color| |bits| |to|
|
||||
|the| |right| |and| |restore| |the|
|
||||
|saved| |color| |bits.|)
|
||||
(DESALIGNLEFT
|
||||
|
||||
(* |;;|
|
||||
"move the color bits to the right and restore the saved color bits.")
|
||||
|
||||
(BITBLT DESTCOLORBM DESALIGNLEFT DBOTTOM DESTCOLORBM (IPLUS
|
||||
DESALIGNLEFT
|
||||
DESOFF)
|
||||
@@ -1580,32 +1585,8 @@
|
||||
(BITBLT SCR 0 0 DESTCOLORBM DESALIGNLEFT DBOTTOM DESOFF HEIGHT
|
||||
'INPUT
|
||||
'REPLACE)))))
|
||||
(8
|
||||
|
||||
(* PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW
|
||||
DESWRD DESOFF) (SETQ MAP (|fetch| (ARRAYP BASE) |of|
|
||||
(\\MAP8 0COLOR 1COLOR))) (SETQ SRCBASE (|fetch|
|
||||
(BITMAP BITMAPBASE) |of| SOURCEBWBM)) (SETQ SRCHEIGHT
|
||||
(|fetch| (BITMAP BITMAPHEIGHT) |of| SOURCEBWBM))
|
||||
(SETQ SRCRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| SOURCEBWBM))
|
||||
(SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD))
|
||||
(SETQ SRCOFFSET (MOD SLEFT BITSPERWORD))
|
||||
(SETQ DESBASE (|fetch| (BITMAP BITMAPBASE) |of| DESTCOLORBM))
|
||||
(SETQ DESHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| DESTCOLORBM))
|
||||
(SETQ DESRW (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| DESTCOLORBM))
|
||||
(SETQ DESWRD (FOLDLO DLEFT 2)) (SETQ DESOFF
|
||||
(MOD DLEFT 2)) (|for| LINECOUNTER |from| 1 |to| HEIGHT |do|
|
||||
(* |linecounter| |goes| |from| 1 |to| |height| |because| |bitmaps| |are|
|
||||
|stored| |internally| |with| |top| |first| |so| |subtracting| |height| |is|
|
||||
|necessary| |to| |get| |offset| |of| |line| |and| |the| 1 |corrects| |for|
|
||||
|height| |difference.|) (\\8BITLINEBLT (\\ADDBASE SRCBASE
|
||||
(IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW)
|
||||
SRCWRD)) SRCOFFSET (\\ADDBASE DESBASE (IPLUS
|
||||
(ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW) DESWRD))
|
||||
DESOFF WIDTH MAP 0COLOR 1COLOR)) *)
|
||||
|
||||
((OPCODES SUBRCALL 142 11)
|
||||
SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS))
|
||||
(8 (SUBRCALL COLORIZE-BITMAP SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT
|
||||
0COLOR 1COLOR DESTNBITS))
|
||||
(24 (PROG (SRCBASE SRCHEIGHT SRCRW DESBASE DESHEIGHT DESRW)
|
||||
(SETQ SRCBASE (|fetch| (BITMAP BITMAPBASE) |of| SOURCEBWBM))
|
||||
(SETQ SRCHEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| SOURCEBWBM))
|
||||
@@ -1616,10 +1597,7 @@
|
||||
(|for| LINECOUNTER |from| 1 |to| HEIGHT
|
||||
|do|
|
||||
|
||||
(* |linecounter| |goes| |from| 1 |to| |height| |because| |bitmaps| |are|
|
||||
|stored| |internally| |with| |top| |first| |so| |subtracting| |height| |is|
|
||||
|necessary| |to| |get| |offset| |of| |line| |and| |the| 1 |corrects| |for|
|
||||
|height| |difference.|)
|
||||
(* |;;| "linecounter goes from 1 to height because bitmaps are stored internally with top first so subtracting height is necessary to get offset of line and the 1 corrects for height difference.")
|
||||
|
||||
(\\24BITLINEBLT (\\ADDBASE SRCBASE (ITIMES (IDIFFERENCE SRCHEIGHT
|
||||
(IPLUS LINECOUNTER
|
||||
@@ -1634,7 +1612,14 @@
|
||||
(SHOULDNT))))
|
||||
|
||||
(UNCOLORIZEBITMAP
|
||||
(LAMBDA (BITMAP COLORMAP) (* \; "Edited 13-Jul-90 16:54 by matsuda")
|
||||
(LAMBDA (BITMAP COLORMAP) (* \;
|
||||
"Edited 26-Oct-2021 14:51 by larry")
|
||||
(* \;
|
||||
"Edited 26-Oct-2021 14:44 by larry")
|
||||
(* \;
|
||||
"Edited 26-Oct-2021 14:44 by larry")
|
||||
(* \;
|
||||
"Edited 13-Jul-90 16:54 by matsuda")
|
||||
(PROG (BITSPERPIXEL MAXCOLOR MAXX MAXY BWBITMAP TABLE RGB R G B BIT BASE BWBASE RASTERWIDTH
|
||||
BWRASTERWIDTH WORD)
|
||||
(SETQ MAXX (SUB1 (BITMAPWIDTH BITMAP)))
|
||||
@@ -1685,8 +1670,7 @@
|
||||
(SETQ BWBASE (\\ADDBASE BWBASE BWRASTERWIDTH))))))
|
||||
(8 (COND
|
||||
((NOT (|type?| BIGBM BITMAP))
|
||||
((OPCODES SUBRCALL 141 3)
|
||||
BITMAP BWBITMAP TABLE))
|
||||
(SUBRCALL UNCOLORIZE-BITMAP BITMAP BWBITMAP TABLE))
|
||||
(T (PROG ((SRCBIGBMLIST (|fetch| (BIGBM BIGBMLIST) |of| BITMAP))
|
||||
SRCBITMAP
|
||||
(WIDTH (ADD1 MAXX))
|
||||
@@ -1705,8 +1689,8 @@
|
||||
|of|
|
||||
SRCBITMAP)
|
||||
)))
|
||||
((OPCODES SUBRCALL 141 3)
|
||||
SRCBITMAP TEMPBM TABLE)
|
||||
(SUBRCALL UNCOLORIZE-BITMAP SRCBITMAP
|
||||
TEMPBM TABLE)
|
||||
(BITBLT TEMPBM 0 (IDIFFERENCE
|
||||
(ADD1 MAXY)
|
||||
HEIGHT)
|
||||
@@ -1714,25 +1698,7 @@
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ SRCBITMAP (|GetNewFragment|
|
||||
SRCBIGBMLIST))))))
|
||||
(* |for| Y |from| 0 |to| MAXY |do|
|
||||
(SETQ WORD 0) (|for| X |from| 0 |to|
|
||||
MAXX |do| (SETQ WORD
|
||||
(LOGOR (LLSH WORD 1)
|
||||
(\\GETBASE TABLE (\\GETBASEBYTE BASE
|
||||
X)))) (COND ((EQ (LOGAND X 15) 15)
|
||||
(\\PUTBASE BWBASE (FOLDLO X 16) WORD)
|
||||
(SETQ WORD 0)))) (COND
|
||||
((NOT (EQ (LOGAND MAXX 15) 15))
|
||||
(SETQ WORD (LLSH WORD
|
||||
(IDIFFERENCE 15 (LOGAND MAXX 15))))
|
||||
(\\PUTBASE BWBASE (FOLDLO MAXX 16)
|
||||
WORD))) (COND ((NOT
|
||||
(EQ Y MAXY)) (SETQ BASE
|
||||
(\\ADDBASE BASE RASTERWIDTH))
|
||||
(SETQ BWBASE (\\ADDBASE BWBASE
|
||||
BWRASTERWIDTH)))) *)
|
||||
)
|
||||
SRCBIGBMLIST)))))))
|
||||
NIL)
|
||||
(RETURN BWBITMAP))))
|
||||
)
|
||||
@@ -1746,17 +1712,17 @@
|
||||
|
||||
(MOVD 'BITBLT 'BKBITBLT)
|
||||
)
|
||||
(PUTPROPS BIGBITMAPS COPYRIGHT ("Venue" 1991 1993 1994 2021))
|
||||
(PUTPROPS BIGBITMAPS COPYRIGHT ("Venue" 1991 1993 1994))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (3337 48035 (BIGBITMAPP 3347 . 3493) (BITBLT.BIGBM 3495 . 14318) (BITMAPCREATE.BIGBM
|
||||
14320 . 15662) (BITMAPCREATE 15664 . 17266) (BITMAPCOPY 17268 . 17803) (BLTSHADE.BIGBM 17805 . 20941)
|
||||
(BITBLT 20943 . 22591) (\\ORG.BITBLT 22593 . 34162) (\\BLTSHADE.DISPLAY 34164 . 43402) (
|
||||
\\RESHOWBORDER1 43404 . 48033)) (48036 71314 (\\DRAWCIRCLE.BIGBM 48046 . 51409) (\\FILLCIRCLE.BIGBM
|
||||
51411 . 55457) (\\DRAWELLIPSE.BIGBM 55459 . 59979) (\\DRAWCURVE.BIGBM 59981 . 63831) (
|
||||
\\DRAWLINE.BIGBM.DASH 63833 . 68192) (\\DRAWLINE.BIGBM.NODASH 68194 . 71312)) (71315 86890 (DSPCREATE
|
||||
71325 . 73755) (DSPDESTINATION 73757 . 77655) (|\\SFFixY| 77657 . 83379) (|\\SFFixDestination| 83381
|
||||
. 84564) (|\\SFFixClippingRegion| 84566 . 86888)) (86891 94977 (\\SW2BM 86901 . 91925) (BITMAPHEIGHT
|
||||
91927 . 92425) (BITMAPWIDTH 92427 . 92919) (|\\SFFixFont| 92921 . 93893) (BITSPERPIXEL 93895 . 94975))
|
||||
(94978 112868 (COLORIZEBITMAP 94988 . 97625) (\\BWTOCOLORBLT 97627 . 105909) (UNCOLORIZEBITMAP 105911
|
||||
. 112866)))))
|
||||
(FILEMAP (NIL (3215 47913 (BIGBITMAPP 3225 . 3371) (BITBLT.BIGBM 3373 . 14196) (BITMAPCREATE.BIGBM
|
||||
14198 . 15540) (BITMAPCREATE 15542 . 17144) (BITMAPCOPY 17146 . 17681) (BLTSHADE.BIGBM 17683 . 20819)
|
||||
(BITBLT 20821 . 22469) (\\ORG.BITBLT 22471 . 34040) (\\BLTSHADE.DISPLAY 34042 . 43280) (
|
||||
\\RESHOWBORDER1 43282 . 47911)) (47914 71192 (\\DRAWCIRCLE.BIGBM 47924 . 51287) (\\FILLCIRCLE.BIGBM
|
||||
51289 . 55335) (\\DRAWELLIPSE.BIGBM 55337 . 59857) (\\DRAWCURVE.BIGBM 59859 . 63709) (
|
||||
\\DRAWLINE.BIGBM.DASH 63711 . 68070) (\\DRAWLINE.BIGBM.NODASH 68072 . 71190)) (71193 86768 (DSPCREATE
|
||||
71203 . 73633) (DSPDESTINATION 73635 . 77533) (|\\SFFixY| 77535 . 83257) (|\\SFFixDestination| 83259
|
||||
. 84442) (|\\SFFixClippingRegion| 84444 . 86766)) (86769 94855 (\\SW2BM 86779 . 91803) (BITMAPHEIGHT
|
||||
91805 . 92303) (BITMAPWIDTH 92305 . 92797) (|\\SFFixFont| 92799 . 93771) (BITSPERPIXEL 93773 . 94853))
|
||||
(94856 110209 (COLORIZEBITMAP 94866 . 97676) (\\BWTOCOLORBLT 97678 . 104271) (UNCOLORIZEBITMAP 104273
|
||||
. 110207)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,19 +1,22 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED " 3-May-93 18:44:36" "{DSK}<project>lfg>parser>DATABASEFNS.;4" 17283
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Oct-2021 10:55:18" {DSK}<home>larry>medley>library>DATABASEFNS.;7 16051
|
||||
|
||||
changes to%: (FNS DUMPDB)
|
||||
|
||||
previous date%: " 7-Jul-92 09:57:14" "{DSK}<project>lfg>parser>DATABASEFNS.;3")
|
||||
previous date%: "24-Oct-2021 20:18:51" {DSK}<home>larry>medley>library>DATABASEFNS.;6)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1986, 1990-1993 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DATABASEFNSCOMS)
|
||||
|
||||
(RPAQQ DATABASEFNSCOMS
|
||||
[(* Does automatic Masterscope database maintenance)
|
||||
[
|
||||
(* ;; "Does automatic Masterscope database maintenance")
|
||||
|
||||
[DECLARE%: FIRST (P (VIRGINFN 'LOAD T)
|
||||
(MOVD? 'LOAD 'OLDLOAD)
|
||||
(VIRGINFN 'LOADFROM T)
|
||||
@@ -28,16 +31,15 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
(INITVARS (LOADDBFLG 'ASK)
|
||||
(SAVEDBFLG 'ASK))
|
||||
(ADDVARS (MAKEFILEFORMS (MAKEDB FILE)))
|
||||
(* To permit MSHASH interface)
|
||||
(INITVARS (MSHASHFILENAME)
|
||||
(MSFILETABLE))
|
||||
(INITVARS (MSFILETABLE))
|
||||
(* ; "To permit MSHASH interface")
|
||||
(LOCALVARS . T)
|
||||
(BLOCKS (LOADDB LOADDB DBFILE DBFILE1 DBFILE2 (NOLINKFNS . T)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T])
|
||||
|
||||
|
||||
|
||||
(* Does automatic Masterscope database maintenance)
|
||||
(* ;; "Does automatic Masterscope database maintenance")
|
||||
|
||||
(DECLARE%: FIRST
|
||||
|
||||
@@ -56,78 +58,81 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
(DEFINEQ
|
||||
|
||||
(DBFILE
|
||||
[LAMBDA (FILE ASKFLAG) (* lmm "29-APR-81 20:27")
|
||||
|
||||
(* Finds a database file that corresponds to the contents of FILE.
|
||||
Looks in directory of FILE, and also in the directory that file originally came
|
||||
from, if it was copied. Returns NIL if no database file is found, else
|
||||
(fulldbfilename . filedates)%, where filedates identifies the name under which
|
||||
the file that the database corresponds to is currently known.
|
||||
-
|
||||
If FILE doesn't have a version, tries to get database for version in core, or
|
||||
most recent version if it hasn't been loaded)
|
||||
[LAMBDA (FILE ASKFLAG) (* ; "Edited 24-Oct-2021 16:50 by rmk:")
|
||||
(* lmm "29-APR-81 20:27")
|
||||
|
||||
(* ;; "Finds a database file that corresponds to the contents of FILE. Looks in directory of FILE, and also in the directory that file originally came from, if it was copied. Returns NIL if no database file is found, else (fulldbfilename . filedates), where filedates identifies the name under which the file that the database corresponds to is currently known.")
|
||||
|
||||
(* ;; "If FILE doesn't have a version, tries to get database for version in core, or most recent version if it hasn't been loaded")
|
||||
|
||||
(DECLARE (GLOBALVARS COMPILE.EXT FILERDTBL))
|
||||
[COND
|
||||
((NULL FILE)
|
||||
(SETQ FILE (INPUT)))
|
||||
((EQ (FILENAMEFIELD FILE 'EXTENSION)
|
||||
COMPILE.EXT) (* Map compiled file into symbolic
|
||||
name)
|
||||
((MEMB (FILENAMEFIELD FILE 'EXTENSION)
|
||||
*COMPILED-EXTENSIONS*) (* ;
|
||||
"Map compiled file into symbolic name")
|
||||
(SETQ FILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY FILE]
|
||||
(PROG [(FILEDATES (COND
|
||||
[(AND (NULL (FILENAMEFIELD FILE 'VERSION))
|
||||
(CAR (GETPROP (NAMEFIELD FILE)
|
||||
'FILEDATES]
|
||||
([SETQ FILE (COND
|
||||
(ASKFLAG (INFILEP FILE))
|
||||
(T (FINDFILE FILE]
|
||||
(CONS (FILEDATE FILE)
|
||||
FILE]
|
||||
(AND FILEDATES (RETURN (DBFILE1 FILE FILEDATES])
|
||||
(LET [(FILEDATES (COND
|
||||
[(AND (NULL (FILENAMEFIELD FILE 'VERSION))
|
||||
(CAR (GETPROP (NAMEFIELD FILE)
|
||||
'FILEDATES]
|
||||
([SETQ FILE (COND
|
||||
(ASKFLAG (INFILEP FILE))
|
||||
(T (FINDFILE FILE]
|
||||
(CONS (FILEDATE FILE)
|
||||
FILE]
|
||||
(AND FILEDATES (DBFILE1 FILE FILEDATES])
|
||||
|
||||
(DBFILE1
|
||||
[LAMBDA (F FILEDATES) (* jds "25-Sep-86 20:04")
|
||||
|
||||
(* Searches databases based on F to find one that matches FILEDATES.
|
||||
Returns (dbfilename . filedates) if successful.
|
||||
For efficiency, checks the most likely highest version first, before doing the
|
||||
directory enumeration)
|
||||
[LAMBDA (F FILEDATES) (* ; "Edited 24-Oct-2021 15:43 by rmk:")
|
||||
(* jds "25-Sep-86 20:04")
|
||||
|
||||
(PROG ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F)))
|
||||
DBF)
|
||||
(RETURN (COND
|
||||
((NULL HIGHEST) (* ;
|
||||
"No file matches the name we gave, so punt.")
|
||||
NIL)
|
||||
((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.")
|
||||
(CONS DBF FILEDATES))
|
||||
(T (* ;
|
||||
"Hunt back thru back versions looking for a matching one.")
|
||||
(for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE
|
||||
'VERSION
|
||||
'*
|
||||
'BODY F)))
|
||||
when (SETQ DBF (DBFILE2 DBF FILEDATES))
|
||||
do (RETURN (CONS DBF FILEDATES])
|
||||
(* ;; "Searches databases based on F to find one that matches FILEDATES. Returns (dbfilename . filedates) if successful. For efficiency, checks the most likely highest version first, before doing the directory enumeration")
|
||||
|
||||
(LET ((HIGHEST (INFILEP (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION 'NIL 'BODY F)))
|
||||
DBF)
|
||||
(COND
|
||||
((NULL HIGHEST) (* ;
|
||||
"No file matches the name we gave, so punt.")
|
||||
NIL)
|
||||
((SETQ DBF (DBFILE2 HIGHEST FILEDATES)) (* ; "The most recent one matches.")
|
||||
(CONS DBF FILEDATES))
|
||||
(T (* ;
|
||||
"Hunt back thru back versions looking for a matching one.")
|
||||
(for DBF in (REMOVE HIGHEST (FILDIR (PACKFILENAME 'EXTENSION 'DATABASE
|
||||
'VERSION
|
||||
'*
|
||||
'BODY F)))
|
||||
when (SETQ DBF (DBFILE2 DBF FILEDATES))
|
||||
do (RETURN (CONS DBF FILEDATES])
|
||||
|
||||
(DBFILE2
|
||||
[LAMBDA (DBF FILEDATES) (* ; "Edited 28-Nov-90 12:42 by rmk:")
|
||||
(* T if DBF is the name of the
|
||||
database file matching FILEDATES)
|
||||
[LAMBDA (DBF FILEDATES) (* ;
|
||||
"Edited 24-Oct-2021 20:18 by rmk:")
|
||||
(* ; "Edited 28-Nov-90 12:42 by rmk:")
|
||||
|
||||
(* ;; "Returns an open stream for DBF if it's the name of the database file matching FILEDATES. DBF is positioned after all the header material, and the reader environment is set up for it.")
|
||||
|
||||
[RESETSAVE (SETQ DBF (OPENSTREAM DBF 'INPUT))
|
||||
'(PROGN (CLOSEF? OLDVALUE]
|
||||
(SET-READER-ENVIRONMENT (READ-READER-ENVIRONMENT DBF (MAKE-READER-ENVIRONMENT
|
||||
*NEW-INTERLISP-MAKEFILE-ENVIRONMENT*)
|
||||
)
|
||||
DBF)
|
||||
|
||||
(* The close is done in the LOADDB RESETLST, except when a candidate file isn't
|
||||
correct)
|
||||
(* ;; "Skip the header stuff")
|
||||
|
||||
(SKREAD DBF) (* Skip LOAD error message)
|
||||
(COND
|
||||
([STREQUAL (CAR FILEDATES)
|
||||
(CAR (READ DBF (FIND-READTABLE "INTERLISP"]
|
||||
DBF)
|
||||
(T (CLOSEF DBF)
|
||||
NIL])
|
||||
(CL:WHEN [OR (EQ 0 (GETFILEPTR DBF))
|
||||
(AND [EQ 'FILECREATED (CAR (LISTP (READ DBF]
|
||||
(EQ 'PRETTYCOMPRINT (CAR (LISTP (READ DBF]
|
||||
[EQ 'PROGN (CAR (LISTP (READ DBF]
|
||||
(COND
|
||||
((STREQUAL (CAR FILEDATES)
|
||||
(CAR (READ DBF)))
|
||||
DBF)
|
||||
(T (CLOSEF DBF)
|
||||
NIL)))])
|
||||
|
||||
(LOAD
|
||||
[LAMBDA (FILE LDFLG PRINTFLG) (* lmm "29-APR-81 20:27")
|
||||
@@ -156,88 +161,62 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
(DEFINEQ
|
||||
|
||||
(DUMPDB
|
||||
[LAMBDA (FILE PROPFLG) (* ; "Edited 3-May-93 18:44 by rmk:")
|
||||
[LAMBDA (FILE PROPFLG) (* ;
|
||||
"Edited 27-Oct-2021 10:51 by larry")
|
||||
(* ;
|
||||
"Edited 24-Oct-2021 16:24 by rmk:")
|
||||
|
||||
(* Dumps a Masterscope database for functions in FILE.
|
||||
Checks the DATABASE property if PROPFLG=T which is how the MAKEFILE advice
|
||||
calls it. A user-level call would default PROPFLG to NIL.)
|
||||
(* ;; "Dumps a Masterscope database for functions in FILE. Checks the DATABASE property if PROPFLG=T which is how the MAKEFILE advice calls it. A user-level call would default PROPFLG to NIL.")
|
||||
|
||||
(* The FILE check is because MAKEFILE returns a list when it doesn't understand
|
||||
the options)
|
||||
(* ;;
|
||||
"The FILE check is because MAKEFILE returns a list when it doesn't understand the options")
|
||||
|
||||
(DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE SAVEDBFLG))
|
||||
(AND FILE (OR (LITATOM FILE)
|
||||
(STRINGP FILE))
|
||||
(PROG (DBFILE (FL (NAMEFIELD FILE))
|
||||
FNS
|
||||
(FFNS (FILEFNSLST FILE)))
|
||||
(COND
|
||||
(FFNS)
|
||||
((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE)))
|
||||
(* Always dump if this is a known
|
||||
file)
|
||||
(SETQ PROPFLG NIL))
|
||||
(T (COND
|
||||
(PROPFLG (/REMPROP FL 'DATABASE))
|
||||
(T (printout T T FILE " has no functions." T)))
|
||||
(RETURN)))
|
||||
(SETQ FNS FFNS)
|
||||
(COND
|
||||
([OR (NULL PROPFLG)
|
||||
(EQ (GETPROP FL 'DATABASE)
|
||||
'YES)
|
||||
(EQ SAVEDBFLG 'YES)
|
||||
(AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE]
|
||||
(* If MSHASH is loaded, only dump
|
||||
functions in the local database)
|
||||
[COND
|
||||
(MSHASHFILENAME (SETQ FNS (for FN in FNS
|
||||
when (PROGN (UPDATEFN FN)
|
||||
(LOCALFNP FN)) collect FN]
|
||||
(RESETLST
|
||||
[RESETSAVE (SETQ DBFILE (OPENSTREAM (PACKFILENAME 'EXTENSION 'DATABASE
|
||||
'VERSION NIL 'BODY FILE)
|
||||
'OUTPUT
|
||||
'NEW))
|
||||
'(PROGN (CLOSEF? OLDVALUE)
|
||||
(AND RESETSTATE (DELFILE OLDVALUE]
|
||||
(RESETSAVE (OUTPUT DBFILE))
|
||||
(RESETSAVE (SETREADTABLE (FIND-READTABLE "INTERLISP")))
|
||||
(RESETSAVE (CL:IN-PACKAGE "INTERLISP")
|
||||
(LIST 'CL:IN-PACKAGE (CL:PACKAGE-NAME *PACKAGE*)))
|
||||
(PRIN1 "(PROGN (PRIN1 %"Use LOADDB to load database files!%
|
||||
%" T) (ERROR!))%
|
||||
"
|
||||
)
|
||||
[AND MSFILETABLE (STORETABLE FL MSFILETABLE (PRINT (CAR (GETPROP FL
|
||||
'FILEDATES]
|
||||
(COND
|
||||
(MSHASHFILENAME (UPDATECONTAINS FL FFNS T)))
|
||||
(* T flag means that the function
|
||||
won't be erased--it might still be
|
||||
interesting)
|
||||
(printout NIL "FNS " .P2 FFNS T) (* So the database file knows which
|
||||
functions are on the file)
|
||||
(COND
|
||||
(FNS (DUMPDATABASE FNS))
|
||||
(T (printout NIL "STOP" T))))
|
||||
[COND
|
||||
(PROPFLG (PRINT (FULLNAME DBFILE)
|
||||
T))
|
||||
(T (/PUT FL 'DATABASEFILENAME DBFILE) (* Remember that we have this file
|
||||
valid already.)
|
||||
(/PUT FL 'DATABASE 'YES] (* Take future note of the databae
|
||||
on a user call)
|
||||
(RETURN (FULLNAME DBFILE])
|
||||
(DECLARE (GLOBALVARS MSFILETABLE SAVEDBFLG))
|
||||
(CL:WHEN (AND FILE (OR (LITATOM FILE)
|
||||
(STRINGP FILE)))
|
||||
(PROG (DBFILE (FL (NAMEFIELD FILE))
|
||||
(FNS (FILEFNSLST FILE)))
|
||||
(COND
|
||||
(FNS)
|
||||
((AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE)))
|
||||
(* ;
|
||||
"Always dump if this is a known file")
|
||||
(SETQ PROPFLG NIL))
|
||||
(T (COND
|
||||
(PROPFLG (/REMPROP FL 'DATABASE))
|
||||
(T (printout T T FILE " has no functions." T)))
|
||||
(RETURN)))
|
||||
(CL:WHEN [OR (NULL PROPFLG)
|
||||
(EQ (GETPROP FL 'DATABASE)
|
||||
'YES)
|
||||
(EQ SAVEDBFLG 'YES)
|
||||
(AND MSFILETABLE (TESTTABLE FL (CADR MSFILETABLE]
|
||||
(CL:WHEN MSFILETABLE
|
||||
[STORETABLE FL MSFILETABLE (CAR (GETPROP FL 'FILEDATES])
|
||||
[SETQ DBFILE (PRETTYDEF NIL (PACKFILENAME 'EXTENSION 'DATABASE 'VERSION NIL
|
||||
'BODY FILE)
|
||||
`((P (PROGN (PRIN1 "Use LOADDB to load database files!" T)
|
||||
(ERROR!)))
|
||||
(E [PRINT (CAR (GETPROP ',FILE 'FILEDATES]
|
||||
(DUMPDATABASE ',FNS]
|
||||
[COND
|
||||
(PROPFLG (PRINT (FULLNAME DBFILE)
|
||||
T))
|
||||
(T (/PUT FL 'DATABASEFILENAME DBFILE) (* ;
|
||||
"Remember that we have this file valid already.")
|
||||
(/PUT FL 'DATABASE 'YES] (* ;
|
||||
"Take future note of the databae on a user call")
|
||||
(RETURN DBFILE))))])
|
||||
|
||||
(LOADDB
|
||||
[LAMBDA (FILE ASKFLAG) (* ; "Edited 7-Jul-92 09:57 by rmk:")
|
||||
[LAMBDA (FILE ASKFLAG) (* ; "Edited 24-Oct-2021 17:44 by rmk:")
|
||||
(* ; "Edited 7-Jul-92 09:57 by rmk:")
|
||||
|
||||
(* ;; "Loads the database file corresponding to FILE, asking for confirmation only if ASKFLAG is T, which is the case from the advice on LOAD but not from usual user-level calls. Before asking, it looks around first to see whether a database file of the appropriate name really exists.")
|
||||
(* ;; "Loads the database file corresponding to FILE, asking for confirmation only if ASKFLAG is T, which is the case from the advice on LOAD but not from usual user-level calls. Before asking, it looks around first to see whether a database file of the appropriate name really exists.")
|
||||
|
||||
(DECLARE (GLOBALVARS MSHASHFILENAME MSFILETABLE MSARGTABLE DWIMWAIT LOADDBFLG))
|
||||
(DECLARE (GLOBALVARS MSFILETABLE MSARGTABLE DWIMWAIT LOADDBFLG))
|
||||
(RESETLST
|
||||
[PROG* [TEM NEWFNS FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP"))
|
||||
[PROG* [TEM FORFILE (*READTABLE* (FIND-READTABLE "INTERLISP"))
|
||||
(*PACKAGE* (CL:FIND-PACKAGE "INTERLISP"))
|
||||
(NF (NAMEFIELD FILE))
|
||||
(DBSTREAM (DBFILE FILE ASKFLAG))
|
||||
@@ -253,8 +232,8 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
([COND
|
||||
[ASKFLAG (COND
|
||||
((EQ (GETPROP NF 'DATABASEFILENAME)
|
||||
DBFILE) (* ;
|
||||
"If the database for this very file has already been loaded, don't bother doing it again.")
|
||||
DBFILE) (* ;
|
||||
"If the database for this very file has already been loaded, don't bother doing it again.")
|
||||
(PRINTOUT T "Database " DBFILE " already loaded." T)
|
||||
NIL)
|
||||
(T (SELECTQ (GETPROP NF 'DATABASE)
|
||||
@@ -275,42 +254,37 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
NIL]
|
||||
(T (/PUT NF 'DATABASE 'YES]
|
||||
(LISPXPRINT (FULLNAME DBFILE)
|
||||
T) (* ; "DBSTREAM was opened in DBFILE")
|
||||
T) (* ; "DBSTREAM was opened in DBFILE")
|
||||
(RESETSAVE (INPUT DBSTREAM))
|
||||
[COND
|
||||
((EQ (SETQ TEM (READ))
|
||||
'FNS)
|
||||
(SETQ NEWFNS (READ))
|
||||
(READ) (* ; "Old format: thrown away")
|
||||
(COND
|
||||
((EQ (SETQ TEM (READ))
|
||||
'ARGS)
|
||||
[COND
|
||||
[MSHASHFILENAME (BIND F WHILE (SETQ F (READ))
|
||||
DO (STORETABLE F MSARGTABLE (READ]
|
||||
(T (WHILE (READ]
|
||||
(WHILE (READ))
|
||||
(SETQ TEM (READ]
|
||||
(COND
|
||||
((OR (EQ (CAR (LISTP TEM))
|
||||
'READATABASE)
|
||||
(EQ TEM 'STOP))
|
||||
(COND
|
||||
((NEQ TEM 'STOP) (* ; "It must be (READATABASE)")
|
||||
((NEQ TEM 'STOP) (* ; "It must be (READATABASE)")
|
||||
(READATABASE)))
|
||||
(COND
|
||||
(MSHASHFILENAME (UPDATECONTAINS NF NEWFNS)))
|
||||
(AND MSFILETABLE (STORETABLE NF MSFILETABLE FORFILE))
|
||||
(* ;
|
||||
"This is done whether or not there is a hashfile.")
|
||||
(UPDATEFILES) (* ;
|
||||
"Mark any edited fns as needing to be reanalyzed.")
|
||||
(* ;
|
||||
"This is done whether or not there is a hashfile.")
|
||||
(UPDATEFILES) (* ;
|
||||
"Mark any edited fns as needing to be reanalyzed.")
|
||||
(FOR FN IN (CDR (GETP NF 'FILE))
|
||||
WHEN (OR (EXPRP FN)
|
||||
(GETP FN 'EXPR)) DO (MSMARKCHANGED FN)))
|
||||
(T (PRINTOUT T T DBFILE " is not a database file!" T)
|
||||
(* ; "So that value of LOADDB is NIL")
|
||||
(* ; "So that value of LOADDB is NIL")
|
||||
(SETQ DBFILE NIL)))
|
||||
(/PUT NF 'DATABASEFILENAME DBFILE) (* ;
|
||||
"Remember the name of the database we just loaded.")
|
||||
(/PUT NF 'DATABASEFILENAME DBFILE) (* ;
|
||||
"Remember the name of the database we just loaded.")
|
||||
(RETURN (FULLNAME DBFILE])])
|
||||
|
||||
(MAKEDB
|
||||
@@ -345,14 +319,12 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
|
||||
(ADDTOVAR MAKEFILEFORMS (MAKEDB FILE))
|
||||
|
||||
|
||||
|
||||
(* To permit MSHASH interface)
|
||||
|
||||
|
||||
(RPAQ? MSHASHFILENAME )
|
||||
|
||||
(RPAQ? MSFILETABLE )
|
||||
|
||||
|
||||
|
||||
(* ; "To permit MSHASH interface")
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
@@ -367,7 +339,7 @@ Copyright (c) 1986, 1990, 1991, 1992, 1993 by Xerox Corporation. All rights res
|
||||
)
|
||||
(PUTPROPS DATABASEFNS COPYRIGHT ("Xerox Corporation" 1986 1990 1991 1992 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1637 6218 (DBFILE 1647 . 3295) (DBFILE1 3297 . 4820) (DBFILE2 4822 . 5584) (LOAD 5586
|
||||
. 5816) (LOADFROM 5818 . 6006) (MAKEFILE 6008 . 6216)) (6274 16706 (DUMPDB 6284 . 10572) (LOADDB
|
||||
10574 . 15618) (MAKEDB 15620 . 16704)))))
|
||||
(FILEMAP (NIL (1679 6704 (DBFILE 1689 . 3334) (DBFILE1 3336 . 4846) (DBFILE2 4848 . 6070) (LOAD 6072
|
||||
. 6302) (LOADFROM 6304 . 6492) (MAKEFILE 6494 . 6702)) (6760 15499 (DUMPDB 6770 . 9534) (LOADDB 9536
|
||||
. 14411) (MAKEDB 14413 . 15497)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
155
library/LLCOLOR
155
library/LLCOLOR
@@ -1,15 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "10-Jul-92 14:57:14" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>LLCOLOR.;6| 137483
|
||||
|
||||
changes to%: (VARS LLCOLORCOMS)
|
||||
(MACROS .DRAW4BPPLINEX. .DRAW8BPPLINEX .DRAW24BPPLINEX .DRAW4BPPLINEY.
|
||||
.DRAW8BPPLINEY .DRAW24BPPLINEY)
|
||||
(FILECREATED "26-Oct-2021 10:53:47" {DSK}<home>larry>medley>library>LLCOLOR.;2 137753
|
||||
|
||||
previous date%: "21-Aug-91 12:27:17" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>LLCOLOR.;5|)
|
||||
changes to%: (FNS \COLORDISPLAYBITS \DRAW8BPPCOLORLINE)
|
||||
|
||||
previous date%: "10-Jul-92 14:57:14" {DSK}<home>larry>medley>library>LLCOLOR.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1982-1992 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LLCOLORCOMS)
|
||||
@@ -51,7 +50,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(FNS PSEUDOCOLOR \PSEUDOCOLOR.BITMAP \PSEUDOCOLOR.UFN)
|
||||
(GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP)
|
||||
(P
|
||||
(* ;; "NOTE: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *")
|
||||
(* ;; "NOTE: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *")
|
||||
|
||||
(SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL)
|
||||
(SETQ MENUFONT (FONTCREATE 'HELVETICA 10)))
|
||||
@@ -290,7 +289,10 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
ColorScreenBitMap])
|
||||
|
||||
(\COLORDISPLAYBITS
|
||||
[LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* ; "Edited 31-Oct-89 10:25 by takeshi")
|
||||
[LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* ;
|
||||
"Edited 26-Oct-2021 10:24 by larry")
|
||||
(* ;
|
||||
"Edited 31-Oct-89 10:25 by takeshi")
|
||||
(* returns a pointer to the bits
|
||||
that the color board needs.)
|
||||
(DECLARE (GLOBALVARS \COLORDISPLAYBITS))
|
||||
@@ -300,8 +302,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(OR (\MAIKO.CGSIXP)
|
||||
(\MAIKO.CGTHREEP)
|
||||
(\MAIKO.CGFOURP)))
|
||||
(PROG [(DUMMY (\ALLOCPAGEBLOCK 1))
|
||||
(ADDROFFSET ((OPCODES SUBRCALL 139 0]
|
||||
(PROG ((DUMMY (\ALLOCPAGEBLOCK 1))
|
||||
(ADDROFFSET (SUBRCALL COLOR-BASE)))
|
||||
(WHILE (NEQ (LOGAND \MAIKO.COLORBUF.ALIGN (IPLUS (\LOLOC DUMMY)
|
||||
ADDROFFSET))
|
||||
0) DO (SETQ DUMMY (\ALLOCPAGEBLOCK 1)))
|
||||
@@ -663,10 +665,13 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(.DRAW4BPPLINEY. MODE])
|
||||
|
||||
(\DRAW8BPPCOLORLINE
|
||||
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
|
||||
(* ; "Edited 19-Mar-91 12:46 by matsuda")
|
||||
((OPCODES SUBRCALL 143 12)
|
||||
X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR])
|
||||
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
|
||||
(* ;
|
||||
"Edited 26-Oct-2021 10:25 by larry")
|
||||
(* ;
|
||||
"Edited 19-Mar-91 12:46 by matsuda")
|
||||
(SUBRCALL COLOR-8BPPDRAWLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR
|
||||
])
|
||||
|
||||
(\DRAW24BPPCOLORLINE
|
||||
[LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
|
||||
@@ -705,7 +710,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
[(MODE)
|
||||
(PROG (INSIDEBITS OUTSIDEBITS)
|
||||
(until (IGREATERP X0 XLIMIT)
|
||||
do (* main loop)
|
||||
do (* main loop)
|
||||
(SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR)))
|
||||
(SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK)
|
||||
(fetch (BITMAPWORD BITS) of MAPPTR)))
|
||||
@@ -717,9 +722,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
OUTSIDEBITS))
|
||||
(PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS)
|
||||
OUTSIDEBITS))
|
||||
(PROGN (* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(PROGN (* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(LOGOR COLORMASK OUTSIDEBITS]
|
||||
[COND
|
||||
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
|
||||
@@ -732,7 +737,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
YINC]
|
||||
[COND
|
||||
[(ZEROP (SETQ MASK (LRSH MASK 4)))
|
||||
(* crossed word boundary)
|
||||
(* crossed word boundary)
|
||||
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET]
|
||||
(SETQ COLORMASK COLORMASKORG)
|
||||
(SETQ MASK (CONSTANT (\4BITMASK 0]
|
||||
@@ -744,7 +749,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(COND
|
||||
((EQ STARTBYTE 1)
|
||||
(GO 1LP)))
|
||||
0LP (* main loop)
|
||||
0LP (* main loop)
|
||||
(\PUTBASEBYTE MAPPTR 0
|
||||
(SELECTQ MODE
|
||||
(ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0)
|
||||
@@ -753,9 +758,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
)))
|
||||
(PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0)))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
[COND
|
||||
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
|
||||
@@ -779,9 +784,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
)))
|
||||
(PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1)))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
[COND
|
||||
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
|
||||
@@ -802,7 +807,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(GO 0LP))))
|
||||
|
||||
(PUTPROPS .DRAW24BPPLINEX MACRO ((MODE)
|
||||
(PROG NIL (* main loop)
|
||||
(PROG NIL (* main loop)
|
||||
LP (\PUTBASE24 MAPPTR 0
|
||||
(SELECTQ MODE
|
||||
(ERASE (LOGAND COLOR (\GETBASE24 MAPPTR
|
||||
@@ -812,9 +817,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(PAINT (LOGOR COLOR (\GETBASE24 MAPPTR
|
||||
0)))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
[COND
|
||||
([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
|
||||
@@ -838,7 +843,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
[(MODE)
|
||||
(PROG (INSIDEBITS OUTSIDEBITS)
|
||||
(until (IGREATERP Y0 YLIMIT)
|
||||
do (* main loop)
|
||||
do (* main loop)
|
||||
(SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR)))
|
||||
(SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK)
|
||||
(fetch (BITMAPWORD BITS) of MAPPTR)))
|
||||
@@ -850,9 +855,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
OUTSIDEBITS))
|
||||
(PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS)
|
||||
OUTSIDEBITS))
|
||||
(PROGN (* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(PROGN (* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(LOGOR COLORMASK OUTSIDEBITS]
|
||||
[COND
|
||||
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
|
||||
@@ -863,7 +868,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(SETQ CDL (IDIFFERENCE CDL DY))
|
||||
(COND
|
||||
[(ZEROP (SETQ MASK (LRSH MASK 4)))
|
||||
(* crossed word boundary)
|
||||
(* crossed word boundary)
|
||||
[SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET
|
||||
]
|
||||
(SETQ COLORMASK COLORMASKORG)
|
||||
@@ -877,7 +882,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(COND
|
||||
((EQ STARTBYTE 1)
|
||||
(GO 1LP)))
|
||||
0LP (* main loop)
|
||||
0LP (* main loop)
|
||||
(\PUTBASEBYTE MAPPTR 0
|
||||
(SELECTQ MODE
|
||||
(ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0)
|
||||
@@ -886,9 +891,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
)))
|
||||
(PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0)))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
(COND
|
||||
((IGREATERP (SETQ Y0 (ADD1 Y0))
|
||||
@@ -899,8 +904,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
YINC]
|
||||
(COND
|
||||
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(COND
|
||||
((IGREATERP (SETQ X0 (ADD1 X0))
|
||||
XLIMIT)
|
||||
@@ -916,9 +921,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
)))
|
||||
(PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1)))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
(COND
|
||||
((IGREATERP (SETQ Y0 (ADD1 Y0))
|
||||
@@ -929,8 +934,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
YINC]
|
||||
(COND
|
||||
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(COND
|
||||
((IGREATERP (SETQ X0 (ADD1 X0))
|
||||
XLIMIT)
|
||||
@@ -947,7 +952,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(COND
|
||||
((EQ STARTBYTE 1)
|
||||
(GO 1LP)))
|
||||
0LP (* main loop)
|
||||
0LP (* main loop)
|
||||
(\PUTBASEBYTE MAPPTR 0
|
||||
(SELECTQ MODE
|
||||
(ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0
|
||||
@@ -957,9 +962,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0)
|
||||
))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
(COND
|
||||
((IGREATERP (SETQ Y0 (ADD1 Y0))
|
||||
@@ -970,8 +975,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
YINC]
|
||||
(COND
|
||||
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(COND
|
||||
((IGREATERP (SETQ X0 (ADD1 X0))
|
||||
XLIMIT)
|
||||
@@ -988,9 +993,9 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1)
|
||||
))
|
||||
(PROGN
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
(* case is REPLACE.
|
||||
Legality of OPERATION has been
|
||||
checked by \CLIPANDDRAWLINE1)
|
||||
COLOR)))
|
||||
(COND
|
||||
((IGREATERP (SETQ Y0 (ADD1 Y0))
|
||||
@@ -1001,8 +1006,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
YINC]
|
||||
(COND
|
||||
([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(* moved enough in Y to move a point
|
||||
in X)
|
||||
(COND
|
||||
((IGREATERP (SETQ X0 (ADD1 X0))
|
||||
XLIMIT)
|
||||
@@ -2211,7 +2216,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
)
|
||||
|
||||
|
||||
(* ;; "NOTE: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *")
|
||||
(* ;; "NOTE: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *")
|
||||
|
||||
|
||||
(SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL)
|
||||
@@ -2228,22 +2233,22 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992 b
|
||||
(PUTPROPS LLCOLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991
|
||||
1992))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3539 21062 (COLORDISPLAY 3549 . 6952) (COLORMAPBITS 6954 . 7111) (
|
||||
\CreateColorScreenBitMap 7113 . 8484) (\CREATECOLORDISPLAYFDEV 8486 . 9444) (COLORMAP 9446 . 10860) (
|
||||
COLORMAPCOPY 10862 . 11382) (SCREENCOLORMAP 11384 . 11578) (SCREENCOLORMAPENTRY 11580 . 11807) (
|
||||
ROTATECOLORMAP 11809 . 12701) (RGBCOLORMAP 12703 . 14841) (CMYCOLORMAP 14843 . 15333) (GRAYCOLORMAP
|
||||
15335 . 16293) (COLORSCREENBITMAP 16295 . 16533) (\COLORDISPLAYBITS 16535 . 19180) (COLORSCREEN 19182
|
||||
. 19310) (SHOWCOLORTESTPATTERN 19312 . 21060)) (21101 21732 (\STARTCOLOR 21111 . 21249) (\STOPCOLOR
|
||||
21251 . 21387) (\SENDCOLORMAPENTRY 21389 . 21730)) (21733 27692 (COLORMAPCREATE 21743 . 22729) (
|
||||
COLORLEVEL 22731 . 23712) (COLORNUMBERP 23714 . 25298) (COLORFROMRGB 25300 . 26482) (
|
||||
INTENSITIESFROMCOLORMAP 26484 . 26869) (SETCOLORINTENSITY 26871 . 27690)) (27693 33530 (\FAST8BIT
|
||||
27703 . 31402) (\MAP4 31404 . 32283) (\MAP8 32285 . 33528)) (33531 34438 (\GETCOLORBRUSH 33541 . 34436
|
||||
)) (34439 38686 (\DRAWCOLORLINE1 34449 . 35191) (\DRAW4BPPCOLORLINE 35193 . 36838) (\DRAW8BPPCOLORLINE
|
||||
36840 . 37160) (\DRAW24BPPCOLORLINE 37162 . 38684)) (62183 120797 (\BWTOCOLORBLT 62193 . 70344) (
|
||||
\4BITLINEBLT 70346 . 104918) (\8BITLINEBLT 104920 . 113861) (\24BITLINEBLT 113863 . 114646) (
|
||||
\GETBASE24 114648 . 116106) (\PUTBASE24 116108 . 117716) (COLORTEXTUREFROMCOLOR# 117718 . 120341) (
|
||||
\BITMAPWORD 120343 . 120795)) (120798 126101 (COLORIZEBITMAP 120808 . 121783) (UNCOLORIZEBITMAP 121785
|
||||
. 126099)) (126189 129506 (COLORMENU 126199 . 129118) (CURSORCOLOR 129120 . 129504)) (132029 136501 (
|
||||
PSEUDOCOLOR 132039 . 134952) (\PSEUDOCOLOR.BITMAP 134954 . 135183) (\PSEUDOCOLOR.UFN 135185 . 136499))
|
||||
(FILEMAP (NIL (3332 21090 (COLORDISPLAY 3342 . 6745) (COLORMAPBITS 6747 . 6904) (
|
||||
\CreateColorScreenBitMap 6906 . 8277) (\CREATECOLORDISPLAYFDEV 8279 . 9237) (COLORMAP 9239 . 10653) (
|
||||
COLORMAPCOPY 10655 . 11175) (SCREENCOLORMAP 11177 . 11371) (SCREENCOLORMAPENTRY 11373 . 11600) (
|
||||
ROTATECOLORMAP 11602 . 12494) (RGBCOLORMAP 12496 . 14634) (CMYCOLORMAP 14636 . 15126) (GRAYCOLORMAP
|
||||
15128 . 16086) (COLORSCREENBITMAP 16088 . 16326) (\COLORDISPLAYBITS 16328 . 19208) (COLORSCREEN 19210
|
||||
. 19338) (SHOWCOLORTESTPATTERN 19340 . 21088)) (21129 21760 (\STARTCOLOR 21139 . 21277) (\STOPCOLOR
|
||||
21279 . 21415) (\SENDCOLORMAPENTRY 21417 . 21758)) (21761 27720 (COLORMAPCREATE 21771 . 22757) (
|
||||
COLORLEVEL 22759 . 23740) (COLORNUMBERP 23742 . 25326) (COLORFROMRGB 25328 . 26510) (
|
||||
INTENSITIESFROMCOLORMAP 26512 . 26897) (SETCOLORINTENSITY 26899 . 27718)) (27721 33558 (\FAST8BIT
|
||||
27731 . 31430) (\MAP4 31432 . 32311) (\MAP8 32313 . 33556)) (33559 34466 (\GETCOLORBRUSH 33569 . 34464
|
||||
)) (34467 38956 (\DRAWCOLORLINE1 34477 . 35219) (\DRAW4BPPCOLORLINE 35221 . 36866) (\DRAW8BPPCOLORLINE
|
||||
36868 . 37430) (\DRAW24BPPCOLORLINE 37432 . 38954)) (62453 121067 (\BWTOCOLORBLT 62463 . 70614) (
|
||||
\4BITLINEBLT 70616 . 105188) (\8BITLINEBLT 105190 . 114131) (\24BITLINEBLT 114133 . 114916) (
|
||||
\GETBASE24 114918 . 116376) (\PUTBASE24 116378 . 117986) (COLORTEXTUREFROMCOLOR# 117988 . 120611) (
|
||||
\BITMAPWORD 120613 . 121065)) (121068 126371 (COLORIZEBITMAP 121078 . 122053) (UNCOLORIZEBITMAP 122055
|
||||
. 126369)) (126459 129776 (COLORMENU 126469 . 129388) (CURSORCOLOR 129390 . 129774)) (132299 136771 (
|
||||
PSEUDOCOLOR 132309 . 135222) (\PSEUDOCOLOR.BITMAP 135224 . 135453) (\PSEUDOCOLOR.UFN 135455 . 136769))
|
||||
)))
|
||||
STOP
|
||||
|
||||
@@ -1,14 +1,20 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "23-Oct-91 14:43:35" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MAIKOCOLOR.;6| 57582
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Oct-2021 10:53:57" {DSK}<home>larry>medley>library>MAIKOCOLOR.;2 60141
|
||||
|
||||
changes to%: (VARS MAIKOCOLORCOMS)
|
||||
(FNS \MAIKOCOLOR.EVENTFN)
|
||||
(MACROS \MAIKO.CGTHREEP \MAIKO.CGFOURP \MAIKO.CGSIXP \MAIKO.CGTWOP)
|
||||
(FNS \MAIKO.COLORINIT \MAIKO.STARTCOLOR \MAIKO.STOPCOLOR \MAIKOCOLOR.EVENTFN
|
||||
\MAIKO.SENDCOLORMAPENTRY \MAIKO.CHANGESCREEN CURSOREXIT CURSORSCREEN
|
||||
WARPCURSOR \SLOWBLTCHAR \SOFTCURSORUP \BITBLT.DISPLAY \PUNT.SLOWBLTCHAR
|
||||
\PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP BITMAPOBJ.SNAPW \MAIKO.PUNTBLTCHAR
|
||||
\MAIKO.BLTCHAR)
|
||||
|
||||
previous date%: "22-Aug-91 17:11:25" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MAIKOCOLOR.;3|)
|
||||
previous date%: "23-Oct-91 14:43:35" {DSK}<home>larry>medley>library>MAIKOCOLOR.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserved.
|
||||
Copyright (c) 1988-1991 by Fuji Xerox Co., Ltd..
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT MAIKOCOLORCOMS)
|
||||
@@ -63,8 +69,9 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
|
||||
(\MAIKO.COLORINIT
|
||||
[LAMBDA NIL
|
||||
(DECLARE (GLOBALVARS \MAIKOCOLORWSOPS \MAIKOCOLORINFO))
|
||||
(* ; "Edited 28-Apr-89 16:51 by tshimizu.fx")
|
||||
(DECLARE (GLOBALVARS \MAIKOCOLORWSOPS \MAIKOCOLORINFO))
|
||||
(* ;
|
||||
"Edited 28-Apr-89 16:51 by tshimizu.fx")
|
||||
(SETQ \MAIKOCOLORWSOPS (create WSOPS
|
||||
STARTBOARD _ (FUNCTION NILL)
|
||||
STARTCOLOR _ (FUNCTION \MAIKO.STARTCOLOR)
|
||||
@@ -82,7 +89,10 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(\DEFINEDISPLAYINFO \MAIKOCOLORINFO])
|
||||
|
||||
(\MAIKO.STARTCOLOR
|
||||
[LAMBDA (FDEV) (* ; "Edited 2-Nov-88 11:13 by shimizu")
|
||||
[LAMBDA (FDEV) (* ;
|
||||
"Edited 26-Oct-2021 10:17 by larry")
|
||||
(* ;
|
||||
"Edited 2-Nov-88 11:13 by shimizu")
|
||||
(PROG (DISPLAYSTATE)
|
||||
(SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
|
||||
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STARTCOLOR)
|
||||
@@ -90,19 +100,19 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
|
||||
(* ;; " MMAP colorbuffer")
|
||||
|
||||
((OPCODES SUBRCALL 136 1)
|
||||
(FETCH (BITMAP BITMAPBASE) OF ColorScreenBitMap))
|
||||
(SUBRCALL COLOR-INIT (FETCH (BITMAP BITMAPBASE) OF ColorScreenBitMap))
|
||||
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'ON])
|
||||
|
||||
(\MAIKO.STOPCOLOR
|
||||
[LAMBDA (FDEV) (* ; "Edited 28-Apr-89 16:51 by tshimizu.fx")
|
||||
[LAMBDA (FDEV) (* ;
|
||||
"Edited 28-Apr-89 16:51 by tshimizu.fx")
|
||||
(* ; "By Take")
|
||||
(PROG (DISPLAYSTATE)
|
||||
(SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
|
||||
(replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'OFF])
|
||||
|
||||
(\MAIKOCOLOR.EVENTFN
|
||||
[LAMBDA (FDEV EVENT) (* ; "Edited 23-Oct-91 14:18 by jds")
|
||||
[LAMBDA (FDEV EVENT) (* ; "Edited 23-Oct-91 14:18 by jds")
|
||||
(COND
|
||||
((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV))
|
||||
'ON)
|
||||
@@ -117,22 +127,26 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
NIL])
|
||||
|
||||
(\MAIKO.SENDCOLORMAPENTRY
|
||||
[LAMBDA (FDEV COLOR# RGB) (* ; "Edited 1-Dec-88 18:16 by shimizu")
|
||||
((OPCODES SUBRCALL 138 4)
|
||||
COLOR#
|
||||
(CAR RGB)
|
||||
(CADR RGB)
|
||||
(CADDR RGB])
|
||||
[LAMBDA (FDEV COLOR# RGB) (* ;
|
||||
"Edited 26-Oct-2021 10:17 by larry")
|
||||
(* ;
|
||||
"Edited 1-Dec-88 18:16 by shimizu")
|
||||
(SUBRCALL COLOR-MAP COLOR# (CAR RGB)
|
||||
(CADR RGB)
|
||||
(CADDR RGB])
|
||||
|
||||
(\MAIKO.CHANGESCREEN
|
||||
[LAMBDA (TOSCREEN) (* ; "Edited 1-Dec-88 18:32 by shimizu")
|
||||
((OPCODES SUBRCALL 137 1)
|
||||
TOSCREEN])
|
||||
[LAMBDA (TOSCREEN) (* ;
|
||||
"Edited 26-Oct-2021 10:18 by larry")
|
||||
(* ;
|
||||
"Edited 1-Dec-88 18:32 by shimizu")
|
||||
(SUBRCALL COLOR-SCREENMODE TOSCREEN])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(CURSOREXIT
|
||||
[LAMBDA NIL (* ; "Edited 11-Aug-89 13:16 by takeshi")
|
||||
[LAMBDA NIL (* ;
|
||||
"Edited 11-Aug-89 13:16 by takeshi")
|
||||
|
||||
(* * called when cursor moves off the screen edge)
|
||||
|
||||
@@ -160,7 +174,8 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(CURSORSCREEN SCREEN2 XCOORD2 YCOORD2])
|
||||
|
||||
(CURSORSCREEN
|
||||
[LAMBDA (SCREEN XCOORD YCOORD) (* ; "Edited 19-Jun-90 16:33 by matsuda")
|
||||
[LAMBDA (SCREEN XCOORD YCOORD) (* ;
|
||||
"Edited 19-Jun-90 16:33 by matsuda")
|
||||
|
||||
(* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos
|
||||
of cursor on SCREEN)
|
||||
@@ -201,7 +216,8 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(CLEARW W))])
|
||||
|
||||
(WARPCURSOR
|
||||
[LAMBDA (ENABLE) (* ; "Edited 20-Jul-90 19:02 by matsuda")
|
||||
[LAMBDA (ENABLE) (* ;
|
||||
"Edited 20-Jul-90 19:02 by matsuda")
|
||||
(COND
|
||||
(ENABLE (MOVD 'SAVE.CURSOREXIT 'CURSOREXIT)
|
||||
T)
|
||||
@@ -209,12 +225,15 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
NIL])
|
||||
|
||||
(\SLOWBLTCHAR
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 7-Jun-90 14:06 by matsuda")
|
||||
((OPCODES SUBRCALL 140 2)
|
||||
CHARCODE DISPLAYSTREAM])
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM) (* ;
|
||||
"Edited 26-Oct-2021 10:19 by larry")
|
||||
(* ;
|
||||
"Edited 7-Jun-90 14:06 by matsuda")
|
||||
(SUBRCALL C-SlowBltChar CHARCODE DISPLAYSTREAM])
|
||||
|
||||
(\SOFTCURSORUP
|
||||
[LAMBDA (NEWCURSOR) (* ; "Edited 16-Jan-89 15:44 by shimizu")
|
||||
[LAMBDA (NEWCURSOR) (* ;
|
||||
"Edited 16-Jan-89 15:44 by shimizu")
|
||||
(* Put soft NEWCURSOR up, assuming
|
||||
soft cursor is down.
|
||||
*)
|
||||
@@ -290,7 +309,8 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(\BITBLT.DISPLAY
|
||||
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
|
||||
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
|
||||
CLIPPEDSOURCEBOTTOM) (* ; "Edited 24-Jan-91 11:57 by matsuda")
|
||||
CLIPPEDSOURCEBOTTOM) (* ;
|
||||
"Edited 24-Jan-91 11:57 by matsuda")
|
||||
(DECLARE (LOCALVARS . T))
|
||||
(DECLARE (GLOBALVARS \SYSPILOTBBT \SCREENBITMAPS \BBSCRATCHTEXTURE \SOFTCURSORP
|
||||
\SOFTCURSORUPP \CURSORDESTINATION))
|
||||
@@ -454,7 +474,8 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(DEFINEQ
|
||||
|
||||
(\PUNT.SLOWBLTCHAR
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 2-Jul-90 14:23 by matsuda")
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM) (* ;
|
||||
"Edited 2-Jul-90 14:23 by matsuda")
|
||||
|
||||
(* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset")
|
||||
|
||||
@@ -535,7 +556,10 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(T (ERROR "Not implemented to rotate by other than 0, 90 or 270"])
|
||||
|
||||
(\MAIKO.PUNTBLTCHAR
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 1-Nov-89 15:26 by takeshi")
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ;
|
||||
"Edited 26-Oct-2021 10:21 by larry")
|
||||
(* ;
|
||||
"Edited 1-Nov-89 15:26 by takeshi")
|
||||
|
||||
(* ;; "puts a character on a display stream. This function will be called when \maiko.bltchar failed. Punt from subr call")
|
||||
|
||||
@@ -598,20 +622,23 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
DDPILOTBBT)
|
||||
of DISPLAYDATA)))
|
||||
0)))
|
||||
(.WHILE.TOP.DS. DISPLAYSTREAM ((OPCODES SUBRCALL 70 6)
|
||||
LOCAL1 DISPLAYDATA CHAR8CODE CURX LEFT RIGHT))
|
||||
(.WHILE.TOP.DS. DISPLAYSTREAM (SUBRCALL BLTCHAR LOCAL1 DISPLAYDATA CHAR8CODE
|
||||
CURX LEFT RIGHT))
|
||||
T])
|
||||
|
||||
(\MAIKO.BLTCHAR
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 6-Jul-90 10:14 by matsuda")
|
||||
((OPCODES SUBRCALL 135 3)
|
||||
CHARCODE DISPLAYSTREAM DISPLAYDATA])
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ;
|
||||
"Edited 26-Oct-2021 10:22 by larry")
|
||||
(* ;
|
||||
"Edited 6-Jul-90 10:14 by matsuda")
|
||||
(SUBRCALL NEW-BLTCHAR CHARCODE DISPLAYSTREAM DISPLAYDATA])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\PUNT.BLTSHADE.BITMAP
|
||||
[LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION
|
||||
CLIPPINGREGION) (* ; "Edited 5-Jun-90 12:12 by Takeshi")
|
||||
CLIPPINGREGION) (* ;
|
||||
"Edited 5-Jun-90 12:12 by Takeshi")
|
||||
|
||||
(* ;; "This FNS is for a punt case of \BLTSHADE.BITMAP which is implemeted in C ")
|
||||
(* ;
|
||||
@@ -718,7 +745,8 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(\PUNT.BITBLT.BITMAP
|
||||
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
|
||||
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
|
||||
CLIPPEDSOURCEBOTTOM) (* ; "Edited 5-Jun-90 11:59 by Takeshi")
|
||||
CLIPPEDSOURCEBOTTOM) (* ;
|
||||
"Edited 5-Jun-90 11:59 by Takeshi")
|
||||
|
||||
(* ;; " This FNS is for a punt case of \BITBLT.BITMAP which is implemeted in C")
|
||||
|
||||
@@ -858,7 +886,8 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
(DEFINEQ
|
||||
|
||||
(BITMAPOBJ.SNAPW
|
||||
[LAMBDA NIL (* ; "Edited 12-Apr-90 09:09 by matsuda")
|
||||
[LAMBDA NIL (* ;
|
||||
"Edited 12-Apr-90 09:09 by matsuda")
|
||||
|
||||
(* * makes an image object of a prompted for region of the screen.)
|
||||
|
||||
@@ -962,11 +991,11 @@ Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserv
|
||||
)
|
||||
(PUTPROPS MAIKOCOLOR COPYRIGHT ("Fuji Xerox Co., Ltd." 1988 1989 1990 1991))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2782 5984 (\MAIKO.COLORINIT 2792 . 3962) (\MAIKO.STARTCOLOR 3964 . 4559) (
|
||||
\MAIKO.STOPCOLOR 4561 . 4945) (\MAIKOCOLOR.EVENTFN 4947 . 5578) (\MAIKO.SENDCOLORMAPENTRY 5580 . 5805)
|
||||
(\MAIKO.CHANGESCREEN 5807 . 5982)) (5985 26414 (CURSOREXIT 5995 . 7433) (CURSORSCREEN 7435 . 9475) (
|
||||
WARPCURSOR 9477 . 9726) (\SLOWBLTCHAR 9728 . 9910) (\SOFTCURSORUP 9912 . 15707) (\BITBLT.DISPLAY 15709
|
||||
. 26412)) (26485 37922 (\PUNT.SLOWBLTCHAR 26495 . 33267) (\MAIKO.PUNTBLTCHAR 33269 . 37722) (
|
||||
\MAIKO.BLTCHAR 37724 . 37920)) (37923 54124 (\PUNT.BLTSHADE.BITMAP 37933 . 44959) (\PUNT.BITBLT.BITMAP
|
||||
44961 . 54122)) (54125 54867 (BITMAPOBJ.SNAPW 54135 . 54865)))))
|
||||
(FILEMAP (NIL (3229 7254 (\MAIKO.COLORINIT 3239 . 4475) (\MAIKO.STARTCOLOR 4477 . 5293) (
|
||||
\MAIKO.STOPCOLOR 5295 . 5749) (\MAIKOCOLOR.EVENTFN 5751 . 6382) (\MAIKO.SENDCOLORMAPENTRY 6384 . 6842)
|
||||
(\MAIKO.CHANGESCREEN 6844 . 7252)) (7255 28244 (CURSOREXIT 7265 . 8769) (CURSORSCREEN 8771 . 10877) (
|
||||
WARPCURSOR 10879 . 11194) (\SLOWBLTCHAR 11196 . 11608) (\SOFTCURSORUP 11610 . 17471) (\BITBLT.DISPLAY
|
||||
17473 . 28242)) (28315 40283 (\PUNT.SLOWBLTCHAR 28325 . 35163) (\MAIKO.PUNTBLTCHAR 35165 . 39855) (
|
||||
\MAIKO.BLTCHAR 39857 . 40281)) (40284 56617 (\PUNT.BLTSHADE.BITMAP 40294 . 47386) (\PUNT.BITBLT.BITMAP
|
||||
47388 . 56615)) (56618 57426 (BITMAPOBJ.SNAPW 56628 . 57424)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,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)
|
||||
(VARS BACKGROUND-YIELDCOMS)
|
||||
(FILECREATED "14-Nov-2021 22:05:58" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;2 1597
|
||||
|
||||
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)
|
||||
@@ -44,7 +44,7 @@
|
||||
(INIT-YIELD T)
|
||||
)
|
||||
|
||||
(RPAQQ BACKGROUND-YIELD 8333330)
|
||||
(RPAQQ BACKGROUND-YIELD 833333)
|
||||
(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
|
||||
|
||||
Binary file not shown.
207
lispusers/TMAX
207
lispusers/TMAX
@@ -1,22 +1,26 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "19-May-99 08:41:45" {DSK}<project>medley3.5>lispusers>TMAX.;5 28668
|
||||
|
||||
changes to%: (MACROS MAKE.XREFOBJ.IMAGEFNS)
|
||||
(FILECREATED "24-Oct-2021 23:45:20"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX.;4 31402
|
||||
|
||||
previous date%: "18-May-99 22:44:24" {DSK}<project>medley3.5>lispusers>TMAX.;3)
|
||||
changes to%: (VARS TMAXCOMS)
|
||||
(FNS GET.TSP.FONT.FAMILY)
|
||||
|
||||
previous date%: "24-Oct-2021 22:06:32"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
Copyright (c) 1987, 1997, 1999 by Stanford University.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT TMAXCOMS)
|
||||
|
||||
(RPAQQ TMAXCOMS
|
||||
( (* ;
|
||||
"Developed under support from NIH grant RR-00785.")
|
||||
(* ;
|
||||
"Written by Frank Gilmurray and Sami Shaio.")
|
||||
( (* ;
|
||||
"Developed under support from NIH grant RR-00785.")
|
||||
(* ;
|
||||
"Written by Frank Gilmurray and Sami Shaio.")
|
||||
(FILES (COMPILED SYSLOAD)
|
||||
TEDIT FREEMENU)
|
||||
(VARS TMAX.FILE.LIST)
|
||||
@@ -27,38 +31,38 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(P (DOFILESLOAD TMAX.FILE.LIST))
|
||||
|
||||
|
||||
(* ;;; "Free Menu data structures")
|
||||
(* ;;; "Free Menu data structures")
|
||||
|
||||
(VARS TSP.FM.DESC IMAGEOBJ.MENU.ITEMS)
|
||||
|
||||
|
||||
(* ;;; "Free Menu functions")
|
||||
(* ;;; "Free Menu functions")
|
||||
|
||||
(FNS TSP.DISPLAY.FMMENU TSP.SETUP.FILENAMES TSP.SETUP.FMMENU TSP.FMMENU TSP.FM.APPLY
|
||||
UPDATE.ALL DOWNDATE.ALL TSP.FUNCTION.HOOKS TSP.GETFN TSP.PUTFN)
|
||||
|
||||
|
||||
(* ;;; "Free Menu toggle functions")
|
||||
(* ;;; "Free Menu toggle functions")
|
||||
|
||||
(FNS AutoUpdate.TOGGLE UPDATE? NGROUP.Menu.TOGGLE NGROUPMENU.ENABLED?
|
||||
NGROUP.Text-Before.TOGGLE TEXTBEFORE.ENABLED? NGROUP.Text-After.TOGGLE
|
||||
TEXTAFTER.ENABLED? Manual.Index.TOGGLE MANUALINDEX.ENABLED?)
|
||||
|
||||
|
||||
(* ;;; "TSP font stuff")
|
||||
(* ;;; "TSP font stuff")
|
||||
|
||||
(FNS GET.TSP.FONT GET.TSP.FONT.FAMILY GET.TSP.FONT.SIZE GET.TSP.FONT.FACE ABBREVIATE.FONT
|
||||
TMAX.SHADEOBJ)
|
||||
|
||||
|
||||
(* ;;; "Collect ImageObjects")
|
||||
(* ;;; "Collect ImageObjects")
|
||||
|
||||
(FNS TSP.LIST.OF.OBJECTS)
|
||||
(GLOBALVARS GP.DefaultFont GP.DefaultShade)
|
||||
(MACROS MAKE.DATEOBJ.IMAGEFNS MAKE.NUMBEROBJ.IMAGEFNS MAKE.REGMARKOBJ.IMAGEFNS
|
||||
MAKE.XREFOBJ.IMAGEFNS)
|
||||
(VARS (GP.DefaultFont (FONTCREATE 'GACHA 10))
|
||||
(GP.DefaultShade 10260)
|
||||
(VARS (GP.DefaultFont (FONTCREATE 'TERMINAL 10))
|
||||
(GP.DefaultShade 1024)
|
||||
(\NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS))
|
||||
(\DATEOBJ.IMAGEFNS (MAKE.DATEOBJ.IMAGEFNS))
|
||||
(\REGMARKOBJ.IMAGEFNS (MAKE.REGMARKOBJ.IMAGEFNS))
|
||||
@@ -134,7 +138,7 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(LABEL "Known References" ID KNOWNREF SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "Reference By" TYPE STATE MENUITEMS (Ask Value Page)
|
||||
INITSTATE Value LINKS (DISPLAY DEFAULTREF))
|
||||
(LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (GACHA 10 MRR)))
|
||||
(LABEL "" TYPE DISPLAY ID DEFAULTREF FONT (TERMINAL 10 MRR)))
|
||||
((LABEL "Endnotes:" TYPE DISPLAY FONT (NIL NIL MRR))
|
||||
(LABEL "Endnote" ID ENDNOTE SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "Insert Endnotes" ID INSERTNOTE SELECTEDFN TSP.FM.APPLY)
|
||||
@@ -150,7 +154,7 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(LABEL "Create TOC" ID CREATETOC SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "View TOC" ID VIEWTOC SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "TOC Filename:" TYPE EDITSTART LINKS (EDIT TOC.FILE))
|
||||
(LABEL "" TYPE EDIT ID TOC.FILE FONT (GACHA 10 MRR)))
|
||||
(LABEL "" TYPE EDIT ID TOC.FILE FONT (TERMINAL 10 MRR)))
|
||||
((LABEL "Indices:" TYPE DISPLAY FONT (NIL NIL MRR))
|
||||
(LABEL "Index" ID INDEX SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "Extended Index" ID XTNDINDEX SELECTEDFN TSP.FM.APPLY)
|
||||
@@ -160,7 +164,7 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(LABEL "Create Index" ID CREATEINDEX SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "View Index" ID VIEWINDEX SELECTEDFN TSP.FM.APPLY)
|
||||
(LABEL "Index Filename:" TYPE EDITSTART LINKS (EDIT INDEX.FILE))
|
||||
(LABEL "" TYPE EDIT ID INDEX.FILE FONT (GACHA 10 MRR])
|
||||
(LABEL "" TYPE EDIT ID INDEX.FILE FONT (TERMINAL 10 MRR])
|
||||
|
||||
(RPAQQ IMAGEOBJ.MENU.ITEMS
|
||||
((UPDATE (UPDATE.ALL TSTREAM TWINDOW))
|
||||
@@ -430,14 +434,17 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(LIST FAMILY SIZE (FONTPROP NEWENTRY.FONT 'FACE])
|
||||
|
||||
(GET.TSP.FONT.FAMILY
|
||||
[LAMBDA (DEFAULT.FONT) (* fsg " 8-Jul-87 15:44")
|
||||
(* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.)
|
||||
[LAMBDA (DEFAULT.FONT) (* ; "Edited 24-Oct-2021 23:39 by rmk:")
|
||||
(* fsg " 8-Jul-87 15:44")
|
||||
|
||||
(* * Get the font family from the menu or DEFAULT.FONT if the menu returns NIL.)
|
||||
|
||||
(OR [MKATOM (MENU (create MENU
|
||||
TITLE _ "Font Family"
|
||||
CENTERFLG _ T
|
||||
ITEMS _ '((Classic 'CLASSIC)
|
||||
(Gacha 'GACHA)
|
||||
(Terminal 'TERMINAL)
|
||||
(Helvetica 'HELVETICA)
|
||||
(Modern 'MODERN)
|
||||
(TimesRoman 'TIMESROMAN]
|
||||
@@ -468,10 +475,12 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(FONTPROP DEFAULT.FONT 'FACE])
|
||||
|
||||
(ABBREVIATE.FONT
|
||||
[LAMBDA (FONT) (* fsg " 8-Jul-87 15:57")
|
||||
(* * Returns an abbreviated font description.
|
||||
For example, if the font is (TIMESROMAN 12
|
||||
(BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.)
|
||||
[LAMBDA (FONT) (* ; "Edited 24-Oct-2021 22:05 by rmk:")
|
||||
(* fsg " 8-Jul-87 15:57")
|
||||
|
||||
(* * Returns an abbreviated font description.
|
||||
For example, if the font is (TIMESROMAN 12
|
||||
(BOLD REGULAR REGULAR)) then the list (TimesRoman 12 Bold) is returned.)
|
||||
|
||||
(LET [(FONT.LIST (COND
|
||||
[(FONTP FONT)
|
||||
@@ -482,13 +491,15 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(LIST (LET ((FONT.FAMILY (CAR FONT.LIST)))
|
||||
(SELECTQ FONT.FAMILY
|
||||
(CLASSIC 'Classic)
|
||||
(TERMINAL 'Terminal)
|
||||
(GACHA 'Gacha)
|
||||
(HELVETICA 'Helvetica)
|
||||
(MODERN 'Modern)
|
||||
(TIMESROMAN 'TimesRoman)
|
||||
FONT.FAMILY))
|
||||
(CADR FONT.LIST)
|
||||
(LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST) collect (GNC FIELD]
|
||||
(LET [(FONT.FACE (CONCATLIST (for FIELD in (CADDR FONT.LIST)
|
||||
collect (GNC FIELD]
|
||||
(SELECTQ (MKATOM FONT.FACE)
|
||||
(MRR 'Standard)
|
||||
(MIR 'Italic)
|
||||
@@ -497,10 +508,10 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
FONT.FACE])
|
||||
|
||||
(TMAX.SHADEOBJ
|
||||
[LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:")
|
||||
(* fsg "17-Sep-87 11:25")
|
||||
[LAMBDA (OBJ STREAM SHADE) (* ; "Edited 26-Jan-97 14:07 by rmk:")
|
||||
(* fsg "17-Sep-87 11:25")
|
||||
|
||||
(* ;; "Shade the ImageObject to distinguish it from normal text.")
|
||||
(* ;; "Shade the ImageObject to distinguish it from normal text.")
|
||||
|
||||
(AND (IMAGESTREAMTYPEP STREAM 'DISPLAY)
|
||||
(LET [(BOUNDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
|
||||
@@ -543,74 +554,70 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO
|
||||
[LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
|
||||
(FUNCTION DATE.IMAGEBOXFN)
|
||||
(FUNCTION DATE.PUTFN)
|
||||
(FUNCTION DATE.GETFN)
|
||||
(FUNCTION DATE.COPYFN)
|
||||
(FUNCTION DATE.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL])
|
||||
(PUTPROPS MAKE.DATEOBJ.IMAGEFNS MACRO [LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
|
||||
(FUNCTION DATE.IMAGEBOXFN)
|
||||
(FUNCTION DATE.PUTFN)
|
||||
(FUNCTION DATE.GETFN)
|
||||
(FUNCTION DATE.COPYFN)
|
||||
(FUNCTION DATE.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL])
|
||||
|
||||
(PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO
|
||||
[LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN)
|
||||
(FUNCTION NUMBER.IMAGEBOXFN)
|
||||
(FUNCTION NUMBER.PUTFN)
|
||||
(FUNCTION NUMBER.GETFN)
|
||||
(FUNCTION NUMBER.COPYFN)
|
||||
(FUNCTION NUMBER.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION XREF.WHENDELETEDFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NUMBER.PREPRINTFN])
|
||||
(PUTPROPS MAKE.NUMBEROBJ.IMAGEFNS MACRO [LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN)
|
||||
(FUNCTION NUMBER.IMAGEBOXFN)
|
||||
(FUNCTION NUMBER.PUTFN)
|
||||
(FUNCTION NUMBER.GETFN)
|
||||
(FUNCTION NUMBER.COPYFN)
|
||||
(FUNCTION NUMBER.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION XREF.WHENDELETEDFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NUMBER.PREPRINTFN])
|
||||
|
||||
(PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO
|
||||
[LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN)
|
||||
(FUNCTION REGMARK.IMAGEBOXFN)
|
||||
(FUNCTION REGMARK.PUTFN)
|
||||
(FUNCTION REGMARK.GETFN)
|
||||
(FUNCTION REGMARK.COPYFN)
|
||||
(FUNCTION REGMARK.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL])
|
||||
(PUTPROPS MAKE.REGMARKOBJ.IMAGEFNS MACRO [LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN)
|
||||
(FUNCTION REGMARK.IMAGEBOXFN)
|
||||
(FUNCTION REGMARK.PUTFN)
|
||||
(FUNCTION REGMARK.GETFN)
|
||||
(FUNCTION REGMARK.COPYFN)
|
||||
(FUNCTION REGMARK.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL])
|
||||
|
||||
(PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO
|
||||
[LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN)
|
||||
(FUNCTION XREF.IMAGEBOXFN)
|
||||
(FUNCTION XREF.PUTFN)
|
||||
(FUNCTION XREF.GETFN)
|
||||
(FUNCTION XREF.COPYFN)
|
||||
(FUNCTION XREF.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION XREF.GET.DISPLAY.TEXT])
|
||||
(PUTPROPS MAKE.XREFOBJ.IMAGEFNS MACRO [LAMBDA NIL
|
||||
(IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN)
|
||||
(FUNCTION XREF.IMAGEBOXFN)
|
||||
(FUNCTION XREF.PUTFN)
|
||||
(FUNCTION XREF.GETFN)
|
||||
(FUNCTION XREF.COPYFN)
|
||||
(FUNCTION XREF.BUTTONEVENTINFN)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION XREF.GET.DISPLAY.TEXT])
|
||||
)
|
||||
|
||||
(RPAQ GP.DefaultFont (FONTCREATE 'GACHA 10))
|
||||
(RPAQ GP.DefaultFont (FONTCREATE 'TERMINAL 10))
|
||||
|
||||
(RPAQQ GP.DefaultShade 10260)
|
||||
(RPAQQ GP.DefaultShade 1024)
|
||||
|
||||
(RPAQ \NUMBEROBJ.IMAGEFNS (MAKE.NUMBEROBJ.IMAGEFNS))
|
||||
|
||||
@@ -643,14 +650,14 @@ Copyright (c) 1987, 1997, 1999 by Stanford University. All rights reserved.
|
||||
(TSP.FUNCTION.HOOKS)
|
||||
(PUTPROPS TMAX COPYRIGHT ("Stanford University" 1987 1997 1999))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (8744 15959 (TSP.DISPLAY.FMMENU 8754 . 9319) (TSP.SETUP.FILENAMES 9321 . 10572) (
|
||||
TSP.SETUP.FMMENU 10574 . 11034) (TSP.FMMENU 11036 . 12222) (TSP.FM.APPLY 12224 . 12543) (UPDATE.ALL
|
||||
12545 . 13217) (DOWNDATE.ALL 13219 . 13589) (TSP.FUNCTION.HOOKS 13591 . 15021) (TSP.GETFN 15023 .
|
||||
15583) (TSP.PUTFN 15585 . 15957)) (16005 18254 (AutoUpdate.TOGGLE 16015 . 16251) (UPDATE? 16253 .
|
||||
16398) (NGROUP.Menu.TOGGLE 16400 . 16782) (NGROUPMENU.ENABLED? 16784 . 17020) (
|
||||
NGROUP.Text-Before.TOGGLE 17022 . 17272) (TEXTBEFORE.ENABLED? 17274 . 17437) (NGROUP.Text-After.TOGGLE
|
||||
17439 . 17687) (TEXTAFTER.ENABLED? 17689 . 17850) (Manual.Index.TOGGLE 17852 . 18091) (
|
||||
MANUALINDEX.ENABLED? 18093 . 18252)) (18288 23401 (GET.TSP.FONT 18298 . 19462) (GET.TSP.FONT.FAMILY
|
||||
19464 . 20147) (GET.TSP.FONT.SIZE 20149 . 20637) (GET.TSP.FONT.FACE 20639 . 21338) (ABBREVIATE.FONT
|
||||
21340 . 22649) (TMAX.SHADEOBJ 22651 . 23399)) (23441 24657 (TSP.LIST.OF.OBJECTS 23451 . 24655)))))
|
||||
(FILEMAP (NIL (8815 16030 (TSP.DISPLAY.FMMENU 8825 . 9390) (TSP.SETUP.FILENAMES 9392 . 10643) (
|
||||
TSP.SETUP.FMMENU 10645 . 11105) (TSP.FMMENU 11107 . 12293) (TSP.FM.APPLY 12295 . 12614) (UPDATE.ALL
|
||||
12616 . 13288) (DOWNDATE.ALL 13290 . 13660) (TSP.FUNCTION.HOOKS 13662 . 15092) (TSP.GETFN 15094 .
|
||||
15654) (TSP.PUTFN 15656 . 16028)) (16076 18325 (AutoUpdate.TOGGLE 16086 . 16322) (UPDATE? 16324 .
|
||||
16469) (NGROUP.Menu.TOGGLE 16471 . 16853) (NGROUPMENU.ENABLED? 16855 . 17091) (
|
||||
NGROUP.Text-Before.TOGGLE 17093 . 17343) (TEXTBEFORE.ENABLED? 17345 . 17508) (NGROUP.Text-After.TOGGLE
|
||||
17510 . 17758) (TEXTAFTER.ENABLED? 17760 . 17921) (Manual.Index.TOGGLE 17923 . 18162) (
|
||||
MANUALINDEX.ENABLED? 18164 . 18323)) (18359 23832 (GET.TSP.FONT 18369 . 19533) (GET.TSP.FONT.FAMILY
|
||||
19535 . 20383) (GET.TSP.FONT.SIZE 20385 . 20873) (GET.TSP.FONT.FACE 20875 . 21574) (ABBREVIATE.FONT
|
||||
21576 . 23076) (TMAX.SHADEOBJ 23078 . 23830)) (23872 25088 (TSP.LIST.OF.OBJECTS 23882 . 25086)))))
|
||||
STOP
|
||||
|
||||
@@ -1,39 +1,54 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(filecreated "12-Mar-88 15:42:46" {erinyes}<lispusers>lyric>tmax-date.\;2 15254
|
||||
|
||||
|changes| |to:| (fns current.display.font)
|
||||
(FILECREATED "24-Oct-2021 13:52:22"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX-DATE.;4| 14231
|
||||
|
||||
|previous| |date:| "30-Dec-87 11:39:18" {erinyes}<lispusers>lyric>tmax-date.\;1)
|
||||
|changes| |to:| (FNS FINDMONTH FINDTIME FINDHOUR AMPM CHANGE.DATE.FORMAT FINDYEAR)
|
||||
(VARS TMAX-DATECOMS)
|
||||
|
||||
|previous| |date:| "12-Mar-88 15:42:46"
|
||||
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TMAX-DATE.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1987-1988 by Xerox Corporation.
|
||||
|
||||
(prettycomprint tmax-datecoms)
|
||||
(PRETTYCOMPRINT TMAX-DATECOMS)
|
||||
|
||||
(rpaqq tmax-datecoms ((* |Developed| |under| |support| |from| nih |grant| rr-00785.)
|
||||
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
|
||||
(* * tmax-datenil |ImageObject| |functions|)
|
||||
(fns dateobj dateobjp date.displayfn date.imageboxfn date.putfn date.getfn
|
||||
date.copyfn date.buttoneventinfn)
|
||||
(* * |Date| |support| |functions|)
|
||||
(fns current.display.font change.date.format)
|
||||
(* * |Functions| |to| |change| |date| |format|)
|
||||
(fns findtime findhour ampm findday nump findmonth findyear)
|
||||
(vars date.format.items)
|
||||
(records daterecord)))
|
||||
(RPAQQ TMAX-DATECOMS
|
||||
(
|
||||
(* |;;| "Developed under support from NIH grant RR-00785. Written by Frank Gilmurray and Sami Shaio. Updated by Ron Kaplan (2021)")
|
||||
|
||||
|
||||
|
||||
(* |;;;| "TMAX-DATE ImageObject functions")
|
||||
|
||||
(FNS DATEOBJ DATEOBJP DATE.DISPLAYFN DATE.IMAGEBOXFN DATE.PUTFN DATE.GETFN DATE.COPYFN
|
||||
DATE.BUTTONEVENTINFN)
|
||||
|
||||
|
||||
(* |;;;| "Date support functions")
|
||||
|
||||
(FNS CURRENT.DISPLAY.FONT CHANGE.DATE.FORMAT)
|
||||
|
||||
|
||||
(* |;;;| "Functions to change date format")
|
||||
|
||||
(FNS FINDTIME FINDHOUR AMPM FINDDAY NUMP FINDMONTH FINDYEAR)
|
||||
(VARS DATE.FORMAT.ITEMS)
|
||||
(DECLARE\: DOEVAL@COMPILE DONTCOPY (RECORDS DATERECORD))))
|
||||
|
||||
|
||||
|
||||
(* |Developed| |under| |support| |from| nih |grant| rr-00785.)
|
||||
(* |;;|
|
||||
"Developed under support from NIH grant RR-00785. Written by Frank Gilmurray and Sami Shaio. Updated by Ron Kaplan (2021)"
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* |Written| |by| |Frank| |Gilmurray| |and| |Sami| |Shaio.|)
|
||||
(* |;;;| "TMAX-DATE ImageObject functions")
|
||||
|
||||
(* * tmax-datenil |ImageObject| |functions|)
|
||||
|
||||
(defineq
|
||||
(DEFINEQ
|
||||
|
||||
(dateobj
|
||||
(lambda (date/time date.string template) (* |fsg| "13-Jul-87 11:51")
|
||||
@@ -126,9 +141,12 @@
|
||||
template.date)))))
|
||||
'changed))))))
|
||||
)
|
||||
(* * |Date| |support| |functions|)
|
||||
|
||||
(defineq
|
||||
|
||||
|
||||
(* |;;;| "Date support functions")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(current.display.font
|
||||
(lambda (stream) (* \; "Edited 12-Mar-88 15:28 by drc:")
|
||||
@@ -144,123 +162,103 @@
|
||||
(|fetch| displayfd |of| current.font))
|
||||
(t (shouldnt "Can't get current font"))))))
|
||||
|
||||
(change.date.format
|
||||
(lambda (date template) (* |ss:| "27-Jun-87 15:36")
|
||||
(* * |Convert| |the| |string| date |to| |the| |format| |specified| |by|
|
||||
template.)
|
||||
(CHANGE.DATE.FORMAT
|
||||
(LAMBDA (DATE TEMPLATE) (* \;
|
||||
"Edited 24-Oct-2021 13:47 by rmk:")
|
||||
(* |ss:| "27-Jun-87 15:36")
|
||||
|
||||
(cond
|
||||
(template (let ((version (|if| (equal (last template)
|
||||
'(a))
|
||||
|then| 'abbrev
|
||||
|else| (|if| (equal (last template)
|
||||
'(f))
|
||||
|then| 'full
|
||||
|else| 'euro)))
|
||||
(funclst '((d findday)
|
||||
(m findmonth)
|
||||
(y findyear))))
|
||||
(cond
|
||||
((eq (car template)
|
||||
t)
|
||||
(findtime date version))
|
||||
(t (let ((ch (|if| (eq version 'abbrev)
|
||||
(* |;;;| "Convert the string DATE to the format specified by TEMPLATE.")
|
||||
|
||||
(COND
|
||||
(TEMPLATE (LET ((VERSION (SELECTQ (CAR (LAST TEMPLATE))
|
||||
(A 'ABBREV)
|
||||
(F 'FULL)
|
||||
'EURO))
|
||||
(FUNCLST '((D FINDDAY)
|
||||
(M FINDMONTH)
|
||||
(Y FINDYEAR))))
|
||||
(COND
|
||||
((EQ T (CAR TEMPLATE))
|
||||
(FINDTIME DATE VERSION))
|
||||
(T (LET ((CH (|if| (EQ VERSION 'ABBREV)
|
||||
|then| "/"
|
||||
|else| " ")))
|
||||
(concat (apply (cadr (assoc (car template)
|
||||
funclst))
|
||||
(list date version))
|
||||
ch
|
||||
(apply (cadr (assoc (cadr template)
|
||||
funclst))
|
||||
(list date version))
|
||||
(|if| (equal ch " ")
|
||||
(CONCAT (APPLY (CADR (ASSOC (CAR TEMPLATE)
|
||||
FUNCLST))
|
||||
(LIST DATE VERSION))
|
||||
CH
|
||||
(APPLY (CADR (ASSOC (CADR TEMPLATE)
|
||||
FUNCLST))
|
||||
(LIST DATE VERSION))
|
||||
(|if| (EQUAL CH " ")
|
||||
|then| ", "
|
||||
|else| ch)
|
||||
(apply (cadr (assoc (caddr template)
|
||||
funclst))
|
||||
(list date version))))))))
|
||||
(t (date)))))
|
||||
|else| CH)
|
||||
(APPLY (CADR (ASSOC (CADDR TEMPLATE)
|
||||
FUNCLST))
|
||||
(LIST DATE VERSION))))))))
|
||||
(T (DATE)))))
|
||||
)
|
||||
(* * |Functions| |to| |change| |date| |format|)
|
||||
|
||||
(defineq
|
||||
|
||||
(findtime
|
||||
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40")
|
||||
(let ((hour (substring olddate 11 12))
|
||||
(minutes (substring olddate 14 15)))
|
||||
(|if| (equal version 'abbrev)
|
||||
|then| (concat (findhour hour)
|
||||
":" minutes " " (ampm hour))
|
||||
|else| (|if| (equal version 'euro)
|
||||
|then| (substring olddate 11 15)
|
||||
|else| (concat (selectq (|if| (lessp (mkatom minutes)
|
||||
46)
|
||||
|then| (mkatom (findhour hour))
|
||||
|else| (plus 1 (mkatom (findhour hour))))
|
||||
(1 "one")
|
||||
(2 "two")
|
||||
(3 "three")
|
||||
(4 "four")
|
||||
(5 "five")
|
||||
(6 "six")
|
||||
(7 "seven")
|
||||
(8 "eight")
|
||||
(9 "nine")
|
||||
(10 "ten")
|
||||
(11 "eleven")
|
||||
(12 "twelve")
|
||||
nil)
|
||||
" "
|
||||
(|if| (and (greaterp (mkatom minutes)
|
||||
15)
|
||||
(lessp (mkatom minutes)
|
||||
45))
|
||||
|then| "thirty"
|
||||
|else| "o'clock")
|
||||
" "
|
||||
(|if| (and (greaterp (mkatom minutes)
|
||||
44)
|
||||
(equal (findhour hour)
|
||||
"11"))
|
||||
|then| (|if| (equal (ampm hour)
|
||||
"a.m.")
|
||||
|then| "p.m."
|
||||
|else| "a.m.")
|
||||
|else| (ampm hour))))))))
|
||||
|
||||
(findhour
|
||||
(lambda (hour) (* |ss:| " 8-Feb-86 17:49")
|
||||
(cond
|
||||
((lessp (mkatom hour)
|
||||
13)
|
||||
(cond
|
||||
((lessp (mkatom hour)
|
||||
10)
|
||||
(mkstring (cadr (unpack hour))))
|
||||
(t hour)))
|
||||
(t (mkstring (selectq (mkatom hour)
|
||||
(13 1)
|
||||
(14 2)
|
||||
(15 3)
|
||||
(16 4)
|
||||
(17 5)
|
||||
(18 6)
|
||||
(19 7)
|
||||
(20 8)
|
||||
(21 9)
|
||||
(22 10)
|
||||
(23 11)
|
||||
(24 12)
|
||||
nil))))))
|
||||
(* |;;;| "Functions to change date format")
|
||||
|
||||
(ampm
|
||||
(lambda (hour)
|
||||
(|if| (or (lessp (mkatom hour)
|
||||
12)
|
||||
(equal (mkatom hour)
|
||||
24))
|
||||
(DEFINEQ
|
||||
|
||||
(FINDTIME
|
||||
(LAMBDA (OLDDATE VERSION) (* \;
|
||||
"Edited 24-Oct-2021 13:28 by rmk:")
|
||||
|
||||
(* |;;|
|
||||
"RMK: The spell-out default is very strange: it rounds the minutes to the nearest half hour.")
|
||||
|
||||
(* |;;| "RMK: Correct for Y2K: Substrings then work. Still, terrible code.")
|
||||
(* |ss:| "27-Jun-87 15:40")
|
||||
(LET* ((UDATE (\\UNPACKDATE (IDATE OLDDATE)))
|
||||
(HOUR (CAR (NTH UDATE 4)))
|
||||
(MINUTES (CAR (NTH UDATE 5))))
|
||||
(SELECTQ VERSION
|
||||
(ABBREV (CONCAT (FINDHOUR HOUR)
|
||||
":" MINUTES " " (AMPM HOUR)))
|
||||
(EURO (SUBSTRING OLDDATE 13 17))
|
||||
(CONCAT (SELECTQ (|if| (LESSP MINUTES 46)
|
||||
|then| (FINDHOUR HOUR)
|
||||
|else| (PLUS 1 (FINDHOUR HOUR)))
|
||||
(1 "one")
|
||||
(2 "two")
|
||||
(3 "three")
|
||||
(4 "four")
|
||||
(5 "five")
|
||||
(6 "six")
|
||||
(7 "seven")
|
||||
(8 "eight")
|
||||
(9 "nine")
|
||||
(10 "ten")
|
||||
(11 "eleven")
|
||||
(12 "twelve")
|
||||
NIL)
|
||||
" "
|
||||
(|if| (AND (GREATERP MINUTES 15)
|
||||
(LESSP MINUTES 45))
|
||||
|then| "thirty"
|
||||
|else| "o'clock")
|
||||
" "
|
||||
(AMPM HOUR))))))
|
||||
|
||||
(FINDHOUR
|
||||
(LAMBDA (HOUR) (* \;
|
||||
"Edited 24-Oct-2021 13:35 by rmk:")
|
||||
(* |ss:| " 8-Feb-86 17:49")
|
||||
(COND
|
||||
((LESSP HOUR 13)
|
||||
HOUR)
|
||||
(T (IDIFFERENCE HOUR 12)))))
|
||||
|
||||
(AMPM
|
||||
(LAMBDA (HOUR) (* \;
|
||||
"Edited 24-Oct-2021 13:37 by rmk:")
|
||||
(|if| (OR (LESSP HOUR 12)
|
||||
(EQ HOUR 24))
|
||||
|then| "a.m."
|
||||
|else| "p.m.")))
|
||||
|
||||
@@ -275,55 +273,66 @@
|
||||
(* |changed|)
|
||||
(not (null (numberp (mkatom n))))))
|
||||
|
||||
(findmonth
|
||||
(lambda (olddate version) (* |ss:| "27-Jun-87 15:40")
|
||||
(prog ((dates '((|Jan| 1 |January|)
|
||||
(|Feb| 2 |February|)
|
||||
(|Mar| 3 |March|)
|
||||
(|Apr| 4 |April|)
|
||||
(|May| 5 |May|)
|
||||
(|Jun| 6 |June|)
|
||||
(|Jul| 7 |July|)
|
||||
(|Aug| 8 |August|)
|
||||
(|Sep| 9 |September|)
|
||||
(|Oct| 10 |October|)
|
||||
(|Nov| 11 |November|)
|
||||
(|Dec| 12 |December|)))
|
||||
(output nil))
|
||||
(|if| (eq version 'abbrev)
|
||||
|then| (setq output (car (cdr (assoc (mkatom (substring olddate 4 6))
|
||||
dates))))
|
||||
|else| (setq output (car (cddr (assoc (mkatom (substring olddate 4 6))
|
||||
dates)))))
|
||||
(return output))))
|
||||
(FINDMONTH
|
||||
(LAMBDA (OLDDATE VERSION) (* \;
|
||||
"Edited 24-Oct-2021 13:52 by rmk:")
|
||||
(* |ss:| "27-Jun-87 15:40")
|
||||
|
||||
(findyear
|
||||
(lambda (olddate version) (* |ss:| "27-Jun-87 15:41")
|
||||
(|if| (eq version 'abbrev)
|
||||
|then| (mkatom (substring olddate 8 9))
|
||||
|else| (mkatom (concat "19" (substring olddate 8 9))))))
|
||||
(* |;;| "\\UNPACKDATE uses 0 origin for months")
|
||||
|
||||
(LET ((MONTH (ASSOC (ADD1 (CAR (NTH (\\UNPACKDATE (IDATE OLDDATE))
|
||||
2)))
|
||||
'((1 |Jan| |January|)
|
||||
(2 |Feb| |February|)
|
||||
(3 |Mar| |March|)
|
||||
(4 |Apr| |April|)
|
||||
(5 |May| |May|)
|
||||
(6 |Jun| |June|)
|
||||
(7 |Jul| |July|)
|
||||
(8 |Aug| |August|)
|
||||
(9 |Sep| |September|)
|
||||
(10 |Oct| |October|)
|
||||
(11 |Nov| |November|)
|
||||
(12 |DecDecember|)))))
|
||||
(|if| (EQ VERSION 'ABBREV)
|
||||
|then| (CADR MONTH)
|
||||
|else| (CADDR MONTH)))))
|
||||
|
||||
(FINDYEAR
|
||||
(LAMBDA (OLDDATE VERSION) (* \;
|
||||
"Edited 24-Oct-2021 13:48 by rmk:")
|
||||
(* |ss:| "27-Jun-87 15:41")
|
||||
(CAR (\\UNPACKDATE (IDATE OLDDATE)))))
|
||||
)
|
||||
|
||||
(rpaqq date.format.items ((|Month Day, Year| '(m d y f)
|
||||
"Insert current date as \"March 8, 1952\"")
|
||||
(|Month/Day/Year| '(m d y a) "Insert current date as \"3/8/52\"")
|
||||
(|Day Month, Year| '(d m y f)
|
||||
"Insert current date as \"8 March, 1952\"")
|
||||
(|Day/Month/Year| '(d m y a) "Insert current date as \"8/3/52\"")
|
||||
(|Time| '(t f) "Insert current time as \"four thirty p.m.\"")
|
||||
(|Numbered Time| '(t a) "Insert current time as \"4:30 p.m.\"")
|
||||
(|Military Time| '(t e) "Insert current time as \"16:30\"")
|
||||
(|Update| t "Convert to current date/time")))
|
||||
(declare\: eval@compile
|
||||
(RPAQQ DATE.FORMAT.ITEMS
|
||||
((|Month Day, Year| '(M D Y F)
|
||||
"Insert current date as \"March 8, 1952\"")
|
||||
(|Month/Day/Year| '(M D Y A)
|
||||
"Insert current date as \"3/8/52\"")
|
||||
(|Day Month, Year| '(D M Y F)
|
||||
"Insert current date as \"8 March, 1952\"")
|
||||
(|Day/Month/Year| '(D M Y A)
|
||||
"Insert current date as \"8/3/52\"")
|
||||
(|Time| '(T F)
|
||||
"Insert current time as \"four thirty p.m.\"")
|
||||
(|Numbered Time| '(T A)
|
||||
"Insert current time as \"4:30 p.m.\"")
|
||||
(|Military Time| '(T E)
|
||||
"Insert current time as \"16:30\"")
|
||||
(|Update| T "Convert to current date/time")))
|
||||
(DECLARE\: DOEVAL@COMPILE DONTCOPY
|
||||
(DECLARE\: EVAL@COMPILE
|
||||
|
||||
(record daterecord (datestring display.date template.date))
|
||||
(RECORD DATERECORD (DATESTRING DISPLAY.DATE TEMPLATE.DATE))
|
||||
)
|
||||
(putprops tmax-date copyright ("Xerox Corporation" 1987 1988))
|
||||
(declare\: dontcopy
|
||||
(filemap (nil (1398 6132 (dateobj 1408 . 2175) (dateobjp 2177 . 2611) (date.displayfn 2613 . 2935) (
|
||||
date.imageboxfn 2937 . 3564) (date.putfn 3566 . 3764) (date.getfn 3766 . 4060) (date.copyfn 4062 .
|
||||
4594) (date.buttoneventinfn 4596 . 6130)) (6174 8957 (current.display.font 6184 . 6890) (
|
||||
change.date.format 6892 . 8955)) (9012 14248 (findtime 9022 . 11531) (findhour 11533 . 12290) (ampm
|
||||
12292 . 12496) (findday 12498 . 12769) (nump 12771 . 13000) (findmonth 13002 . 13980) (findyear 13982
|
||||
. 14246)))))
|
||||
stop
|
||||
)
|
||||
(PUTPROPS TMAX-DATE COPYRIGHT ("Xerox Corporation" 1987 1988))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (1422 6156 (DATEOBJ 1432 . 2199) (DATEOBJP 2201 . 2635) (DATE.DISPLAYFN 2637 . 2959) (
|
||||
DATE.IMAGEBOXFN 2961 . 3588) (DATE.PUTFN 3590 . 3788) (DATE.GETFN 3790 . 4084) (DATE.COPYFN 4086 .
|
||||
4618) (DATE.BUTTONEVENTINFN 4620 . 6154)) (6200 8853 (CURRENT.DISPLAY.FONT 6210 . 6916) (
|
||||
CHANGE.DATE.FORMAT 6918 . 8851)) (8906 13305 (FINDTIME 8916 . 10695) (FINDHOUR 10697 . 11058) (AMPM
|
||||
11060 . 11359) (FINDDAY 11361 . 11632) (NUMP 11634 . 11863) (FINDMONTH 11865 . 12981) (FINDYEAR 12983
|
||||
. 13303)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
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
|
||||
|
||||
if [ -z "$LDEINIT" ] ; then
|
||||
export LDEINIT="$MEDLEYDIR/greetfiles/SIMPLE-INIT"
|
||||
export LDEINIT="$MEDLEYDIR/greetfiles/MEDLEYDIR-INIT"
|
||||
fi
|
||||
|
||||
export LDEKBDTYPE=x
|
||||
@@ -195,4 +195,3 @@ export INMEDLEY=1
|
||||
|
||||
"$prog" $noscroll $geometry $screensize $mem -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
|
||||
|
||||
|
||||
|
||||
@@ -29,7 +29,7 @@ tar cfz medley/tmp/$tag-runtime.tgz \
|
||||
--exclude "*~" --exclude "*#*" \
|
||||
medley/docs/dinfo \
|
||||
medley/docs/Documentation\ Tools \
|
||||
medley/greetfiles/SIMPLE-INIT \
|
||||
medley/greetfiles \
|
||||
medley/run-medley \
|
||||
medley/scripts \
|
||||
medley/fonts/displayfonts medley/fonts/altofonts \
|
||||
|
||||
166
sources/ATBL
166
sources/ATBL
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "21-Aug-2021 08:06:49" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;22 91541
|
||||
|
||||
changes to%: (FNS \ORIGTERMTABLE)
|
||||
(FILECREATED "24-Oct-2021 21:53:59" {DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;28 92451
|
||||
|
||||
previous date%: "19-Aug-2021 14:45:21"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;21)
|
||||
changes to%: (FNS MAKE-READER-ENVIRONMENT)
|
||||
|
||||
previous date%: "24-Oct-2021 20:14:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>ATBL.;27)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -14,15 +15,15 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PRETTYCOMPRINT ATBLCOMS)
|
||||
|
||||
(RPAQQ ATBLCOMS
|
||||
[(COMS (* ;
|
||||
"Common features of read and terminal tables")
|
||||
[(COMS (* ;
|
||||
"Common features of read and terminal tables")
|
||||
(DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
|
||||
(RECORDS CHARTABLE))
|
||||
(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
|
||||
(MACROS \CREATENSCHARHASH))
|
||||
(FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE)
|
||||
)
|
||||
(COMS (* ; "terminal tables")
|
||||
(COMS (* ; "terminal tables")
|
||||
(FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE
|
||||
GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE
|
||||
TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX
|
||||
@@ -31,16 +32,16 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(CONSTANTS * TERMCLASSES)
|
||||
(RECORDS TERMCODE TERMTABLEP)))
|
||||
(INITRECORDS TERMTABLEP))
|
||||
(COMS (* ; "read tables")
|
||||
(COMS (* ; "read tables")
|
||||
(FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR
|
||||
READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR
|
||||
\GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE
|
||||
\SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
|
||||
(PROP ARGNAMES READTABLEPROP)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
|
||||
"READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
|
||||
(* ;
|
||||
"OTHER must be zero because of initialization.")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (* ;
|
||||
"READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
|
||||
(* ;
|
||||
"OTHER must be zero because of initialization.")
|
||||
[VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
|
||||
(FUNCTION (LAMBDA
|
||||
(PAIR)
|
||||
@@ -48,8 +49,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
".RC")
|
||||
(CADR PAIR]
|
||||
(MACROS \COMPUTED.FORM)
|
||||
(* ;
|
||||
"This macro ought to be official somehow")
|
||||
(* ;
|
||||
"This macro ought to be official somehow")
|
||||
(RECORDS CONTEXTS ESCAPES WAKEUPS)
|
||||
(EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
|
||||
(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
|
||||
@@ -64,8 +65,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
[COMS (INITVARS (\READTABLEHASH))
|
||||
(FNS \ATBLSET)
|
||||
(INITRECORDS READER-ENVIRONMENT)
|
||||
(* ;
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
(* ;
|
||||
"Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
|
||||
(FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
|
||||
(INITVARS (*LISP-PACKAGE*)
|
||||
(*INTERLISP-PACKAGE*)
|
||||
@@ -85,8 +86,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ;
|
||||
"0 is either NONE.TC, REAL.CCE, or OTHER.RC")
|
||||
(* ;
|
||||
"0 is either NONE.TC, REAL.CCE, or OTHER.RC")
|
||||
(COND
|
||||
((IGREATERP CHAR \MAXTHINCHAR)
|
||||
(OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
|
||||
@@ -97,8 +98,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE)
|
||||
(CHECK (type? CHARTABLE TABLE))
|
||||
(* ;
|
||||
"0 is REAL.CCE, NONE.TC, OTHER.RC")
|
||||
(* ;
|
||||
"0 is REAL.CCE, NONE.TC, OTHER.RC")
|
||||
(COND
|
||||
((ILEQ CHAR \MAXTHINCHAR)
|
||||
(\PUTBASEBYTE TABLE CHAR CODE))
|
||||
@@ -401,8 +402,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
|
||||
"added size argument for creation of \ORIGTERMTABLE during initialization.")
|
||||
(PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;
|
||||
"added size argument for creation of \ORIGTERMTABLE during initialization.")
|
||||
(LIST 'HASHARRAY (OR (CAR ARGS)
|
||||
'\NSCHARHASHKEYS)
|
||||
'\NSCHARHASHOVERFLOW)))
|
||||
@@ -949,8 +950,8 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24))
|
||||
(TERMCLASS (LOGAND DATUM 7))) (* ;
|
||||
"We assume that values are appropriately shifted")
|
||||
(TERMCLASS (LOGAND DATUM 7))) (* ;
|
||||
"We assume that values are appropriately shifted")
|
||||
(CREATE (LOGOR CCECHO TERMCLASS)))
|
||||
|
||||
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL
|
||||
@@ -1640,34 +1641,34 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(RECORD READMACRODEF (MACROTYPE . MACROFN))
|
||||
|
||||
(DATATYPE READTABLEP ((READSA POINTER) (* ;
|
||||
"A CHARTABLE defining syntax of each char")
|
||||
(READMACRODEFS POINTER) (* ;
|
||||
"A hash table associating macro chars with macro definitions")
|
||||
(READMACROFLG FLAG) (* ;
|
||||
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
|
||||
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
|
||||
(COMMONLISP FLAG) (* ;
|
||||
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
|
||||
(NUMBERBASE BITS 5) (* ; "Not used")
|
||||
(CASEINSENSITIVE FLAG) (* ;
|
||||
"If true, unescaped lowercase chars are converted to uppercase in symbols")
|
||||
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
|
||||
(USESILPACKAGE FLAG) (* ;
|
||||
"If true, IL:READ ignores *PACKAGE* and reads in the IL package")
|
||||
(DATATYPE READTABLEP ((READSA POINTER) (* ;
|
||||
"A CHARTABLE defining syntax of each char")
|
||||
(READMACRODEFS POINTER) (* ;
|
||||
"A hash table associating macro chars with macro definitions")
|
||||
(READMACROFLG FLAG) (* ;
|
||||
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
|
||||
(ESCAPEFLG FLAG) (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
|
||||
(COMMONLISP FLAG) (* ;
|
||||
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
|
||||
(NUMBERBASE BITS 5) (* ; "Not used")
|
||||
(CASEINSENSITIVE FLAG) (* ;
|
||||
"If true, unescaped lowercase chars are converted to uppercase in symbols")
|
||||
(COMMONNUMSYNTAX FLAG) (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
|
||||
(USESILPACKAGE FLAG) (* ;
|
||||
"If true, IL:READ ignores *PACKAGE* and reads in the IL package")
|
||||
(NIL 5 FLAG)
|
||||
(DISPATCHMACRODEFS POINTER) (* ;
|
||||
"An a-list of dispatching macro char and its dispatch definitions")
|
||||
(HASHMACROCHAR BYTE) (* ;
|
||||
"The character code used in this read table for the # dispatch macro")
|
||||
(ESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for single escape")
|
||||
(MULTESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for multiple escape")
|
||||
(PACKAGECHAR BYTE) (* ;
|
||||
"The character code used in this read table for package delimiter")
|
||||
(READTBLNAME POINTER) (* ;
|
||||
"The canonical 'name' of this read table")
|
||||
(DISPATCHMACRODEFS POINTER) (* ;
|
||||
"An a-list of dispatching macro char and its dispatch definitions")
|
||||
(HASHMACROCHAR BYTE) (* ;
|
||||
"The character code used in this read table for the # dispatch macro")
|
||||
(ESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for single escape")
|
||||
(MULTESCAPECHAR BYTE) (* ;
|
||||
"The character code used in this read table for multiple escape")
|
||||
(PACKAGECHAR BYTE) (* ;
|
||||
"The character code used in this read table for package delimiter")
|
||||
(READTBLNAME POINTER) (* ;
|
||||
"The canonical 'name' of this read table")
|
||||
)
|
||||
READSA _ (create CHARTABLE))
|
||||
)
|
||||
@@ -1833,14 +1834,33 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-READER-ENVIRONMENT
|
||||
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
|
||||
(* ; "Edited 16-Aug-2021 23:44 by rmk:")
|
||||
[LAMBDA (PACKAGE READTABLE BASE FORMAT PACKAGEFORM READTABLEFORM)
|
||||
(* ;
|
||||
"Edited 24-Oct-2021 21:53 by rmk:")
|
||||
(* ;
|
||||
"Edited 16-Aug-2021 23:44 by rmk:")
|
||||
|
||||
(* ;; "PACKAGE can be a prop list of keyword-values")
|
||||
|
||||
(CL:WHEN (LISTP PACKAGE)
|
||||
(CL:UNLESS READTABLE
|
||||
(SETQ READTABLE (LISTGET PACKAGE :READTABLE)))
|
||||
(CL:UNLESS BASE
|
||||
(SETQ BASE (LISTGET PACKAGE :BASE)))
|
||||
(CL:UNLESS FORMAT
|
||||
(SETQ FORMAT (LISTGET PACKAGE :FORMAT)))
|
||||
(SETQ PACKAGE (LISTGET PACKAGE :PACKAGE)))
|
||||
(create READER-ENVIRONMENT
|
||||
REPACKAGE _ (COND
|
||||
(PACKAGE (\DTEST PACKAGE 'PACKAGE))
|
||||
((CL:PACKAGEP PACKAGE)
|
||||
PACKAGE)
|
||||
[PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
|
||||
(\DEST PACKAGE 'PACKAGE]
|
||||
(T *PACKAGE*))
|
||||
REREADTABLE _ (COND
|
||||
(READTABLE (\DTEST READTABLE 'READTABLEP))
|
||||
((READTABLEP READTABLE))
|
||||
[READTABLE (OR (FIND-READTABLE READTABLE)
|
||||
(\DEST READTABLE 'READTABLEP]
|
||||
(T *READTABLE*))
|
||||
REBASE _ (COND
|
||||
(BASE (\CHECKRADIX BASE))
|
||||
@@ -1904,22 +1924,22 @@ Copyright (c) 1982-1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
|
||||
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1993 2018
|
||||
2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (18036 29188 (GETSYNTAX 18046 . 22877) (SETSYNTAX 22879 . 23952) (SYNTAXP 23954 . 26451)
|
||||
(\COPYSYNTAX 26453 . 27170) (\GETCHARCODE 27172 . 27460) (\SETFATSYNCODE 27462 . 28753) (
|
||||
\MAPCHARTABLE 28755 . 29186)) (29221 44187 (CONTROL 29231 . 29483) (COPYTERMTABLE 29485 . 29852) (
|
||||
DELETECONTROL 29854 . 32495) (GETDELETECONTROL 32497 . 33459) (ECHOCHAR 33461 . 34902) (ECHOCONTROL
|
||||
34904 . 35361) (ECHOMODE 35363 . 35609) (GETECHOMODE 35611 . 35775) (GETCONTROL 35777 . 35943) (
|
||||
GETTERMTABLE 35945 . 36012) (RAISE 36014 . 36440) (GETRAISE 36442 . 36604) (RESETTERMTABLE 36606 .
|
||||
37690) (SETTERMTABLE 37692 . 37926) (TERMTABLEP 37928 . 38089) (\GETTERMSYNTAX 38091 . 38362) (
|
||||
\GTTERMTABLE 38364 . 38700) (\ORIGTERMTABLE 38702 . 42312) (\SETTERMSYNTAX 42314 . 42949) (
|
||||
\TERMCLASSTOCODE 42951 . 43380) (\TERMCODETOCLASS 43382 . 43769) (\LITCHECK 43771 . 44185)) (46717
|
||||
70541 (COPYREADTABLE 46727 . 46925) (FIND-READTABLE 46927 . 47074) (IN-READTABLE 47076 . 47236) (
|
||||
ESCAPE 47238 . 47491) (GETBRK 47493 . 47631) (GETREADTABLE 47633 . 47769) (GETSEPR 47771 . 47909) (
|
||||
READMACROS 47911 . 48174) (READTABLEP 48176 . 48339) (READTABLEPROP 48341 . 53499) (RESETREADTABLE
|
||||
53501 . 57748) (SETBRK 57750 . 59360) (SETREADTABLE 59362 . 59550) (SETSEPR 59552 . 61094) (
|
||||
\GETREADSYNTAX 61096 . 63786) (\GTREADTABLE 63788 . 64013) (\GTREADTABLE1 64015 . 64271) (
|
||||
\ORIGREADTABLE 64273 . 66181) (\READCLASSTOCODE 66183 . 66634) (\SETMACROSYNTAX 66636 . 68431) (
|
||||
\SETREADSYNTAX 68433 . 69494) (\READTABLEP.DEFPRINT 69496 . 70539)) (83633 88086 (\ATBLSET 83643 .
|
||||
88084)) (88533 91065 (MAKE-READER-ENVIRONMENT 88543 . 89321) (EQUAL-READER-ENVIRONMENT 89323 . 90467)
|
||||
(SET-READER-ENVIRONMENT 90469 . 91063)))))
|
||||
(FILEMAP (NIL (18046 29198 (GETSYNTAX 18056 . 22887) (SETSYNTAX 22889 . 23962) (SYNTAXP 23964 . 26461)
|
||||
(\COPYSYNTAX 26463 . 27180) (\GETCHARCODE 27182 . 27470) (\SETFATSYNCODE 27472 . 28763) (
|
||||
\MAPCHARTABLE 28765 . 29196)) (29231 44197 (CONTROL 29241 . 29493) (COPYTERMTABLE 29495 . 29862) (
|
||||
DELETECONTROL 29864 . 32505) (GETDELETECONTROL 32507 . 33469) (ECHOCHAR 33471 . 34912) (ECHOCONTROL
|
||||
34914 . 35371) (ECHOMODE 35373 . 35619) (GETECHOMODE 35621 . 35785) (GETCONTROL 35787 . 35953) (
|
||||
GETTERMTABLE 35955 . 36022) (RAISE 36024 . 36450) (GETRAISE 36452 . 36614) (RESETTERMTABLE 36616 .
|
||||
37700) (SETTERMTABLE 37702 . 37936) (TERMTABLEP 37938 . 38099) (\GETTERMSYNTAX 38101 . 38372) (
|
||||
\GTTERMTABLE 38374 . 38710) (\ORIGTERMTABLE 38712 . 42322) (\SETTERMSYNTAX 42324 . 42959) (
|
||||
\TERMCLASSTOCODE 42961 . 43390) (\TERMCODETOCLASS 43392 . 43779) (\LITCHECK 43781 . 44195)) (46727
|
||||
70551 (COPYREADTABLE 46737 . 46935) (FIND-READTABLE 46937 . 47084) (IN-READTABLE 47086 . 47246) (
|
||||
ESCAPE 47248 . 47501) (GETBRK 47503 . 47641) (GETREADTABLE 47643 . 47779) (GETSEPR 47781 . 47919) (
|
||||
READMACROS 47921 . 48184) (READTABLEP 48186 . 48349) (READTABLEPROP 48351 . 53509) (RESETREADTABLE
|
||||
53511 . 57758) (SETBRK 57760 . 59370) (SETREADTABLE 59372 . 59560) (SETSEPR 59562 . 61104) (
|
||||
\GETREADSYNTAX 61106 . 63796) (\GTREADTABLE 63798 . 64023) (\GTREADTABLE1 64025 . 64281) (
|
||||
\ORIGREADTABLE 64283 . 66191) (\READCLASSTOCODE 66193 . 66644) (\SETMACROSYNTAX 66646 . 68441) (
|
||||
\SETREADSYNTAX 68443 . 69504) (\READTABLEP.DEFPRINT 69506 . 70549)) (83643 88096 (\ATBLSET 83653 .
|
||||
88094)) (88543 91975 (MAKE-READER-ENVIRONMENT 88553 . 90231) (EQUAL-READER-ENVIRONMENT 90233 . 91377)
|
||||
(SET-READER-ENVIRONMENT 91379 . 91973)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,16 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "10-Aug-2020 21:44:38" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;5 90419
|
||||
|
||||
changes to%: (FNS FILEPOS FFILEPOS)
|
||||
(FILECREATED "24-Oct-2021 23:57:27"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;3 90360
|
||||
|
||||
previous date%: "11-Nov-2018 12:12:53"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;4)
|
||||
changes to%: (VARS IOCHARCOMS)
|
||||
|
||||
previous date%: "24-Oct-2021 23:53:23"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>IOCHAR.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018, 2020 by Venue & Xerox Corporation. All rights reserved.
|
||||
Copyright (c) 1981-1988, 1990-1991, 2018, 2020 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT IOCHARCOMS)
|
||||
@@ -38,17 +40,17 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
|
||||
(\MIN.SEARCH.LENGTH 100)))
|
||||
(INITRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR))
|
||||
[COMS
|
||||
(* ;; "DATE Functions")
|
||||
(* ;; "DATE Functions")
|
||||
|
||||
(FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE
|
||||
\OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE)
|
||||
(OPTIMIZERS DATEFORMAT)
|
||||
|
||||
(* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)")
|
||||
(* ;; "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)")
|
||||
|
||||
(INITVARS (\TimeZoneComp 8)
|
||||
(\BeginDST 98)
|
||||
(\EndDST 304)
|
||||
(\BeginDST 74)
|
||||
(\EndDST 312)
|
||||
(\DayLightSavings T))
|
||||
(ADDVARS (TIME.ZONES (8 "PST" "PDT")
|
||||
(7 "MST" "MDT")
|
||||
@@ -163,14 +165,14 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
|
||||
|
||||
(CL:DEFUN XCL:PACK (NAMES &OPTIONAL (PACKAGE *PACKAGE*))
|
||||
|
||||
(* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ")
|
||||
(* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ")
|
||||
|
||||
(CL:INTERN (CONCATLIST NAMES)
|
||||
PACKAGE))
|
||||
|
||||
(CL:DEFUN XCL:PACK* (&REST NAMES)
|
||||
|
||||
(* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ")
|
||||
(* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ")
|
||||
|
||||
(CL:INTERN (CONCATLIST NAMES)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -182,11 +184,11 @@ Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018,
|
||||
|
||||
(PUTPROPS \CATRANSLATE MACRO (OPENLAMBDA (CABASE CASIZE CAFAT CHAR)
|
||||
(COND
|
||||
((ILEQ CHAR CASIZE)(* ;
|
||||
"If it's in the table, use the table value")
|
||||
((ILEQ CHAR CASIZE)(* ;
|
||||
"If it's in the table, use the table value")
|
||||
(\GETBASEBYTE CABASE CHAR))
|
||||
(T (* ;
|
||||
"Off the end -- assume it's itself")
|
||||
(T (* ;
|
||||
"Off the end -- assume it's itself")
|
||||
CHAR))))
|
||||
)
|
||||
)
|
||||
@@ -1326,9 +1328,9 @@ DONTCOPY
|
||||
|
||||
(RPAQ? \TimeZoneComp 8)
|
||||
|
||||
(RPAQ? \BeginDST 98)
|
||||
(RPAQ? \BeginDST 74)
|
||||
|
||||
(RPAQ? \EndDST 304)
|
||||
(RPAQ? \EndDST 312)
|
||||
|
||||
(RPAQ? \DayLightSavings T)
|
||||
|
||||
@@ -1372,15 +1374,15 @@ DONTCOPY
|
||||
(PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990
|
||||
1991 2018 2020))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3507 7301 (CHCON 3517 . 4367) (UNPACK 4369 . 5263) (DCHCON 5265 . 6532) (DUNPACK 6534
|
||||
. 7299)) (7302 18817 (UALPHORDER 7312 . 7408) (ALPHORDER 7410 . 9213) (CONCAT 9215 . 9860) (
|
||||
CONCATCODES 9862 . 10048) (PACKC 10050 . 12653) (PACK 12655 . 13234) (PACK* 13236 . 14958) (\PACK.ITEM
|
||||
14960 . 15415) (STRPOS 15417 . 18815)) (18819 19108 (XCL:PACK 18819 . 19108)) (19110 19360 (XCL:PACK*
|
||||
19110 . 19360)) (20078 22469 (STRPOSL 20088 . 21714) (MAKEBITTABLE 21716 . 22467)) (22631 23108 (
|
||||
CASEARRAY 22641 . 22831) (UPPERCASEARRAY 22833 . 23106)) (23430 47032 (FILEPOS 23440 . 33352) (
|
||||
FFILEPOS 33354 . 44467) (\SETUP.FFILEPOS 44469 . 47030)) (47820 89067 (DATE 47830 . 47916) (DATEFORMAT
|
||||
47918 . 48010) (GDATE 48012 . 48123) (IDATE 48125 . 59796) (\IDATESCANTOKEN 59798 . 61077) (
|
||||
\IDATE-PARSE-MONTH 61079 . 64775) (\OUTDATE 64777 . 77525) (\OUTDATE-STRING 77527 . 78142) (\RPLRIGHT
|
||||
78144 . 78382) (\UNPACKDATE 78384 . 84175) (\PACKDATE 84177 . 87497) (\DTSCAN 87499 . 87641) (\ISDST?
|
||||
87643 . 88150) (\CHECKDSTCHANGE 88152 . 89065)))))
|
||||
(FILEMAP (NIL (3448 7242 (CHCON 3458 . 4308) (UNPACK 4310 . 5204) (DCHCON 5206 . 6473) (DUNPACK 6475
|
||||
. 7240)) (7243 18758 (UALPHORDER 7253 . 7349) (ALPHORDER 7351 . 9154) (CONCAT 9156 . 9801) (
|
||||
CONCATCODES 9803 . 9989) (PACKC 9991 . 12594) (PACK 12596 . 13175) (PACK* 13177 . 14899) (\PACK.ITEM
|
||||
14901 . 15356) (STRPOS 15358 . 18756)) (18760 19049 (XCL:PACK 18760 . 19049)) (19051 19301 (XCL:PACK*
|
||||
19051 . 19301)) (20019 22410 (STRPOSL 20029 . 21655) (MAKEBITTABLE 21657 . 22408)) (22572 23049 (
|
||||
CASEARRAY 22582 . 22772) (UPPERCASEARRAY 22774 . 23047)) (23371 46973 (FILEPOS 23381 . 33293) (
|
||||
FFILEPOS 33295 . 44408) (\SETUP.FFILEPOS 44410 . 46971)) (47761 89008 (DATE 47771 . 47857) (DATEFORMAT
|
||||
47859 . 47951) (GDATE 47953 . 48064) (IDATE 48066 . 59737) (\IDATESCANTOKEN 59739 . 61018) (
|
||||
\IDATE-PARSE-MONTH 61020 . 64716) (\OUTDATE 64718 . 77466) (\OUTDATE-STRING 77468 . 78083) (\RPLRIGHT
|
||||
78085 . 78323) (\UNPACKDATE 78325 . 84116) (\PACKDATE 84118 . 87438) (\DTSCAN 87440 . 87582) (\ISDST?
|
||||
87584 . 88091) (\CHECKDSTCHANGE 88093 . 89006)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,14 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
|
||||
(IL:FILECREATED "22-Sep-92 11:47:31" "{Pele:mv:envos}<LispCore>Sources>LLPACKAGE.;25" 82127
|
||||
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS IL:ADD-SYMBOL)
|
||||
(IL:FILECREATED "24-Oct-2021 10:20:31" IL:|{DSK}<home>larry>medley>sources>LLPACKAGE.;4| 82444
|
||||
|
||||
IL:|previous| IL:|date:| "20-May-91 13:07:32" "{Pele:mv:envos}<LispCore>Sources>LLPACKAGE.;24"
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL IL:FIND-SYMBOL*)
|
||||
|
||||
IL:|previous| IL:|date:| "22-Sep-92 11:47:31" IL:|{DSK}<home>larry>medley>sources>LLPACKAGE.;1|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1987, 1990, 1991, 1992 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1986-1987, 1990-1992 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:LLPACKAGECOMS)
|
||||
|
||||
@@ -524,9 +525,7 @@
|
||||
PACKAGE)))
|
||||
(IL:DEFINEQ
|
||||
|
||||
(xcl:defpackage
|
||||
(il:nlambda il:args (il:* il:\; "Edited 2-Dec-87 10:39 by raf") (il:setq il:args (xcl:remove-comments il:args)) (let ((package (find-package (car il:args)))) (cond ((packagep package) (il:* il:\; "If one already exists, test compatability of package definitions") (il:|for| il:option il:|in| (cdr il:args) il:|do| (let* ((il:key (cond ((keywordp il:option) il:option) ((il:listp il:option) (car il:option)) (t (il:error "Bad option for defpackage " il:option)))) (values (cond ((keywordp il:option) (list t)) ((il:listp il:option) (cdr il:option)) (t (il:error "Bad option for defpackage " il:option))))) (il:selectq il:key ((:internal-symbols :external-symbols) nil) (:external-only (if (not (%package-external-only package)) (il:error "Package NOT :external-only as asserted by defpackage: " package))) (:prefix-name (setf (%package-namesymbol package) (make-symbol (car values)))) (:use (use-package values package)) (:nicknames (il:enter-new-nicknames package values)) (:export (export (il:for il:symbol il:in values il:collect (il:if (il:litatom il:symbol) il:then il:symbol il:elseif (il:stringp il:symbol) il:then (intern il:symbol package) il:else (il:error "Bad object in :export option of defpackage " il:symbol))) package)) (:import (import values package)) ((:shadow :shadowing-import) (let ((il:symbols-to-shadow (il:mapconc values (il:function (il:lambda (symbol) (cond ((not (il:memb symbol (%package-shadowing-symbols package))) (list symbol)))))))) (il:selectq il:key (:shadow (shadow il:symbols-to-shadow package)) (:shadowing-import (shadowing-import il:symbols-to-shadow package)) nil))) (il:error "Bad keyword for defpackage " il:key))))) (t (il:* il:\; "Otherwise, make a new package to spec") (let ((il:post-make-forms nil)) (il:setq package (il:apply (quote make-package) (cons (car il:args) (il:|for| il:option il:|in| (cdr il:args) il:|join| (let ((il:key (cond ((keywordp il:option) il:option) ((il:listp il:option) (car il:option)) (t (il:error "Bad option for defpackage " il:option)))) (values (cond ((keywordp il:option) (list t)) ((il:listp il:option) (cdr il:option)) (t (il:error "Bad option for defpackage " il:option))))) (il:selectq il:key ((:use :nicknames) (list il:key (il:|if| (car values) il:|then| values il:|else| (il:* il:\; "Handles case where NIL is being used to explicitly say the package's :USE list is empty, since the default is to use LISP.") nil))) ((:prefix-name :internal-symbols :external-symbols :external-only) (list il:key (car values))) ((:shadow :export :import :shadowing-import) (il:setq il:post-make-forms (cons (cons il:key values) il:post-make-forms)) nil) (il:error "Bad keyword for defpackage " il:key))))))) (il:mapc il:post-make-forms (il:function (il:lambda (il:form) (il:selectq (car il:form) (:shadow (shadow (cdr il:form) package)) (:export (export (il:for il:symbol il:in (cdr il:form) il:collect (il:if (il:litatom il:symbol) il:then il:symbol il:elseif (il:stringp il:symbol) il:then (intern il:symbol package) il:else (il:error "Bad object in :export option of defpackage " il:symbol))) package)) (:import (import (cdr il:form) package)) (:shadowing-import (shadowing-import (cdr il:form) package)) (il:shouldnt "Bogus form on post-make-forms")))))))) (package-name package)))
|
||||
)
|
||||
(xcl:defpackage
|
||||
(il:nlambda il:args (il:* il:\; "Edited 2-Dec-87 10:39 by raf") (il:setq il:args (xcl:remove-comments il:args)) (let ((package (find-package (car il:args)))) (cond ((packagep package) (il:* il:\; "If one already exists, test compatability of package definitions") (il:|for| il:option il:|in| (cdr il:args) il:|do| (let* ((il:key (cond ((keywordp il:option) il:option) ((il:listp il:option) (car il:option)) (t (il:error "Bad option for defpackage " il:option)))) (values (cond ((keywordp il:option) (list t)) ((il:listp il:option) (cdr il:option)) (t (il:error "Bad option for defpackage " il:option))))) (il:selectq il:key ((:internal-symbols :external-symbols) nil) (:external-only (if (not (%package-external-only package)) (il:error "Package NOT :external-only as asserted by defpackage: " package))) (:prefix-name (setf (%package-namesymbol package) (make-symbol (car values)))) (:use (use-package values package)) (:nicknames (il:enter-new-nicknames package values)) (:export (export (il:for il:symbol il:in values il:collect (il:if (il:litatom il:symbol) il:then il:symbol il:elseif (il:stringp il:symbol) il:then (intern il:symbol package) il:else (il:error "Bad object in :export option of defpackage " il:symbol))) package)) (:import (import values package)) ((:shadow :shadowing-import) (let ((il:symbols-to-shadow (il:mapconc values (il:function (il:lambda (symbol) (cond ((not (il:memb symbol (%package-shadowing-symbols package))) (list symbol)))))))) (il:selectq il:key (:shadow (shadow il:symbols-to-shadow package)) (:shadowing-import (shadowing-import il:symbols-to-shadow package)) nil))) (il:error "Bad keyword for defpackage " il:key))))) (t (il:* il:\; "Otherwise, make a new package to spec") (let ((il:post-make-forms nil)) (il:setq package (il:apply (quote make-package) (cons (car il:args) (il:|for| il:option il:|in| (cdr il:args) il:|join| (let ((il:key (cond ((keywordp il:option) il:option) ((il:listp il:option) (car il:option)) (t (il:error "Bad option for defpackage " il:option)))) (values (cond ((keywordp il:option) (list t)) ((il:listp il:option) (cdr il:option)) (t (il:error "Bad option for defpackage " il:option))))) (il:selectq il:key ((:use :nicknames) (list il:key (il:|if| (car values) il:|then| values il:|else| (il:* il:\; "Handles case where NIL is being used to explicitly say the package's :USE list is empty, since the default is to use LISP.") nil))) ((:prefix-name :internal-symbols :external-symbols :external-only) (list il:key (car values))) ((:shadow :export :import :shadowing-import) (il:setq il:post-make-forms (cons (cons il:key values) il:post-make-forms)) nil) (il:error "Bad keyword for defpackage " il:key))))))) (il:mapc il:post-make-forms (il:function (il:lambda (il:form) (il:selectq (car il:form) (:shadow (shadow (cdr il:form) package)) (:export (export (il:for il:symbol il:in (cdr il:form) il:collect (il:if (il:litatom il:symbol) il:then il:symbol il:elseif (il:stringp il:symbol) il:then (intern il:symbol package) il:else (il:error "Bad object in :export option of defpackage " il:symbol))) package)) (:import (import (cdr il:form) package)) (:shadowing-import (shadowing-import (cdr il:form) package)) (il:shouldnt "Bogus form on post-make-forms")))))))) (package-name package)))
|
||||
)
|
||||
)
|
||||
@@ -1033,7 +1032,7 @@
|
||||
(T (IL:ADD-SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
SYMBOL)))
|
||||
(VALUES SYMBOL NIL)))))
|
||||
"Check internal and external symbols, then scan down the list of hashtables for inherited symbols. When an inherited symbol is found pull that table to the beginning of the list."
|
||||
|
||||
(DEFUN IL:FIND-SYMBOL* (IL:BASE IL:OFFSET IL:LENGTH IL:FATP PACKAGE)
|
||||
(IL:* IL:\; "Check internal and external symbols, then scan down the list of hashtables for inherited symbols. When an inherited symbol is found pull that table to the beginning of the list.")
|
||||
|
||||
@@ -1042,10 +1041,11 @@
|
||||
(LET* ((IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
|
||||
(IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))
|
||||
(IL:RESULT (IL:\\CREATECELL IL:\\FIXP))
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP
|
||||
(%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
IL:RESULT))
|
||||
IL:SYM IL:WHERE (IL:DONE))
|
||||
(UNLESS (%PACKAGE-EXTERNAL-ONLY PACKAGE)
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM (IL:SUBRCALL IL:WITH-SYMBOL IL:BASE IL:OFFSET
|
||||
IL:LENGTH IL:FATP (
|
||||
%PACKAGE-INTERNAL-SYMBOLS
|
||||
PACKAGE)
|
||||
IL:RESULT))
|
||||
(COND
|
||||
@@ -1061,10 +1061,11 @@
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))")
|
||||
|
||||
(IL:SETQ IL:WHERE :INTERNAL)
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP
|
||||
(%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
IL:RESULT))
|
||||
(IL:SETQ IL:DONE T)))))
|
||||
(UNLESS IL:DONE
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM (IL:SUBRCALL IL:WITH-SYMBOL IL:BASE IL:OFFSET
|
||||
IL:LENGTH IL:FATP (
|
||||
%PACKAGE-EXTERNAL-SYMBOLS
|
||||
PACKAGE)
|
||||
IL:RESULT))
|
||||
(COND
|
||||
@@ -1087,10 +1088,10 @@
|
||||
(DO ((IL:PREV IL:HEAD IL:TABLE)
|
||||
(IL:TABLE (CDR IL:HEAD)
|
||||
(CDR IL:TABLE)))
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP
|
||||
(CAR IL:TABLE)
|
||||
IL:RESULT))
|
||||
((OR IL:DONE (NULL IL:TABLE))
|
||||
(VALUES NIL NIL))
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM (IL:SUBRCALL IL:WITH-SYMBOL IL:BASE
|
||||
IL:OFFSET IL:LENGTH IL:FATP
|
||||
(CAR IL:TABLE)
|
||||
IL:RESULT))
|
||||
(COND
|
||||
@@ -1518,11 +1519,11 @@
|
||||
(IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING))
|
||||
(IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
|
||||
(IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP (
|
||||
(IL:RESULT (IL:\\CREATECELL IL:\\FIXP))
|
||||
IL:SYM)
|
||||
(IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM (IL:SUBRCALL IL:WITH-SYMBOL IL:BASE IL:OFFSET
|
||||
PACKAGE)
|
||||
IL:RESULT))
|
||||
IL:LENGTH IL:FATP (
|
||||
%PACKAGE-EXTERNAL-SYMBOLS
|
||||
PACKAGE)
|
||||
IL:RESULT))
|
||||
(VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1))))
|
||||
@@ -1563,5 +1564,30 @@
|
||||
|
||||
(IL:ADDTOVAR IL:LAMA )
|
||||
)
|
||||
(IL:FILEMAP (NIL (25052 28345 (XCL:DEFPACKAGE 25065 . 28343)))))
|
||||
(IL:PUTPROPS IL:LLPACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (9779 10219 (IL:\\UPCASEBASE 9779 . 10219)) (10221 11342 (IL:APROPOS-SEARCH 10221 .
|
||||
11342)) (12882 12964 (PACKAGE-NAME 12882 . 12964)) (12966 13058 (PACKAGE-NICKNAMES 12966 . 13058)) (
|
||||
13060 13168 (PACKAGE-SHADOWING-SYMBOLS 13060 . 13168)) (13170 13260 (PACKAGE-USE-LIST 13170 . 13260))
|
||||
(13262 13360 (PACKAGE-USED-BY-LIST 13262 . 13360)) (13362 14517 (IL:MAKE-PACKAGE-HASHTABLE 13362 .
|
||||
14517)) (14519 14681 (PRINT-PACKAGE 14519 . 14681)) (14683 15074 (PRINT-PACKAGE-HASHTABLE 14683 .
|
||||
15074)) (16142 16923 (MAKE-SYMBOL 16142 . 16923)) (18034 18444 (IL:\\PKG-FIND-FREE-PACKAGE-INDEX 18034
|
||||
. 18444)) (18501 18647 (IL:SETF-SYMBOL-PACKAGE 18501 . 18647)) (18649 18741 (SYMBOL-PACKAGE 18649 .
|
||||
18741)) (21512 21684 (IL:INTERNAL-SYMBOL-COUNT 21512 . 21684)) (21686 21804 (IL:EXTERNAL-SYMBOL-COUNT
|
||||
21686 . 21804)) (21806 22962 (IL:ENTER-NEW-NICKNAMES 21806 . 22962)) (22964 23390 (
|
||||
IL:MAKE-PRIME-HASHTABLE-SIZE 22964 . 23390)) (23392 25061 (MAKE-PACKAGE 23392 . 25061)) (25062 28355 (
|
||||
XCL:DEFPACKAGE 25075 . 28353)) (28404 28626 (FIND-PACKAGE 28404 . 28626)) (28628 31966 (USE-PACKAGE
|
||||
28628 . 31966)) (31968 32448 (IN-PACKAGE 31968 . 32448)) (32450 32724 (XCL:PKG-GOTO 32450 . 32724)) (
|
||||
32726 33826 (RENAME-PACKAGE 32726 . 33826)) (33828 35279 (XCL:DELETE-PACKAGE 33828 . 35279)) (35281
|
||||
38227 (EXPORT 35281 . 38227)) (38229 39472 (UNEXPORT 38229 . 39472)) (39474 41118 (IMPORT 39474 .
|
||||
41118)) (41120 42398 (SHADOWING-IMPORT 41120 . 42398)) (42400 43454 (SHADOW 42400 . 43454)) (43456
|
||||
44111 (UNUSE-PACKAGE 43456 . 44111)) (44175 44481 (LIST-ALL-PACKAGES 44175 . 44481)) (44538 48313 (
|
||||
IL:ADD-SYMBOL 44538 . 48313)) (52637 53940 (IL:INTERN* 52637 . 53940)) (53942 59790 (IL:FIND-SYMBOL*
|
||||
53942 . 59790)) (59792 61243 (INTERN 59792 . 61243)) (61245 61823 (FIND-SYMBOL 61245 . 61823)) (61881
|
||||
62781 (IL:NUKE-SYMBOL 61881 . 62781)) (62783 64903 (UNINTERN 62783 . 64903)) (64905 66048 (
|
||||
IL:MOBY-UNINTERN 64905 . 66048)) (66107 66179 (IL:\\INDEXATOMPNAME 66107 . 66179)) (66291 66438 (
|
||||
IL:MAKE-DO-SYMBOLS-VARS 66291 . 66438)) (66440 67895 (IL:MAKE-DO-SYMBOLS-CODE 66440 . 67895)) (75495
|
||||
76020 (FIND-ALL-SYMBOLS 75495 . 76020)) (76022 76301 (IL:BRIEFLY-DESCRIBE-SYMBOL 76022 . 76301)) (
|
||||
76303 77817 (APROPOS 76303 . 77817)) (77819 79476 (APROPOS-LIST 77819 . 79476)) (79580 81153 (
|
||||
IL:FIND-EXTERNAL-SYMBOL 79580 . 81153)) (81155 81675 (IL:FIND-EXACT-SYMBOL 81155 . 81675)) (81677
|
||||
81757 (IL:PACKAGE-NAME-AS-SYMBOL 81677 . 81757)) (81759 81908 (IL:\\FIND.PACKAGE.INTERNAL 81759 .
|
||||
|
||||
Binary file not shown.
@@ -1,28 +1,31 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "25-Feb-94 16:50:33" |{DSK}<users>nilsson>mnw>MAIKOBITBLT.;1| 8778
|
||||
|
||||
|changes| |to:| (VARS MAIKOBITBLTCOMS)
|
||||
(FILECREATED "26-Oct-2021 10:52:24" |{DSK}<home>larry>medley>sources>MAIKOBITBLT.;2| 9691
|
||||
|
||||
|previous| |date:| "14-Jun-90 16:57:27" |{DSK}<king>export>lispcore>sources>MAIKOBITBLT.;1|)
|
||||
|changes| |to:| (FNS \\MAIKO.BITBLTSUB \\MAIKO.BLTCHAR \\MAIKO.PUNTBLTCHAR
|
||||
\\MAIKO.BITBLT.BITMAP \\MAIKO.BLTSHADE.BITMAP)
|
||||
|
||||
|previous| |date:| "24-Oct-2021 10:31:31" |{DSK}<home>larry>medley>sources>MAIKOBITBLT.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1988, 1989, 1990, 1994 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1988-1990, 1994 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT MAIKOBITBLTCOMS)
|
||||
|
||||
(RPAQQ MAIKOBITBLTCOMS (
|
||||
(* |;;| "this file has some optimizations for BITBLT on MAIKO; while PILOTBITBLT opcode still works, these functions directly implement some higher level operations")
|
||||
(RPAQQ MAIKOBITBLTCOMS
|
||||
(
|
||||
(* |;;| "this file has some optimizations for BITBLT on MAIKO; while PILOTBITBLT opcode still works, these functions directly implement some higher level operations")
|
||||
|
||||
(FNS \\MAIKO.BITBLTSUB \\MAIKO.BLTCHAR \\MAIKO.PUNTBLTCHAR
|
||||
\\MAIKO.BITBLT.BITMAP \\MAIKO.BLTSHADE.BITMAP)
|
||||
|
||||
(* |;;| "Save the old \\BITBLT.BITMAP, because it handles the OPERATION - MERGE case, where the C code doesn't.")
|
||||
(FNS \\MAIKO.BITBLTSUB \\MAIKO.BLTCHAR \\MAIKO.PUNTBLTCHAR \\MAIKO.BITBLT.BITMAP
|
||||
\\MAIKO.BLTSHADE.BITMAP)
|
||||
|
||||
(* |;;| "Save the old \\BITBLT.BITMAP, because it handles the OPERATION - MERGE case, where the C code doesn't.")
|
||||
|
||||
(P (MOVD '\\BITBLT.BITMAP '\\MAIKO.OLDBITBLT.BITMAP))
|
||||
(ADDVARS (\\MAIKO.MOVDS (\\MAIKO.BLTCHAR \\MEDW.BLTCHAR)
|
||||
(\\MAIKO.BITBLTSUB \\BITBLTSUB)
|
||||
(\\MAIKO.BITBLT.BITMAP \\BITBLT.BITMAP)
|
||||
(\\MAIKO.BLTSHADE.BITMAP \\BLTSHADE.BITMAP)))))
|
||||
(P (MOVD '\\BITBLT.BITMAP '\\MAIKO.OLDBITBLT.BITMAP))
|
||||
(ADDVARS (\\MAIKO.MOVDS (\\MAIKO.BLTCHAR \\MEDW.BLTCHAR)
|
||||
(\\MAIKO.BITBLTSUB \\BITBLTSUB)
|
||||
(\\MAIKO.BITBLT.BITMAP \\BITBLT.BITMAP)
|
||||
(\\MAIKO.BLTSHADE.BITMAP \\BLTSHADE.BITMAP)))))
|
||||
|
||||
|
||||
|
||||
@@ -34,22 +37,28 @@
|
||||
|
||||
(\\MAIKO.BITBLTSUB
|
||||
(LAMBDA (PILOTBBT |SourceBitMap| SLX STY |DestinationBitMap| DLX DTY HEIGHT |SourceType|
|
||||
|Operation| |Texture| |WindowXOffset| |WindowYOffset|)
|
||||
|Operation| |Texture| |WindowXOffset| |WindowYOffset|)
|
||||
(* \;
|
||||
"Edited 26-Oct-2021 10:06 by larry")
|
||||
(* \; "Edited 29-Jun-88 16:24 by ")
|
||||
|
||||
(* |;;| "replaces \\BITBLTSUB on Maiko")
|
||||
|
||||
((OPCODES SUBRCALL 69 13)
|
||||
PILOTBBT |SourceBitMap| SLX STY |DestinationBitMap| DLX DTY HEIGHT |SourceType| |Operation|
|
||||
|Texture| |WindowXOffset| |WindowYOffset|)))
|
||||
(SUBRCALL BITBLTSUB PILOTBBT |SourceBitMap| SLX STY |DestinationBitMap| DLX DTY HEIGHT
|
||||
|SourceType| |Operation| |Texture| |WindowXOffset| |WindowYOffset|)))
|
||||
|
||||
(\\MAIKO.BLTCHAR
|
||||
(LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA)
|
||||
((OPCODES SUBRCALL 135 3)
|
||||
CHARCODE DISPLAYSTREAM DISPLAYDATA)))
|
||||
(LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* \;
|
||||
"Edited 26-Oct-2021 10:22 by larry")
|
||||
(* \;
|
||||
"Edited 6-Jul-90 10:14 by matsuda")
|
||||
(SUBRCALL NEW-BLTCHAR CHARCODE DISPLAYSTREAM DISPLAYDATA)))
|
||||
|
||||
(\\MAIKO.PUNTBLTCHAR
|
||||
(LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* \; "Edited 29-Jun-88 16:04 by ")
|
||||
(LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* \;
|
||||
"Edited 26-Oct-2021 10:21 by larry")
|
||||
(* \;
|
||||
"Edited 1-Nov-89 15:26 by takeshi")
|
||||
|
||||
(* |;;| "puts a character on a display stream. This function will be called when \\maiko.bltchar failed. Punt from subr call")
|
||||
|
||||
@@ -63,7 +72,12 @@
|
||||
(\\CHANGECHARSET.DISPLAY DISPLAYDATA (\\CHARSET CHARCODE))))
|
||||
(COND
|
||||
((|ffetch| (\\DISPLAYDATA |DDSlowPrintingCase|) |of| DISPLAYDATA)
|
||||
(RETURN (\\SLOWBLTCHAR CHARCODE DISPLAYSTREAM))))
|
||||
(RETURN (COND
|
||||
((|type?| STREAM DISPLAYSTREAM)
|
||||
(\\SLOWBLTCHAR CHARCODE DISPLAYSTREAM))
|
||||
((|type?| WINDOW DISPLAYSTREAM)
|
||||
(\\SLOWBLTCHAR CHARCODE (FETCH DSP OF DISPLAYSTREAM)))
|
||||
(T (ERROR "Not Stream or Window" DISPLAYSTREAM))))))
|
||||
(SETQ CURX (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| DISPLAYDATA))
|
||||
(SETQ RIGHT (IPLUS CURX (\\DSPGETCHARIMAGEWIDTH CHAR8CODE DISPLAYDATA)))
|
||||
(COND
|
||||
@@ -107,14 +121,14 @@
|
||||
DISPLAYDATA)
|
||||
))
|
||||
0)))
|
||||
(.WHILE.TOP.DS. DISPLAYSTREAM ((OPCODES SUBRCALL 70 6)
|
||||
LOCAL1 DISPLAYDATA CHAR8CODE CURX LEFT RIGHT))
|
||||
(.WHILE.TOP.DS. DISPLAYSTREAM (SUBRCALL BLTCHAR LOCAL1 DISPLAYDATA CHAR8CODE
|
||||
CURX LEFT RIGHT))
|
||||
T))))))
|
||||
|
||||
(\\MAIKO.BITBLT.BITMAP
|
||||
(LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
|
||||
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
|
||||
CLIPPEDSOURCEBOTTOM) (* \; "Edited 14-Jun-90 16:47 by TS")
|
||||
CLIPPEDSOURCEBOTTOM) (* \; "Edited 14-Jun-90 16:47 by TS")
|
||||
|
||||
(* |;;| "SUN version of \\BITBLT.BITMAP. For all but the MERGE case, use C code. For the MERGE case, use the old code.")
|
||||
|
||||
@@ -132,7 +146,7 @@
|
||||
|
||||
(\\MAIKO.BLTSHADE.BITMAP
|
||||
(LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION
|
||||
CLIPPINGREGION) (* \; "Edited 14-Jun-90 16:49 by TS")
|
||||
CLIPPINGREGION) (* \; "Edited 14-Jun-90 16:49 by TS")
|
||||
(DECLARE (LOCALVARS . T))
|
||||
|
||||
(* |;;| "C function, bitshade_bitmap , has PUNT case \\PUNT.BLTSHADE.BITMAP(Takeshi)")
|
||||
@@ -156,7 +170,7 @@
|
||||
(\\MAIKO.BLTSHADE.BITMAP \\BLTSHADE.BITMAP))
|
||||
(PUTPROPS MAIKOBITBLT COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1994))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (1600 8233 (\\MAIKO.BITBLTSUB 1610 . 2130) (\\MAIKO.BLTCHAR 2132 . 2272) (
|
||||
\\MAIKO.PUNTBLTCHAR 2274 . 6375) (\\MAIKO.BITBLT.BITMAP 6377 . 7729) (\\MAIKO.BLTSHADE.BITMAP 7731 .
|
||||
8231)))))
|
||||
(FILEMAP (NIL (1500 9146 (\\MAIKO.BITBLTSUB 1510 . 2193) (\\MAIKO.BLTCHAR 2195 . 2623) (
|
||||
\\MAIKO.PUNTBLTCHAR 2625 . 7288) (\\MAIKO.BITBLT.BITMAP 7290 . 8642) (\\MAIKO.BLTSHADE.BITMAP 8644 .
|
||||
9144)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED "25-Mar-2021 09:50:57" |{DSK}<home>larry>ilisp>medley>sources>MAIKOETHER.;2| 47411
|
||||
|
||||
|changes| |to:| (VARS MAIKOETHERCOMS \\EPT.3TO10)
|
||||
(FNS \\MAIKO.10MBSENDPACKET \\MAIKO.10MBWATCHER \\MAIKO.ETHERRESUME
|
||||
\\MAIKO.ETHERSUSPEND \\MAIKO.INPUT.INTERRUPT \\MAIKO.10MBSTARTDRIVER
|
||||
\\MAIKO.10MBTURNONETHER \\MAIKO.10MB.RESTART.ETHER \\MAIKO.CHECKSUM)
|
||||
(FILECREATED "25-Oct-2021 15:12:33" |{DSK}<home>larry>medley>sources>MAIKOETHER.;2| 28792
|
||||
|
||||
|previous| |date:| " 4-May-91 15:52:07" |{DSK}<home>larry>ilisp>medley>sources>MAIKOETHER.;1|
|
||||
)
|
||||
|changes| |to:| (FNS \\DISPLAYLINE)
|
||||
(VARS MAIKOETHERCOMS)
|
||||
|
||||
|previous| |date:| "25-Mar-2021 09:50:57" |{DSK}<home>larry>medley>sources>MAIKOETHER.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1988-1991, 2021 by Venue & Xerox Corporation.
|
||||
@@ -16,7 +14,7 @@
|
||||
|
||||
(RPAQQ MAIKOETHERCOMS
|
||||
((FNS \\10MB.RESTART.ETHER \\10MB.STARTDRIVER \\10MB.TURNOFFETHER \\10MB.TURNONETHER
|
||||
\\10MBSENDPACKET \\10MBWATCHER \\DISPLAYLINE \\MAIKO.10MBSENDPACKET \\MAIKO.10MBWATCHER
|
||||
\\10MBSENDPACKET \\10MBWATCHER \\MAIKO.10MBSENDPACKET \\MAIKO.10MBWATCHER
|
||||
\\MAIKO.ETHERRESUME \\MAIKO.ETHERSUSPEND \\MAIKO.INPUT.INTERRUPT \\NS.SETTIME
|
||||
\\PUP.SETTIME \\MAIKO.10MBSTARTDRIVER \\MAIKO.10MBTURNONETHER \\MAIKO.10MB.RESTART.ETHER
|
||||
\\MAIKO.CHECKSUM)
|
||||
@@ -183,256 +181,6 @@
|
||||
(SETQ CNTR 0)
|
||||
(GO LP))))
|
||||
|
||||
(\\DISPLAYLINE
|
||||
(LAMBDA (TEXTOBJ LINE WINDOW) (* \; "Edited 5-Apr-89 16:22 by snow")
|
||||
|
||||
(* |;;| "Display the line of text LINE in the edit window where it belongs.")
|
||||
|
||||
(* |;;| " This Function works on MIAKO")
|
||||
|
||||
(PROG ((CH 0)
|
||||
(CHLIST (|fetch| (THISLINE CHARS) |of| (|fetch| THISLINE |of| TEXTOBJ)))
|
||||
(WLIST (|fetch| (THISLINE WIDTHS) |of| (|ffetch| THISLINE |of| TEXTOBJ)))
|
||||
(LOOKS (|fetch| (THISLINE LOOKS) |of| (|ffetch| THISLINE |of| TEXTOBJ)))
|
||||
(WINDOWDS (WINDOWPROP (OR WINDOW (CAR (|fetch| (TEXTOBJ \\WINDOW) |of| TEXTOBJ)))
|
||||
'DSP))
|
||||
(TEXTLEN (|ffetch| (TEXTOBJ TEXTLEN) |of| TEXTOBJ))
|
||||
(THISLINE (|ffetch| (TEXTOBJ THISLINE) |of| TEXTOBJ))
|
||||
(TERMSA (|ffetch| (TEXTOBJ TXTTERMSA) |of| TEXTOBJ))
|
||||
(STREAM (|ffetch| (TEXTOBJ STREAMHINT) |of| TEXTOBJ))
|
||||
(OLDCACHE (|fetch| LCBITMAP |of| (|ffetch| (TEXTOBJ DISPLAYCACHE) |of|
|
||||
TEXTOBJ)))
|
||||
(DS (|ffetch| (TEXTOBJ DISPLAYCACHEDS) |of| TEXTOBJ))
|
||||
(HCPYDS (|ffetch| (TEXTOBJ DISPLAYHCPYDS) |of| TEXTOBJ))
|
||||
(HARDCOPYMODE (|fetch| (FMTSPEC FMTHARDCOPY) |of| (|fetch| (LINEDESCRIPTOR
|
||||
LFMTSPEC)
|
||||
|of| LINE)))
|
||||
LOOKSTARTX CACHE \\PCHARSLEFT \\PSTRING \\PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT
|
||||
CLIPRIGHT DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE)
|
||||
(SETQ LHEIGHT (COND
|
||||
((|ffetch| (LINEDESCRIPTOR PREVLINE) |of| LINE)
|
||||
(* \;
|
||||
"So if theres a base-to-base measure, we clear everything right.")
|
||||
(IMAX (IDIFFERENCE (|fetch| YBOT |of| (|ffetch| (
|
||||
LINEDESCRIPTOR
|
||||
PREVLINE)
|
||||
|of| LINE))
|
||||
(|ffetch| (LINEDESCRIPTOR YBOT) |of| LINE))
|
||||
(|ffetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE)))
|
||||
(T (|ffetch| (LINEDESCRIPTOR LHEIGHT) |of| LINE))))
|
||||
(COND
|
||||
(HARDCOPYMODE (* \;
|
||||
"This is a hardcopy-mode line. Scale things.")
|
||||
(* \; "(SETQ DS HCPYDS)")
|
||||
(SETQ SCALE (DSPSCALE NIL HCPYDS)))
|
||||
(T (SETQ SCALE 1)))
|
||||
(SETQ CACHE (\\TEDIT.LINECACHE (|ffetch| (TEXTOBJ DISPLAYCACHE) |of| TEXTOBJ)
|
||||
(COND
|
||||
(HARDCOPYMODE (FIXR (FQUOTIENT (|fetch| RIGHTMARGIN |of|
|
||||
LINE)
|
||||
SCALE)))
|
||||
(T (|fetch| RIGHTMARGIN |of| LINE)))
|
||||
LHEIGHT))
|
||||
(COND
|
||||
((NEQ CACHE OLDCACHE) (* \;
|
||||
"We changed the bitmaps because this line was bigger--update the displaystream, too")
|
||||
(DSPDESTINATION CACHE DS)
|
||||
(DSPCLIPPINGREGION (|create| REGION
|
||||
LEFT _ 0
|
||||
BOTTOM _ 0
|
||||
WIDTH _ (|fetch| BITMAPWIDTH |of| CACHE)
|
||||
HEIGHT _ (|ffetch| BITMAPHEIGHT |of| CACHE))
|
||||
DS)))
|
||||
(BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE)
|
||||
(* \; "Clear the line cache")
|
||||
(COND
|
||||
(HARDCOPYMODE (* \;
|
||||
"This is a hardcopy-mode line. Scale things.")
|
||||
(* \; "(SETQ DS HCPYDS)")
|
||||
(SETQ SCALE (DSPSCALE NIL HCPYDS)))
|
||||
(T (SETQ SCALE 1)))
|
||||
(COND
|
||||
((AND (NOT (ZEROP (|fetch| CHAR1 |of| LINE)))
|
||||
(ILEQ (|ffetch| CHAR1 |of| LINE)
|
||||
TEXTLEN)
|
||||
(IGEQ (|ffetch| YBOT |of| LINE)
|
||||
(|ffetch| WBOTTOM |of| TEXTOBJ)))
|
||||
|
||||
(* |;;| "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.")
|
||||
|
||||
(COND
|
||||
((NEQ (|fetch| DESC |of| THISLINE)
|
||||
LINE) (* \;
|
||||
"No image cache -- re-format and display")
|
||||
(\\FORMATLINE TEXTOBJ NIL (|ffetch| CHAR1 |of| LINE)
|
||||
LINE)))
|
||||
(MOVETO (|ffetch| LEFTMARGIN |of| LINE)
|
||||
(|ffetch| DESCENT |of| LINE)
|
||||
DS)
|
||||
(SETQ DISPLAYDATA (|fetch| IMAGEDATA |of| DS))
|
||||
(SETQ DDPILOTBBT (|ffetch| DDPILOTBBT |of| DISPLAYDATA))
|
||||
(SETQ XOFFSET (|ffetch| DDXOFFSET |of| DISPLAYDATA))
|
||||
|
||||
(* |;;| "The X position of the left edge of the window, since \\TEDIT.BLTCHAR works on the screen bitmap itself.")
|
||||
|
||||
(SETQ CLIPLEFT (|ffetch| |DDClippingLeft| |of| DISPLAYDATA))
|
||||
(* \;
|
||||
"The left and right edges of the clipping region for the text display window.")
|
||||
(SETQ CLIPRIGHT (|ffetch| |DDClippingRight| |of| DISPLAYDATA))
|
||||
(SETQ OFONT (DSPFONT (|fetch| CLFONT |of| (SETQ OLOOKS (\\EDITELT LOOKS 0)))
|
||||
DS)) (* \; "The starting font")
|
||||
(SETQ DDWIDTHCACHE (|ffetch| DDWIDTHSCACHE |of| DISPLAYDATA))
|
||||
(* \;
|
||||
"Cache the character-image widths")
|
||||
(SETQ DDOFFSETCACHE (|ffetch| DDOFFSETSCACHE |of| DISPLAYDATA))
|
||||
(* \;
|
||||
"And the offset-into-strike-bitmap array")
|
||||
(SETQ LOOKSTARTX (|ffetch| LEFTMARGIN |of| LINE))
|
||||
(* \;
|
||||
"Starting X position for the current-looks text.")
|
||||
(AND (|fetch| CLOFFSET |of| OLOOKS)
|
||||
(RELMOVETO 0 (FIXR (FTIMES SCALE (|ffetch| CLOFFSET |of| OLOOKS)))
|
||||
DS)) (* \;
|
||||
"Any sub- or superscripting at start of line")
|
||||
(|bind| (LOOKNO _ 1)
|
||||
DX
|
||||
(TX _ (IPLUS XOFFSET (|ffetch| LEFTMARGIN |of| LINE))) |for| I
|
||||
|from| 0 |to| (|fetch| LEN |of| THISLINE)
|
||||
|do|
|
||||
|
||||
(* |;;| "Display the line character by character")
|
||||
|
||||
(SETQ CH (\\EDITELT CHLIST I)) (* \;
|
||||
"Grab the character (or IMAGEOBJ) to display")
|
||||
(SETQ DX (\\WORDELT WLIST I)) (* \; "And its width")
|
||||
(SELECTC CH
|
||||
(|LMInvisibleRun| (* \;
|
||||
"An INVISIBLE run -- skip it, and skip over the char count")
|
||||
(|add| LOOKNO 1))
|
||||
(|LMLooksChange| (* \; "A LOOKS change")
|
||||
(|freplace| DDXPOSITION |of| DISPLAYDATA
|
||||
|with| (IDIFFERENCE TX XOFFSET))
|
||||
(* \;
|
||||
"Make the displaystream reflect our current X position")
|
||||
(TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (|ffetch| DESCENT
|
||||
|of| LINE))
|
||||
(* \;
|
||||
"Make any necessary changes to the preceding characters (underline, strike-out &c)")
|
||||
(DSPFONT (|fetch| CLFONT |of| (SETQ OLOOKS (\\EDITELT LOOKS
|
||||
LOOKNO)))
|
||||
DS) (* \; "Set the new font")
|
||||
(|add| LOOKNO 1) (* \;
|
||||
"Grab the next set of char looks")
|
||||
(AND (|ffetch| CLOFFSET |of| OLOOKS)
|
||||
(RELMOVETO 0 (|ffetch| CLOFFSET |of| OLOOKS)
|
||||
DS)) (* \; "Account for super/subscripting")
|
||||
(SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET))
|
||||
(* \;
|
||||
"Remember the starting Xpos for possible later underlining &c")
|
||||
)
|
||||
((CHARCODE (TAB \#^I)) (* \;
|
||||
"TAB: use the width from the cache to decide the right formatting.")
|
||||
(COND
|
||||
((OR (IEQP CH (CHARCODE \#^I))
|
||||
(|ffetch| CLLEADER |of| OLOOKS)
|
||||
(EQ (|ffetch| CLUSERINFO |of| OLOOKS)
|
||||
'DOTTEDLEADER))
|
||||
(LET* ((LEADERFONT (COND
|
||||
(HARDCOPYMODE (FONTCOPY (|ffetch|
|
||||
CLFONT
|
||||
|of| OLOOKS)
|
||||
'DEVICE HCPYDS))
|
||||
(T (|ffetch| CLFONT |of| OLOOKS))))
|
||||
(DOTWIDTH (CHARWIDTH (CHARCODE \.)
|
||||
LEADERFONT))
|
||||
(TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH
|
||||
(IREMAINDER TX DOTWIDTH))))
|
||||
)
|
||||
(|while| (ILEQ TTX (IPLUS TX DX))
|
||||
|do| (COND
|
||||
(HARDCOPYMODE
|
||||
(SUBRCALL TEDIT.BLTCHAR (CHARCODE \.)
|
||||
DS
|
||||
(FIXR (FQUOTIENT (IDIFFERENCE TTX
|
||||
DOTWIDTH)
|
||||
SCALE))
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
|
||||
((OR TERMSA HARDCOPYMODE)
|
||||
(* \;
|
||||
"Using special instrns from TERMSA")
|
||||
(\\DSPPRINTCHAR DS (CHARCODE \.)))
|
||||
(T (* \; "Native charcodes")
|
||||
(SUBRCALL TEDIT.BLTCHAR (CHARCODE \.)
|
||||
DS
|
||||
(IDIFFERENCE TTX DOTWIDTH)
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
|
||||
)
|
||||
(|add| TTX DOTWIDTH))))))
|
||||
(13 (* \; "It's a CR")
|
||||
NIL)
|
||||
(COND
|
||||
((SMALLP CH) (* \;
|
||||
"Normal character -- just display it.")
|
||||
(COND
|
||||
(HARDCOPYMODE (SUBRCALL TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX
|
||||
SCALE))
|
||||
DISPLAYDATA DDPILOTBBT CLIPRIGHT))
|
||||
((OR TERMSA HARDCOPYMODE) (* \;
|
||||
"Using special instrns from TERMSA")
|
||||
(\\DSPPRINTCHAR DS CH))
|
||||
(T (* \; "Native charcodes")
|
||||
(SUBRCALL TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT
|
||||
CLIPRIGHT))))
|
||||
(T (* \; "CH is an object.")
|
||||
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
|
||||
XOFFSET)
|
||||
(SETQ CURY (DSPYPOSITION NIL DS))
|
||||
DS) (* \;
|
||||
"Go to the base line, left edge of the image region.")
|
||||
(APPLY* (IMAGEOBJPROP CH 'DISPLAYFN)
|
||||
CH DS 'DISPLAY (|ffetch| STREAMHINT |of| TEXTOBJ))
|
||||
(* \;
|
||||
"Tell him to display himself here.")
|
||||
(DSPFONT (|ffetch| CLFONT |of| OLOOKS)
|
||||
DS)
|
||||
(MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
|
||||
XOFFSET)
|
||||
CURY DS) (* \;
|
||||
"Move to after the object's image")
|
||||
)))
|
||||
(|add| TX DX) (* \; "Update our X position")
|
||||
|finally| (|freplace| DDXPOSITION |of| DISPLAYDATA
|
||||
|with| (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
|
||||
XOFFSET))
|
||||
(* \;
|
||||
"Make any necessary looks mods to the last run of characters")
|
||||
(TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (|ffetch| DESCENT
|
||||
|of| LINE)))))
|
||||
(BITBLT CACHE 0 0 WINDOWDS 0 (|ffetch| YBOT |of| LINE)
|
||||
(|ffetch| WRIGHT |of| TEXTOBJ)
|
||||
LHEIGHT
|
||||
'INPUT
|
||||
'REPLACE) (* \;
|
||||
"Paint the cached image on the screen (this lessens flicker during update)")
|
||||
(COND
|
||||
((|fetch| (FMTSPEC FMTREVISED) |of| (|ffetch| (LINEDESCRIPTOR LFMTSPEC)
|
||||
|of| LINE))
|
||||
(* \;
|
||||
"This paragraph has been revised, so mark it.")
|
||||
(\\TEDIT.MARK.REVISION TEXTOBJ (|ffetch| (LINEDESCRIPTOR LFMTSPEC) |of| LINE)
|
||||
WINDOWDS LINE)))
|
||||
(SELECTQ (|ffetch| LMARK |of| LINE)
|
||||
(GREY (* \;
|
||||
"This line has some property that isn't visible to the user. Tell him to be careful")
|
||||
(BITBLT NIL 0 0 WINDOWDS 0 (|ffetch| YBASE |of| LINE)
|
||||
6 6 'TEXTURE 'PAINT 42405))
|
||||
(SOLID (* \;
|
||||
"This line has some property that isn't visible to the user. Tell him to be careful")
|
||||
(BITBLT NIL 0 0 WINDOWDS 0 (|ffetch| YBASE |of| LINE)
|
||||
6 6 'TEXTURE 'PAINT BLACKSHADE))
|
||||
(BITBLT NIL 0 0 WINDOWDS 0 (|ffetch| YBASE |of| LINE)
|
||||
6 6 'TEXTURE 'REPLACE WHITESHADE)))))
|
||||
|
||||
(\\MAIKO.10MBSENDPACKET
|
||||
(LAMBDA (NDB PACKET) (* \; "Edited 31-Oct-89 14:10 by bvm")
|
||||
(PROG NIL
|
||||
@@ -781,13 +529,12 @@
|
||||
(RPAQQ \\MAIKO.IO-INTERRUPT-VECTOR NIL)
|
||||
(PUTPROPS MAIKOETHER COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 2021))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (2870 40835 (\\10MB.RESTART.ETHER 2880 . 3040) (\\10MB.STARTDRIVER 3042 . 4801) (
|
||||
\\10MB.TURNOFFETHER 4803 . 4963) (\\10MB.TURNONETHER 4965 . 7335) (\\10MBSENDPACKET 7337 . 9708) (
|
||||
\\10MBWATCHER 9710 . 11049) (\\DISPLAYLINE 11051 . 29389) (\\MAIKO.10MBSENDPACKET 29391 . 31769) (
|
||||
\\MAIKO.10MBWATCHER 31771 . 33116) (\\MAIKO.ETHERRESUME 33118 . 33277) (\\MAIKO.ETHERSUSPEND 33279 .
|
||||
33440) (\\MAIKO.INPUT.INTERRUPT 33442 . 35704) (\\NS.SETTIME 35706 . 35986) (\\PUP.SETTIME 35988 .
|
||||
36269) (\\MAIKO.10MBSTARTDRIVER 36271 . 37926) (\\MAIKO.10MBTURNONETHER 37928 . 40303) (
|
||||
\\MAIKO.10MB.RESTART.ETHER 40305 . 40658) (\\MAIKO.CHECKSUM 40660 . 40833)) (41890 44955 (
|
||||
\\MAIKO.ETHER-INTERRUPT 41900 . 44953)) (45077 46440 (\\MAIKO.CONSOLE-LOG-PRINT 45087 . 46438)) (46486
|
||||
47166 (\\MAIKO.IO-INTERRUPT 46496 . 47164)))))
|
||||
(FILEMAP (NIL (2591 22216 (\\10MB.RESTART.ETHER 2601 . 2761) (\\10MB.STARTDRIVER 2763 . 4522) (
|
||||
\\10MB.TURNOFFETHER 4524 . 4684) (\\10MB.TURNONETHER 4686 . 7056) (\\10MBSENDPACKET 7058 . 9429) (
|
||||
\\10MBWATCHER 9431 . 10770) (\\MAIKO.10MBSENDPACKET 10772 . 13150) (\\MAIKO.10MBWATCHER 13152 . 14497)
|
||||
(\\MAIKO.ETHERRESUME 14499 . 14658) (\\MAIKO.ETHERSUSPEND 14660 . 14821) (\\MAIKO.INPUT.INTERRUPT
|
||||
14823 . 17085) (\\NS.SETTIME 17087 . 17367) (\\PUP.SETTIME 17369 . 17650) (\\MAIKO.10MBSTARTDRIVER
|
||||
17652 . 19307) (\\MAIKO.10MBTURNONETHER 19309 . 21684) (\\MAIKO.10MB.RESTART.ETHER 21686 . 22039) (
|
||||
\\MAIKO.CHECKSUM 22041 . 22214)) (23271 26336 (\\MAIKO.ETHER-INTERRUPT 23281 . 26334)) (26458 27821 (
|
||||
\\MAIKO.CONSOLE-LOG-PRINT 26468 . 27819)) (27867 28547 (\\MAIKO.IO-INTERRUPT 27877 . 28545)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,9 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 2-Mar-2021 23:12:27" {DSK}<home>larry>ilisp>medley>sources>MAIKOLOADUPFNS.;4 5921
|
||||
|
||||
changes to%: (VARS MAIKOLOADUPFNSCOMS)
|
||||
(FILECREATED "26-Oct-2021 09:55:14" {DSK}<home>larry>medley>sources>MAIKOLOADUPFNS.;2 5969
|
||||
|
||||
previous date%: "25-Feb-2021 15:43:43" {DSK}<home>larry>ilisp>save>MAIKOLOADUPFNS.;1)
|
||||
changes to%: (FNS \BITBLTSUB \BLTCHAR)
|
||||
|
||||
previous date%: " 2-Mar-2021 23:12:27" {DSK}<home>larry>medley>sources>MAIKOLOADUPFNS.;1)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -59,18 +60,16 @@ Copyright (c) 1989, 2018, 2021 by ENVOS Corporation.
|
||||
|
||||
(\BITBLTSUB
|
||||
[LAMBDA (PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation
|
||||
Texture WindowXOffset WindowYOffset) (* ; "Edited 29-Jun-88 16:24 by ")
|
||||
Texture WindowXOffset WindowYOffset) (* ; "Edited 26-Oct-2021 09:53 by larry")
|
||||
|
||||
(* ;; "replaces \BITBLTSUB on Maiko")
|
||||
|
||||
((OPCODES SUBRCALL 69 13)
|
||||
PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation Texture
|
||||
WindowXOffset WindowYOffset])
|
||||
(SUBRCALL BITBLTSUB PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType
|
||||
Operation Texture WindowXOffset WindowYOffset])
|
||||
|
||||
(\BLTCHAR
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA)
|
||||
((OPCODES SUBRCALL 135 3)
|
||||
CHARCODE DISPLAYSTREAM DISPLAYDATA])
|
||||
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 26-Oct-2021 09:51 by larry")
|
||||
(SUBRCALL NEW-BLTCHAR CHARCODE DISPLAYSTREAM DISPLAYDATA])
|
||||
|
||||
(\CHECKSUM
|
||||
[LAMBDA (BASE NWORDS INITSUM) (* ; "Edited 20-May-88 11:48 by MASINTER")
|
||||
@@ -164,12 +163,12 @@ Copyright (c) 1989, 2018, 2021 by ENVOS Corporation.
|
||||
)
|
||||
(PUTPROPS MAIKOLOADUPFNS COPYRIGHT ("ENVOS Corporation" 1989 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1336 5603 (CL::%%COPY-TIME-STATS 1346 . 1542) (CHECKPAGEMAP 1544 . 1676) (CLOCK 1678 .
|
||||
1827) (CLOCK0 1829 . 1979) (DAYTIME 1981 . 2132) (SETTIME 2134 . 2408) (\BITBLTSUB 2410 . 2832) (
|
||||
\BLTCHAR 2834 . 2966) (\CHECKSUM 2968 . 3133) (\CLOCK0 3135 . 3286) (\COUNTREALPAGES 3288 . 3421) (
|
||||
\DAYTIME0 3423 . 3576) (\DIRTYBACKGROUND 3578 . 3714) (\DOLOCKPAGES 3716 . 3848) (\DONEWPAGE 3850 .
|
||||
3999) (\DORECLAIM 4001 . 4147) (\DOTEMPLOCKPAGES 4149 . 4285) (\LOADVMEMPAGE 4287 . 4420) (
|
||||
\LOCKEDPAGEP 4422 . 4538) (\LOCKPAGES 4540 . 4670) (\MOVEVMEMFILEPAGE 4672 . 4793) (\NEWPAGE 4795 .
|
||||
4942) (\PAGEFAULT 4944 . 5056) (\SHOWPAGETABLE 5058 . 5192) (\TEMPUNLOCKPAGES 5194 . 5330) (
|
||||
\UNLOCKPAGES 5332 . 5464) (\WRITEDIRTYPAGE 5466 . 5601)))))
|
||||
(FILEMAP (NIL (1335 5651 (CL::%%COPY-TIME-STATS 1345 . 1541) (CHECKPAGEMAP 1543 . 1675) (CLOCK 1677 .
|
||||
1826) (CLOCK0 1828 . 1978) (DAYTIME 1980 . 2131) (SETTIME 2133 . 2407) (\BITBLTSUB 2409 . 2831) (
|
||||
\BLTCHAR 2833 . 3014) (\CHECKSUM 3016 . 3181) (\CLOCK0 3183 . 3334) (\COUNTREALPAGES 3336 . 3469) (
|
||||
\DAYTIME0 3471 . 3624) (\DIRTYBACKGROUND 3626 . 3762) (\DOLOCKPAGES 3764 . 3896) (\DONEWPAGE 3898 .
|
||||
4047) (\DORECLAIM 4049 . 4195) (\DOTEMPLOCKPAGES 4197 . 4333) (\LOADVMEMPAGE 4335 . 4468) (
|
||||
\LOCKEDPAGEP 4470 . 4586) (\LOCKPAGES 4588 . 4718) (\MOVEVMEMFILEPAGE 4720 . 4841) (\NEWPAGE 4843 .
|
||||
4990) (\PAGEFAULT 4992 . 5104) (\SHOWPAGETABLE 5106 . 5240) (\TEMPUNLOCKPAGES 5242 . 5378) (
|
||||
\UNLOCKPAGES 5380 . 5512) (\WRITEDIRTYPAGE 5514 . 5649)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user