move obsolete lispusers (#635)

* TEXTOFD:  Property OBJECTBYTE returned instead of image objects

This allows COMPARETEXT to work on TEDIT files

* ATBL: Default reader environment uses *DEFAULT-EXTERNALFORMAT* instead of :XCCS constant

* CMLEXEC:  Fix FILETYPE property

It had CL:COMPILE-FILE, but the directory had LCOMs.  Changed to :FAKE-COMPILE-FILE.

* FILEIO:  single place for EOL specification

Now only in SETFILEINFO, not separately in \DO.PARAMS.AT.OPEN

* WINDOWOBJ:  COPYINSERT now uniformly allows lists of objects

It was incomplete.

* COMPARETEXT: Now works for TEDIT files

* EXAMINEDEFS: side-by-side attached SEDIT windows for comparing alternative definitions

* OBJECTWINDOW:  container for arbitrary image objects

.github/workflows/build.yml

@@ -1,82 +0,0 @@
-#  based on https://blog.oddbit.com/post/2020-09-25-building-multi-architecture-im/
----
-# Interlisp workflow to build Docker Image that support multiple architectures
-name: 'Build Medley Docker image'
-
-# Run this workflow on push to master
-on:
-  push:
-    branches:
-      - master
-
-# Jobs that compose this workflow
-jobs:
-  # Job to build the docker image
-  docker:
-    runs-on: ubuntu-latest
-    steps:
-      # Checkout the branch
-      - name: Checkout
-        uses: actions/checkout@v2
-
-      # Setup needed environment variables
-      - name: Prepare
-        id: prep
-        run: |
-          DOCKER_IMAGE=interlisp/${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
-
-          # 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')
-
-      # Setup Docker Machine Emulation environment
-      - name: Set up QEMU
-        uses: docker/setup-qemu-action@master
-        with:
-          platforms: all
-
-      # Setup Docker Buildx function
-      - name: Set up Docker Buildx
-        id: buildx
-        uses: docker/setup-buildx-action@master
-
-      # Login to DockerHub - required to store the image
-      - name: Login to DockerHub
-        if: github.event_name != 'pull_request'
-        uses: docker/login-action@v1
-        with:
-          username: ${{ secrets.DOCKER_USERNAME }}
-          password: ${{ secrets.DOCKER_PASSWORD }}
-
-      # Start the Docker Build using the Dockerfilein the repository
-      - name: Build
-        uses: docker/build-push-action@v2
-        with:
-          builder: ${{ steps.buildx.outputs.name }}
-          context: .
-          file: ./Dockerfile
-          # Platforms
-          #  linux/amd64 -- Standard x86_64
-          #  linux/arm64 -- Apple M1
-          #  linux/arm/v7 -- Raspberry pi
-          platforms: linux/amd64,linux/arm64,linux/arm/v7
-          # Push the created image
-          push: true
-          # tags to assign to the Docker image
-          tags: ${{ steps.prep.outputs.tags }}

.github/workflows/buildDocker.yml

@@ -0,0 +1,112 @@
+#  based on https://blog.oddbit.com/post/2020-09-25-building-multi-architecture-im/
+---
+# Interlisp workflow to build Docker Image that support multiple architectures
+name: Build Medley Docker image
+
+# Run this workflow on demand
+on:
+  workflow_dispatch:
+
+# Jobs that compose this workflow
+jobs:
+  # Job to build the docker image
+  docker:
+    runs-on: ubuntu-latest
+    steps:
+      # Checkout the branch
+      - 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: |
+          DOCKERHUB_ACCOUNT=interlisp
+          DOCKER_IMAGE=${DOCKERHUB_ACCOUNT}/${GITHUB_REPOSITORY#*/}
+          VERSION=latest
+          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}
+          echo ::set-output name=maiko_release::${MAIKO_RELEASE}
+          echo ::set-output name=medley_release::${MEDLEY_RELEASE}
+
+      # 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
+        uses: docker/setup-qemu-action@master
+        with:
+          platforms: all
+
+      # Setup Docker Buildx function
+      - name: Set up Docker Buildx
+        id: buildx
+        uses: docker/setup-buildx-action@master
+
+      # Login to DockerHub - required to store the image
+      - name: Login to DockerHub
+        if: github.event_name != 'pull_request'
+        uses: docker/login-action@v1
+        with:
+          username: ${{ secrets.DOCKER_USERNAME }}
+          password: ${{ secrets.DOCKER_PASSWORD }}
+
+      # Start the Docker Build using the Dockerfilein the repository
+      - name: Build
+        uses: docker/build-push-action@v2
+        with:
+          builder: ${{ steps.buildx.outputs.name }}
+          context: .
+          file: ./Dockerfile
+          # Platforms
+          #  linux/amd64 -- Standard x86_64
+          #  linux/arm64 -- Apple M1
+          #  linux/arm/v7 -- Raspberry pi
+          platforms: linux/amd64,linux/arm64,linux/arm/v7
+          # Push the created image
+          push: true
+          # tags to assign to the Docker image
+          tags: ${{ steps.prep.outputs.tags }}
+          build-args: |
+            medley_release=${{steps.prep.outputs.medley_release}}
+            maiko_release=${{steps.prep.outputs.maiko_release}}
+            build_date=${{steps.prep.outputs.build_time}}

.github/workflows/buildLoadup.yml

@@ -0,0 +1,106 @@
+# Interlisp workflow to build Medley release
+name: Build Medley Release
+
+# Run this workflow on push to master
+on:
+  workflow_dispatch:
+    inputs:
+      tag:
+        description:  'Release Tag'
+
+# Jobs that compose this workflow
+jobs:
+  # Build Loadup
+  loadup:
+    runs-on: ubuntu-latest
+    steps:
+      - name: Set release tag if currently undefined
+        if: ${{ github.event.inputs.tag == null }}
+        run:  |
+          echo "tag=medley-`date +%y%m%d`" >> $GITHUB_ENV
+
+      - name: Set release tag to input value
+        if: ${{ github.event.inputs.tag != null }}
+        run: |
+          echo "tag=${{ github.event.inputs.tag }}" >> $GITHUB_ENV
+
+      - name: Checkout Medley
+        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:
+          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: Untar Maiko Release
+        run: |
+          tar -xvzf "${{ steps.latest_version.outputs.latest_tag }}-linux.x86_64.tgz"
+
+      - name: install vnc
+        run: sudo apt-get update && sudo apt-get install -y tightvncserver
+
+      - name: Build Loadout
+        run: |
+          Xvnc -geometry 1280x720 :0 &
+          export DISPLAY=":0"
+          PATH="$PWD/maiko:$PATH" 
+          scripts/loadup-all.sh
+
+      - name: Build release tar get libs
+        run: |
+          cp -p tmp/full.sysout tmp/lisp.sysout tmp/*.dribble tmp/whereis.hash loadups/
+          cp -p tmp/exports.all tmp/RDSYS tmp/RDSYS.LCOM library/
+          cd ..
+          tar cfz medley/tmp/$tag-loadups.tgz        \
+            medley/loadups/lisp.sysout               \
+            medley/loadups/full.sysout               \
+            medley/loadups/whereis.hash              \
+            medley/library/exports.all               \
+            medley/library/RDSYS/                    \
+            medley/library/RDSYS.LCOM   
+      
+      - name: tar part 2
+        run: |
+          cd ..
+          tar cfz medley/tmp/$tag-runtime.tgz                    \
+                     --exclude "*~" --exclude "*#*"              \
+                     medley/docs/dinfo                           \
+                     medley/docs/Documentation\ Tools            \
+                     medley/greetfiles                           \
+                     medley/run-medley                           \
+                     medley/scripts                              \
+                     medley/fonts/displayfonts                   \
+                     medley/fonts/altofonts                      \
+                     medley/fonts/postscriptfonts                \
+                     medley/library/                             \
+                     medley/lispusers/                           \
+                     medley/fonts/big                            \
+                     medley/fonts/other                          \
+                     medley/sources/                             \
+                     medley/internal/library      
+
+      - name: Release notes
+        run: |
+          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 }}

BUILDING.md

@@ -0,0 +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 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.

Dockerfile

@@ -1,19 +1,25 @@
-FROM interlisp/maiko:latest
-ARG BUILD_DATE
+FROM ubuntu:focal
+ARG build_date
+ARG medley_release
+ARG maiko_release
 LABEL name="Medley"
+# LABEL tags=${tags}
 LABEL description="The Medley Interlisp environment"
 LABEL url="https://github.com/Interlisp/medley"
-LABEL build-time=$BUILD_DATE
+LABEL build-time=$build_date
+ENV BUILD_DATE=$build_date
+ENV MEDLEY_RELEASE=$medley_release
+ENV MAIKO_RELEASE=$maiko_release
 
 RUN apt-get update && apt-get install -y tightvncserver
 
 EXPOSE 5900
 
-# Need to refine this down to only needed directories.
-COPY . /app/medley
+# Copy and uncompress loadup and required source files.
+ADD *.tgz /home
 
-WORKDIR /app/medley
+WORKDIR /home/medley
 
 RUN adduser --disabled-password --gecos "" medley
 USER medley
-ENTRYPOINT USER=medley Xvnc -geometry 1280x720 :0 & DISPLAY=:0 PATH="/app/maiko:$PATH" ./run-medley -full -g 1280x720 -sc 1280x720
+ENTRYPOINT USER=medley Xvnc -geometry 1280x720 :0 & DISPLAY=:0 PATH="/app/maiko:$PATH" ./run-medley -full -g 1280x720 -sc 1280x720

README.md

@@ -1,26 +1,72 @@
 # Medley 
 
-
-
-
 This repository is for the Lisp environment of [Medley Interlisp](https://Interlisp.org).
 
-We've made great process in sorting out what we have (some dusty corners notwithstanding), but there's quite a bit more work to do. Please report problems!
+See the [Medley Interlisp Wiki](https://github.com/Interlisp/medley/wiki/) for an overview and pointers to available documentation.
 
-See [Medley Interlisp Wiki](https://github.com/Interlisp/medley/wiki/) for an overview, and other pointers.
+A sub-project is [Interlisp/maiko](https://github.com/Interlisp/maiko), which is the implementation (in C) of the Medley virtual machine.
 
-A sub-project is [Interlisp/maiko](https://github.com/Interlisp/maiko), which is the implementation (in C) of the Medley virtual machine. 
+## Using releases
+
+There currently are separate releases of medley and maiko; get the latest version of each.
+There (soon) will also be Docker containers with the latest, and a way to try out Medley in the cloud (without installing).
 
 
-## Instructions for Building and Running
+### Getting releases
+
+Get the Maiko release [here](https://github.com/Interlisp/maiko/releases). You'll need the one corresponding to your operating system and processor (for Windows with WSL or Intel linux, use `linux.x86_64`; for Macs use `darwin.x86_64` for Intel and `darwin.aarch64` for M1.)
+
+Or, build your own maiko (the binaries `lde` `ldex` and `ldeinit`.) We can build for other OS arch pairs depending on what is available for GitHub actions.
+
+The medley release comes in two parts, found [here](https://github.com/Interlisp/medley/releases)
+1. The "loadups" (download `medley-`YYMMDD`-loadups.tgz`)
+2. The "runtime" (download `medley-`YYMMDD`-runtime.tgz`)
+
+You don't need the "runtime" if you've cloned this (medley) repo.
+If you happen to have the 'gh' GitHub command line installed you can download both using
+```
+   gh release download -R Interlisp/medley -p "*"
+```
+but otherwise just click on the link(s) to the parts you need.
+
+### Unpacking releases
+
+From a shell/terminal window:
+
+1. Choose where you want to install medley and maiko.
+Unpack the medley loadups file
+
+*  `cd ` ~parent~
+*  `tar -xvfz medley-`YYMMDD`-loadups.tgz`
+
+2. Unpack the medley runtime OR clone the Medley repo
+   (the "medley runtime" is just a subset of the whole repo)
+   
+* `tar -xvfz medley-`YYMMDD`-runtime.tgz` 
+
+   OR
+   ```
+   git clone https://github.com/Interlisp/medley
+   ```
+   
+3. Unpack the maiko file for your operating system and CPU type, e.g.,
+
+   ```
+   tar -xvfz maiko-210823.linux.x86_64.tgz
+   ```
+
+3. This should leave you with two directories, `medley` and `maiko`.
 
 ### Setting up X
 
-Medley Interlisp needs an X-Server to manage its display. Most Linux desktops have one. There are a number of free open source X-servers for windows. Mac users should head over to [XQuartz.org](https://xquartz.org/releases) -- be sure to pick a version if you have a newer Mac.
+Medley Interlisp currently needs an X-Server to manage its display. Most Linux desktops have one. Windows 11 with WSL includes an X-Server. For Windows 10 with WSL2, there are a number of open-source X servers; for example vcxsrv.
+
+Mac users should get [XQuartz from XQuartz.org](https://xquartz.org/releases).
+
+Medley manages the display entirely, doesn't use X fonts and manages it's own window system.
 
 If you have a high-resolution display, note that much of the graphics was designed for a low-resolution display, so an X-server that does "pixel doublilng" is best. (E.g., Raspberry Pi does pixel doubling on 4K displays.) It also presumes you have a 3-button mouse; the scroll-wheel on some mice act as one with some difficulty.) XQuartz Preferences/Input has "Emulate three button mouse" option.
 
-
 ### Running Medley Interlisp
 
 The `run-medley` script in this repo sets up some convenient defaults. Running Medley can be done by typing:
@@ -35,9 +81,6 @@ Or, if you wish to start Medley up with a different SYSOUT:
 $ cd medley
 $ ./run-medley <SYSOUT-file-name>
 ```
-
-Once the system comes up, give it a few seconds to initialize.
-
 The first time the system is run it loads the system image that comes
 with the system.  When you exit the system (or "do a `SaveVM`" menu
 option) the state of your machine is saved in a file named
@@ -73,23 +116,34 @@ files. A .TEDIT or .TXT file is probably documentation
 for the package of same name, at least in the library,
 internal/library, lispusers.
 
+
+
+
+
 The current repo has both Lisp sources and compiled .LCOM and .DFASL
-files, because some files don't compile in a vanilla lisp.sysout .
+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
-- patches -- for cases where reloading doesn't wor
-- scripts  -- some scripts for fixing up things
-- sunloadup --  support information for making a new lisp.sysout from scratch
-- 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
+

docs/README.md

@@ -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
+ 
+ 

fonts/README.md

@@ -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
+ 

greetfiles/MEDLEYDIR-INIT

@@ -0,0 +1,64 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+
(FILECREATED " 2-Dec-2021 21:13:55" {DSK}<home>larry>medley>greetfiles>MEDLEYDIR-INIT.;3
 2392   
+
+      changes to%:  (VARS MEDLEYDIR-INITCOMS)
+                    (FNS INTERLISPMODE)
+
+      previous date%: "14-Nov-2021 22:34:49" {DSK}<home>larry>medley>greetfiles>MEDLEYDIR-INIT.;1)
+
+
+(PRETTYCOMPRINT MEDLEYDIR-INITCOMS)
+
+(RPAQQ MEDLEYDIR-INITCOMS

+       ([P (LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
+                              "")
+                         "/sources/MEDLEYDIR.LCOM"))
+           (MEDLEY-INIT-VARS)
+           (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
+        (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))
+        (FNS INTERLISPMODE)))
+
+(LOAD? (CONCAT (OR (UNIX-GETENV "MEDLEYDIR")
+                   "")
+              "/sources/MEDLEYDIR.LCOM"))
+
+(MEDLEY-INIT-VARS)
+
+(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE))
+
+(FILESLOAD BACKGROUND-YIELD)
+
+(RPAQQ FILING.ENUMERATION.DEPTH
 1)
+
+(RPAQ LOGINDIR
 (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
+                                      (UNIX-GETENV "HOME"))))
+
+(RPAQ USERGREETFILES
 `((,LOGINDIR "INIT" COM)
+                           (,LOGINDIR "INIT")))
+
+(RPAQQ COPYRIGHTSRESERVED
 NIL)
+(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 (1544 2369 (INTERLISPMODE 1554 . 2367)))))
+STOP

greetfiles/README.md

@@ -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.
+
+

greetfiles/initcommands.txt

@@ -1,4 +0,0 @@
-lldb ../../maiko/darwin.386/ldeinit
-
-break set -n error
-run ./INIT.DLINIT -INIT -NF

internal/library/MAKE-PS

@@ -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

internal/library/MEDLEY-UTILS

@@ -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

library/BIGBITMAPS

@@ -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

library/DATABASEFNS

@@ -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

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

library/MAIKOCOLOR

@@ -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

library/TEDIT

@@ -1,12 +1,11 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-
(FILECREATED "29-Sep-2021 22:16:28" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;11
 142247 
+
(FILECREATED "16-Dec-2021 12:34:26" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;21
 142324 
 
-      changes to%:  (FNS TEDIT-SEE)
+      :CHANGES-TO (FNS TEDIT-SEE)
 
-      previous date%: "19-Sep-2021 17:08:56" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDIT.;5)
+      :PREVIOUS-DATE "13-Oct-2021 10:00:40" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;20)
 
 
 (* ; "
@@ -27,9 +26,9 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
               (TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP))
               (TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU))
                                                              (* ; 
-
                                            "Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")

+
                                              "Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")

                                                              (* ; 
-
                                                  "Changed by yabu.fx, for SUNLOADUP without DWIM.")

+
                                                    "Changed by yabu.fx, for SUNLOADUP without DWIM.")

               )
         (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
         (FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT-SEE TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE 
@@ -40,10 +39,10 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
              \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1)
         (P (MOVD? 'NILL 'OBJECTOUTOFTEDIT))
                                                              (* ; 
-
                                  "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")

+
                                    "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")

         (COMS (FNS \CREATE.TEDIT.RESTART.MENU))
                                                              (* ; 
-
                                                    "Added by yabu.fx, for SUNLOADUP without DWIM.")

+
                                                      "Added by yabu.fx, for SUNLOADUP without DWIM.")

         (COMS                                                (* ; "Debugging functions")

               (FNS PLCHAIN PRINTLINE SEEFILE))
         (COMS                                                (* ; "Object-oriented editing")

@@ -56,10 +55,10 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
               (VARS TEDITSYSTEMDATE (TEDITSUPPORT "TEditSupport.PA"))
               (FNS MAKETEDITFORM)
               (P (ADDTOVAR LAFITESPECIALFORMS
 ("TEdit Report" 'MAKETEDITFORM 
-                                                         "Report a problem with TEdit"))
+                                                     "Report a problem with TEdit"))
                  (SETQ LAFITEFORMSMENU NIL)))
         (COMS                                                (* ; 
-
                         "LISTFILES Interface, so the system can decide if a file is a TEdit file.")

+
                           "LISTFILES Interface, so the system can decide if a file is a TEdit file.")

               (ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
                                               (EXTENSION (TEDIT])
 
@@ -330,8 +329,9 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
                 (RETURN PROC])
 
 (TEDIT-SEE

-  [LAMBDA (FILE WINDOW FORMAT)
                          (* ; "Edited 29-Sep-2021 22:16 by rmk:")


-                                                            (* ; "Edited 27-Feb-2021 20:07 by rmk:")


+  [LAMBDA (FILE WINDOW FORMAT TITLE)                         (* ; "Edited 16-Dec-2021 12:33 by rmk")

+                                                             (* ; "Edited 13-Oct-2021 10:00 by rmk:")

+                                                             (* ; "Edited 27-Feb-2021 20:07 by rmk:")

                                                              (* ; "Edited  1-Feb-88 19:00 by bvm:")

 
     (* ;; "See FILE in a scrollable READONLY TEDIT window.  If FILE is a LISP source file, copy first to a temporary NODIRCORE image file that interpretes the fontchange characters rather than showing black boxes.")

@@ -340,34 +340,32 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
 
     (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
            (LET ((SEESTREAM STREAM)
-                 ENV TSTREAM)
+                 TSTREAM)
 
                 (* ;; "No need to fiddle with a TEDIT file")

 
                 (IF
 (\TEDIT.FORMATTEDP1 STREAM)
-                  ELSEIF
 (SETQ ENV (LISPSOURCEFILEP STREAM))
+                  ELSEIF
 (LISPSOURCEFILEP STREAM)
                     THEN
 
+                         (* ;; "Lisp source file")

 
-                          (* ;; "Lisp source file")

-
-                          (SETFILEINFO STREAM 'FORMAT ENV)
-                          (SETQ SEESTREAM (OPENTEXTSTREAM))
-                          (COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
+                         (SETQ SEESTREAM (OPENTEXTSTREAM))
+                         (DSPFONT DEFAULTFONT SEESTREAM)
+                         (COPY.TEXT.TO.IMAGE STREAM SEESTREAM)
                   ELSE
 
+                       (* ;; "Not a Lisp source file and not a Tedit file.  If it is not random access, we copy it so we can scroll around.")

 
-                        (* ;; "Not a Lisp source file and not a Tedit file.  If it is not random access, we copy it so we can scroll around.")

+                       (* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")

 
-                        (* ;; "Maybe there is a conventional way of finding out the external format of a plain-text stream (an EMACS header?), here we nudge towards :UTF-8 (if it exists).")

-
-                        (SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
-                                                        *DEFAULT-EXTERNALFORMAT*))
-                        (CL:UNLESS (RANDACCESSP STREAM)
-                            (SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
-                            (COPYCHARS STREAM SEESTREAM)))
-                [SETQ TSTREAM (TEXTSTREAM
 (TEDIT
 SEESTREAM WINDOW NIL '(READONLY T]
-                (WINDOWPROP (WFROMDS TSTREAM)
+                       (SETFILEINFO STREAM 'FORMAT (OR FORMAT (FIND-FORMAT :UTF-8)
+                                                       :DEFAULT))
+                       (CL:UNLESS (RANDACCESSP STREAM)
+                           (SETQ SEESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
+                           (COPYCHARS STREAM SEESTREAM)))
+                [SETQ TSTREAM (TEXTSTREAM
 (TEDIT
 SEESTREAM WINDOW NIL `(READONLY T FONT ,DEFAULTFONT]
+                [WINDOWPROP (WFROMDS TSTREAM)
                        'TITLE
-                       (CONCAT "SEE window for " (FULLNAME STREAM)))
+                       (OR TITLE (CONCAT "SEE window for " (FULLNAME STREAM]
                 (FULLNAME STREAM])
 
 (TEDIT.CHARWIDTH

@@ -2235,7 +2233,7 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
 (* ; "TEDIT Support information")

 
 
-(RPAQQ TEDITSYSTEMDATE
 "29-Sep-2021 22:16:28")
+(RPAQQ TEDITSYSTEMDATE
 "16-Dec-2021 12:34:26")
 
 (RPAQ TEDITSUPPORT
 "TEditSupport.PA")
 (DEFINEQ
@@ -2257,23 +2255,23 @@ Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
 
 
 (ADDTOVAR PRINTFILETYPES
 (TEDIT (TEST \TEDIT.FORMATTEDP1)
-                                    (EXTENSION (TEDIT))))
+                                (EXTENSION (TEDIT))))
 (PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 
 1992 1993 1995 1999 2018 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (4329 117413 (\TEDIT2 4339 . 7090) (COERCETEXTOBJ 7092 . 15868) (TEDIT 15870 . 20839) (
-TEDIT-SEE 20841 . 23089) (TEDIT.CHARWIDTH 23091 . 25115) (TEDIT.COPY 25117 . 33553) (TEDIT.DELETE 
-33555 . 34245) (TEDIT.DO.BLUEPENDINGDELETE 34247 . 37314) (TEDIT.INSERT 37316 . 42846) (TEDIT.KILL 
-42848 . 44405) (TEDIT.MAPLINES 44407 . 45806) (TEDIT.MAPPIECES 45808 . 46764) (TEDIT.MOVE 46766 . 
-56550) (TEDIT.QUIT 56552 . 58552) (TEDIT.STRINGWIDTH 58554 . 59225) (TEDIT.\INSERT 59227 . 61252) (
-TEXTOBJ 61254 . 62379) (TEXTSTREAM 62381 . 63996) (\TEDIT.INCLUDE 63998 . 67898) (\TEDIT.INSERT.PIECES
- 67900 . 77815) (\TEDIT.MOVE.PIECEMAPFN 77817 . 79896) (\TEDIT.OBJECT.SHOWSEL 79898 . 83527) (
-\TEDIT.RESTARTFN 83529 . 85524) (\TEDIT.CHARDELETE 85526 . 89488) (\TEDIT.COPY.PIECEMAPFN 89490 . 
-92715) (\TEDIT.DELETE 92717 . 100235) (\TEDIT.DIFFUSE.PARALOOKS 100237 . 103001) (\TEDIT.FOREIGN.COPY?
- 103003 . 106730) (\TEDIT.QUIT 106732 . 109878) (\TEDIT.WORDDELETE 109880 . 114713) (\TEDIT1 114715 . 
-117411)) (117527 117643 (\CREATE.TEDIT.RESTART.MENU 117537 . 117641)) (117742 121431 (PLCHAIN 117752
- . 118026) (PRINTLINE 118028 . 120792) (SEEFILE 120794 . 121429)) (121472 141115 (TEDIT.INSERT.OBJECT 
-121482 . 130559) (TEDIT.EDIT.OBJECT 130561 . 132817) (TEDIT.FIND.OBJECT 132819 . 133712) (
-TEDIT.FIND.OBJECT.SUBTREE 133714 . 134520) (TEDIT.PUT.OBJECT 134522 . 136181) (TEDIT.GET.OBJECT 136183
- . 139382) (TEDIT.OBJECT.CHANGED 139384 . 141113)) (141393 141756 (MAKETEDITFORM 141403 . 141754)))))
+  (FILEMAP (NIL (4330 117494 (\TEDIT2 4340 . 7091) (COERCETEXTOBJ 7093 . 15869) (TEDIT 15871 . 20840) (
+TEDIT-SEE 20842 . 23170) (TEDIT.CHARWIDTH 23172 . 25196) (TEDIT.COPY 25198 . 33634) (TEDIT.DELETE 
+33636 . 34326) (TEDIT.DO.BLUEPENDINGDELETE 34328 . 37395) (TEDIT.INSERT 37397 . 42927) (TEDIT.KILL 
+42929 . 44486) (TEDIT.MAPLINES 44488 . 45887) (TEDIT.MAPPIECES 45889 . 46845) (TEDIT.MOVE 46847 . 
+56631) (TEDIT.QUIT 56633 . 58633) (TEDIT.STRINGWIDTH 58635 . 59306) (TEDIT.\INSERT 59308 . 61333) (
+TEXTOBJ 61335 . 62460) (TEXTSTREAM 62462 . 64077) (\TEDIT.INCLUDE 64079 . 67979) (\TEDIT.INSERT.PIECES
+ 67981 . 77896) (\TEDIT.MOVE.PIECEMAPFN 77898 . 79977) (\TEDIT.OBJECT.SHOWSEL 79979 . 83608) (
+\TEDIT.RESTARTFN 83610 . 85605) (\TEDIT.CHARDELETE 85607 . 89569) (\TEDIT.COPY.PIECEMAPFN 89571 . 
+92796) (\TEDIT.DELETE 92798 . 100316) (\TEDIT.DIFFUSE.PARALOOKS 100318 . 103082) (\TEDIT.FOREIGN.COPY?
+ 103084 . 106811) (\TEDIT.QUIT 106813 . 109959) (\TEDIT.WORDDELETE 109961 . 114794) (\TEDIT1 114796 . 
+117492)) (117608 117724 (\CREATE.TEDIT.RESTART.MENU 117618 . 117722)) (117823 121512 (PLCHAIN 117833
+ . 118107) (PRINTLINE 118109 . 120873) (SEEFILE 120875 . 121510)) (121553 141196 (TEDIT.INSERT.OBJECT 
+121563 . 130640) (TEDIT.EDIT.OBJECT 130642 . 132898) (TEDIT.FIND.OBJECT 132900 . 133793) (
+TEDIT.FIND.OBJECT.SUBTREE 133795 . 134601) (TEDIT.PUT.OBJECT 134603 . 136262) (TEDIT.GET.OBJECT 136264
+ . 139463) (TEDIT.OBJECT.CHANGED 139465 . 141194)) (141474 141837 (MAKETEDITFORM 141484 . 141835)))))
 STOP

library/TEDITMENU

@@ -1,11 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "29-Apr-2021 22:44:22" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;5
 275764 
 
-      changes to%:  (FNS \TEDIT.MENU.INIT)
+
(FILECREATED "26-Oct-2021 08:44:02" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;3
 276285 
 
-      previous date%: "29-Apr-2021 22:40:33" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;4)
+      changes to%:  (FNS \TEXTMENU.START)
+
+      previous date%: "29-Apr-2021 22:44:22" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITMENU.;1)
 
 
 (* ; "
@@ -19,7 +20,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
         (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
                (FILES (LOADCOMP)
                       TEDITDCL))
-        [COMS                                                (* ; "Simple Menu Button support")

+        [COMS                                                (* ; "Simple Menu Button support")

               (FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN 
                    MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MBUTTON.CREATE MBUTTON.CHANGENAME 
                    MBUTTON.FIND.BUTTON MBUTTON.FIND.NEXT.BUTTON MBUTTON.FIND.NEXT.FIELD MBUTTON.INIT
@@ -31,13 +32,13 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
               (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT))
                      (ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN]
         [COMS 
-              (* ;; 
-
            "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")

+              (* ;; 
+
            "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")

 
               (FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN 
                    MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT)
               (DECLARE%: DONTEVAL@LOAD DOCOPY (P (THREESTATE.INIT]
-        [COMS                                                (* ; "One-of-N Menu button sets")

+        [COMS                                                (* ; "One-of-N Menu button sets")

               (FNS MB.CREATE.NWAYBUTTON MB.NB.DISPLAYFN MB.NB.WHENOPERATEDFN MB.NB.SIZEFN 
                    MB.NWAYBUTTON.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS 
                    MB.NWAYBUTTON.ADDITEM)
@@ -45,7 +46,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
               (DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT))
                      (ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN]
         [COMS 
-              (* ;; "Two-state, toggling menu buttons.")

+              (* ;; "Two-state, toggling menu buttons.")

 
               (FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN 
                    \TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT 
@@ -54,7 +55,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
               (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT))
                      (ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN]
         [COMS 
-              (* ;; "Margin Setting and display")

+              (* ;; "Margin Setting and display")

 
               (FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN
                    MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK
@@ -66,11 +67,11 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
               (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT))
                      (ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN]
         (COMS 
-              (* ;; "Text menu creation and support")

+              (* ;; "Text menu creation and support")

 
               (FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN)
               (BITMAPS TEXTMENUICON TEXTMENUICONMASK))
-        [COMS                                                (* ; "TEdit-specific support")

+        [COMS                                                (* ; "TEdit-specific support")

               (FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN 
                    \TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN)
               (FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS 
@@ -82,7 +83,7 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
                    \TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS)
               (FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING 
                    TEDIT.UNPARSE.PAGEFORMAT)
-              (COMS                                          (* ; "Initialization Code")

+              (COMS                                          (* ; "Initialization Code")

                     (GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU 
                            TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC 
                            TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU)
@@ -2067,11 +2068,14 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
 (DEFINEQ
 
 (\TEXTMENU.START

-  [LAMBDA (MENU MAINWINDOW TITLE HEIGHT)
      (* ; 
+  [LAMBDA (MENU MAINWINDOW TITLE HEIGHT)
                (* ; "Edited 26-Oct-2021 08:43 by rmk:")


+                                                  (* ; 
 
                                                "Edited  4-Jun-93 11:59 by sybalsky:mv:envos")

 
     (* ;; "Create a TEdit-based menu for a given main window.")

 
+    (* ;; "RMK: Add MAX/MINSIZE so menus don't grow vertically when the main window is reshaped.  Not sure why HEIGHT is passed in or defaults to 133, but either way, the original window height should persist")

+
     (PROG ([WREG (COND
                     (MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION))
                     (T (GETREGION]
@@ -2104,6 +2108,9 @@ Copyright (c) 1983-1995, 2021 by Venue & Xerox Corporation.
                                                              (* ; 
 
                                                           "Mark this as a TEDIT MENU window")

           (ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE)
+          [SETQ HEIGHT (FETCH
 (REGION HEIGHT) OF
 (WINDOWPROP MENUW 'REGION]
+          (WINDOWPROP MENUW 'MAXSIZE (CONS 64000 HEIGHT))
+          (WINDOWPROP MENUW 'MINSIZE (CONS 0 HEIGHT))
           (SETQ MENUTEXT MENU)
           (replace
 (TEXTOBJ MENUFLG) of
 (fetch
 (TEXTSTREAM TEXTOBJ) of
 MENUTEXT)
              with
 T)
@@ -4524,20 +4531,20 @@ MB.CREATE.NWAYBUTTON 43946 . 47914) (MB.NB.DISPLAYFN 47916 . 50188) (MB.NB.WHENO
 85254 . 88164) (MB.MARGINBAR.SELFN 88166 . 100760) (MB.MARGINBAR.SIZEFN 100762 . 101124) (
 MB.MARGINBAR.DISPLAYFN 101126 . 103811) (MDESCALE 103813 . 104252) (MSCALE 104254 . 104588) (
 MB.MARGINBAR.SHOWTAB 104590 . 106761) (MB.MARGINBAR.TABTRACK 106763 . 108098) (\TEDIT.TABTYPE.SET 
-108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130317 (\TEXTMENU.START 112725 . 115917) (
-\TEXTMENU.DOC.CREATE 115919 . 127443) (TEXTMENU.CLOSEFN 127445 . 130315)) (130627 150691 (
-\TEDITMENU.CREATE 130637 . 130937) (\TEDIT.EXPANDED.MENU 130939 . 131643) (MB.DEFAULTBUTTON.FN 131645
- . 134517) (\TEDITMENU.RECORD.UNFORMATTED 134519 . 134857) (MB.DEFAULTBUTTON.ACTIONFN 134859 . 150689)
-) (150692 178075 (\TEDIT.CHARLOOKSMENU.CREATE 150702 . 152842) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152844
- . 153218) (\TEDIT.APPLY.BOLDNESS 153220 . 153505) (\TEDIT.APPLY.CHARLOOKS 153507 . 155438) (
-\TEDIT.APPLY.OLINE 155440 . 155721) (\TEDIT.SHOW.CHARLOOKS 155723 . 157636) (
-\TEDIT.NEUTRALIZE.CHARLOOKS 157638 . 158564) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158566 . 166219) (
-\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166221 . 169104) (\TEDIT.PARSE.CHARLOOKS.MENU 169106 . 177214) (
-\TEDIT.APPLY.SLOPE 177216 . 177499) (\TEDIT.APPLY.STRIKEOUT 177501 . 177788) (\TEDIT.APPLY.ULINE 
-177790 . 178073)) (178076 210142 (\TEDITPARAMENU.CREATE 178086 . 178466) (\TEDIT.EXPANDEDPARA.MENU 
-178468 . 178788) (\TEDIT.APPLY.PARALOOKS 178790 . 191020) (\TEDIT.SHOW.PARALOOKS 191022 . 202549) (
-\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202551 . 208622) (\TEDIT.RECORD.TABLEADERS 208624 . 210140)) (210143 
-248145 (\TEDIT.SHOW.PAGEFORMATTING 210153 . 226693) (\TEDITPAGEMENU.CREATE 226695 . 227738) (
-\TEDIT.APPLY.PAGEFORMATTING 227740 . 240111) (TEDIT.UNPARSE.PAGEFORMAT 240113 . 248143)) (248450 
-275299 (\TEDIT.MENU.INIT 248460 . 275297)))))
+108100 . 110807) (MARGINBAR.INIT 110809 . 111696)) (112715 130838 (\TEXTMENU.START 112725 . 116438) (
+\TEXTMENU.DOC.CREATE 116440 . 127964) (TEXTMENU.CLOSEFN 127966 . 130836)) (131148 151212 (
+\TEDITMENU.CREATE 131158 . 131458) (\TEDIT.EXPANDED.MENU 131460 . 132164) (MB.DEFAULTBUTTON.FN 132166
+ . 135038) (\TEDITMENU.RECORD.UNFORMATTED 135040 . 135378) (MB.DEFAULTBUTTON.ACTIONFN 135380 . 151210)
+) (151213 178596 (\TEDIT.CHARLOOKSMENU.CREATE 151223 . 153363) (\TEDIT.EXPANDEDCHARLOOKS.MENU 153365
+ . 153739) (\TEDIT.APPLY.BOLDNESS 153741 . 154026) (\TEDIT.APPLY.CHARLOOKS 154028 . 155959) (
+\TEDIT.APPLY.OLINE 155961 . 156242) (\TEDIT.SHOW.CHARLOOKS 156244 . 158157) (
+\TEDIT.NEUTRALIZE.CHARLOOKS 158159 . 159085) (\TEDIT.FILL.IN.CHARLOOKS.MENU 159087 . 166740) (
+\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166742 . 169625) (\TEDIT.PARSE.CHARLOOKS.MENU 169627 . 177735) (
+\TEDIT.APPLY.SLOPE 177737 . 178020) (\TEDIT.APPLY.STRIKEOUT 178022 . 178309) (\TEDIT.APPLY.ULINE 
+178311 . 178594)) (178597 210663 (\TEDITPARAMENU.CREATE 178607 . 178987) (\TEDIT.EXPANDEDPARA.MENU 
+178989 . 179309) (\TEDIT.APPLY.PARALOOKS 179311 . 191541) (\TEDIT.SHOW.PARALOOKS 191543 . 203070) (
+\TEDIT.NEUTRALIZE.PARALOOKS.MENU 203072 . 209143) (\TEDIT.RECORD.TABLEADERS 209145 . 210661)) (210664 
+248666 (\TEDIT.SHOW.PAGEFORMATTING 210674 . 227214) (\TEDITPAGEMENU.CREATE 227216 . 228259) (
+\TEDIT.APPLY.PAGEFORMATTING 228261 . 240632) (TEDIT.UNPARSE.PAGEFORMAT 240634 . 248664)) (248971 
+275820 (\TEDIT.MENU.INIT 248981 . 275818)))))
 STOP

library/TEDITWINDOW

@@ -1,11 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "19-Sep-2021 23:11:04" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;10
 186372 
 
-      changes to%:  (FNS \TEDIT.SCROLLFN)
+
(FILECREATED "16-Oct-2021 18:52:11" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;18
 187780 
 
-      previous date%: "19-Sep-2021 22:58:18" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;9)
+      changes to%:  (FNS TEDIT.DEACTIVATE.WINDOW)
+
+      previous date%: "12-Oct-2021 15:10:06" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITWINDOW.;17)
 
 
 (* ; "
@@ -25,6 +26,9 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
              \TEDIT.WINDOW.OPS \TEDIT.EXPANDFN \TEDIT.MAINW \TEDIT.PRIMARYW \TEDIT.COPYINSERTFN 
              \TEDIT.NEWREGIONFN \TEDIT.SET.WINDOW.EXTENT \TEDIT.SHRINK.ICONCREATE \TEDIT.SHRINKFN 
              \TEDIT.SPLITW \TEDIT.UNSPLITW \TEDIT.WINDOW.SETUP \SAFE.FIRST)
+        (INITVARS (\TEDIT.OP.WIDTH 12)
+               (\TEDIT.OP.BOTTOM 12))
+        (DECLARE%: DONTEVAL@LOAD DOCOPY (GLOBALVARS \TEDIT.OP.WIDTH \TEDIT.OP.BOTTOM))
         (CURSORS BXCARET BXHICARET TEDIT.LINECURSOR \TEDIT.SPLITCURSOR \TEDIT.MOVESPLITCURSOR 
                \TEDIT.UNSPLITCURSOR \TEDIT.MAKESPLITCURSOR)
         (INITVARS (TEDIT.DEFAULT.WINDOW NIL))
@@ -156,7 +160,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
     TEDIT.DEFAULT.WINDOW])
 
 (TEDIT.CURSORMOVEDFN

-  [LAMBDA (W)
                                            (* ; "Edited 30-May-91 23:39 by jds")

+  [LAMBDA (W)
                                           (* ; "Edited 12-Oct-2021 13:14 by rmk:")

 
          (* Watch the mouse and change the cursor to reflect the region of the window 
 
       it's in (line select, window split eventually?))

@@ -187,13 +191,18 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
                                                                           of
 LINE]
                 (SELECTQ (fetch
 (TEXTOBJ MOUSEREGION) of
 TEXTOBJ)
                     (TEXT [COND
-                             ((IGEQ X (SETQ LEFT (IDIFFERENCE (fetch
 (TEXTOBJ WRIGHT)
-                                                                 of
 TEXTOBJ)
-                                                        8)))
+                             ((AND (IGEQ X (SETQ LEFT (IDIFFERENCE (fetch
 (TEXTOBJ WRIGHT)
+                                                                      of
 TEXTOBJ)
+                                                             \TEDIT.OP.WIDTH)))
+                                   (IGEQ Y (IPLUS (fetch
 (TEXTOBJ WBOTTOM) of
 TEXTOBJ)
+                                                  \TEDIT.OP.BOTTOM)))
+
+                              (* ;; "The region to the right of text, for splitting operations.")

+
                               (CURSOR \TEDIT.SPLITCURSOR)
                               (replace
 (TEXTOBJ MOUSEREGION) of
 TEXTOBJ with
 'WINDOW)
                               (replace
 LEFT of
 CURSORREG with
 LEFT)
-                              (replace
 WIDTH of
 CURSORREG with
 8))
+                              (replace
 WIDTH of
 CURSORREG with
 \TEDIT.OP.WIDTH))
                              ([ILESSP X (SETQ LEFT
                                          (OR [AND LINE (COND
                                                           ((fetch
 (FMTSPEC FMTHARDCOPY)
@@ -221,13 +230,15 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
                                                                                     of
 TEXTOBJ)
                                                                            (IPLUS LEFT 8])
                     (LINE (COND
-                             ((IGEQ X (SETQ LEFT (IDIFFERENCE (fetch
 (TEXTOBJ WRIGHT)
-                                                                 of
 TEXTOBJ)
-                                                        8)))
+                             ((AND (IGEQ X (SETQ LEFT (IDIFFERENCE (fetch
 (TEXTOBJ WRIGHT)
+                                                                      of
 TEXTOBJ)
+                                                             \TEDIT.OP.WIDTH)))
+                                   (IGEQ Y (IPLUS (fetch
 (TEXTOBJ WBOTTOM) of
 TEXTOBJ)
+                                                  \TEDIT.OP.BOTTOM)))
                               (CURSOR \TEDIT.SPLITCURSOR)
                               (replace
 (TEXTOBJ MOUSEREGION) of
 TEXTOBJ with
 'WINDOW)
                               (replace
 LEFT of
 CURSORREG with
 LEFT)
-                              (replace
 WIDTH of
 CURSORREG with
 8))
+                              (replace
 WIDTH of
 CURSORREG with
 \TEDIT.OP.WIDTH))
                              [[IGEQ X (SETQ LEFT (OR [AND LINE (COND
                                                                   ((fetch
 (FMTSPEC FMTHARDCOPY)
                                                                       of
 (fetch
 (
@@ -256,13 +267,15 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
                              (T (replace
 LEFT of
 CURSORREG with
 0)
                                 (replace
 WIDTH of
 CURSORREG with
 LEFT))))
                     (WINDOW (COND
-                               ((IGEQ X (SETQ LEFT (IDIFFERENCE (fetch
 (TEXTOBJ WRIGHT)
-                                                                   of
 TEXTOBJ)
-                                                          8)))
+                               ((AND (IGEQ X (SETQ LEFT (IDIFFERENCE (fetch
 (TEXTOBJ WRIGHT)
+                                                                        of
 TEXTOBJ)
+                                                               \TEDIT.OP.WIDTH)))
+                                     (IGEQ Y (IPLUS (fetch
 (TEXTOBJ WBOTTOM) of
 TEXTOBJ)
+                                                    \TEDIT.OP.BOTTOM)))
                                 (replace
 (TEXTOBJ MOUSEREGION) of
 TEXTOBJ with

                                                                                   'WINDOW)
                                 (replace
 LEFT of
 CURSORREG with
 LEFT)
-                                (replace
 WIDTH of
 CURSORREG with
 8))
+                                (replace
 WIDTH of
 CURSORREG with
 \TEDIT.OP.WIDTH))
                                ([IGEQ X (SETQ LEFT
                                          (OR [AND LINE (COND
                                                           ((fetch
 (FMTSPEC FMTHARDCOPY)
@@ -795,17 +808,18 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
                               'SELECTED OSEL (fetch
 (TEXTOBJ STREAMHINT) of
 TEXTOBJ])])
 
 (\TEDIT.WINDOW.OPS

-  [LAMBDA (TEXTOBJ WINDOWTOSPLIT)
                        (* ; "Edited 30-May-91 23:33 by jds")

+  [LAMBDA (TEXTOBJ WINDOWTOSPLIT)
                       (* ; "Edited 12-Oct-2021 15:01 by rmk:")

 
 (* ;;; "Do window operations for TEdit, e.g., splitting a window, moving the split location, or unsplitting.")

 
     (PROG ([WINDOWOPREGION (create
 REGION
                                   LEFT _ (DIFFERENCE (fetch
 (TEXTOBJ WRIGHT) of
 TEXTOBJ)
-                                                8)
-                                  BOTTOM _ 0
-                                  WIDTH _ 8
-                                  HEIGHT _ (fetch
 HEIGHT of
 (WINDOWPROP WINDOWTOSPLIT
-                                                                           'REGION]
+                                                \TEDIT.OP.WIDTH)
+                                  BOTTOM _ \TEDIT.OP.BOTTOM
+                                  WIDTH _ \TEDIT.OP.WIDTH
+                                  HEIGHT _ (fetch
 (REGION HEIGHT) of
 (WINDOWPROP 
+                                                                                    WINDOWTOSPLIT
+                                                                                    'REGION]
            Y OPERATION)
           [while
 [AND (MOUSESTATE (OR LEFT MIDDLE RIGHT))
                           (INSIDE? WINDOWOPREGION (LASTMOUSEX WINDOWTOSPLIT)
@@ -845,7 +859,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
                            (\TEDIT.UNSPLITW
 WINDOWTOSPLIT))
                   (MOVE                                      (* ; 
 
                                                           "Moving the divider between two panes.")

-                        (TEDIT.PROMPTPRINT
 TEXTOBJ "Can't move the split point yet." T))
+                        (TEDIT.PROMPTPRINT
 TEXTOBJ "Split-point moving is not yet implemented" T))
                   (SHOULDNT)))
              (T (CURSOR T])
 
@@ -1366,6 +1380,16 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
         (CAR LIST.OR.ATOM))
        (T LIST.OR.ATOM])
 )
+
+(RPAQ? \TEDIT.OP.WIDTH
 12)
+
+(RPAQ? \TEDIT.OP.BOTTOM
 12)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \TEDIT.OP.WIDTH \TEDIT.OP.BOTTOM)
+)
+)
 (RPAQ BXCARET (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@CH@@CH@@FL@@FL@@LF@@
 ) (QUOTE NIL) 3 4))
 (RPAQ BXHICARET (CURSORCREATE (QUOTE #*(16 16)A@@@A@@@A@@@A@@@A@@@A@@@A@@@A@@@CH@@GL@@FL@@LF@@HB@@@@@@@@@@@@@@
@@ -1679,12 +1703,13 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
 (DEFINEQ
 
 (TEDIT.DEACTIVATE.WINDOW

-  [LAMBDA (W FORCEFLG DISCONNECTONLYFLG)
                 (* ; "Edited 30-May-91 23:34 by jds")

+  [LAMBDA (W FORCEFLG DISCONNECTONLYFLG)
                (* ; "Edited 16-Oct-2021 18:51 by rmk:")

 
     (* ;; "Deactivate the various button fns for this window")

 
     (PROG [(TEXTOBJ (WINDOWPROP W 'TEXTOBJ]                  (* ; 
 
                           "Can't be a call to TEXTOBJ, since window may NOT have a textobj on it.")

+          (replace
 (TEXTOBJ EDITFINISHEDFLG) of
 TEXTOBJ with
 T)
           [COND
              ((AND TEXTOBJ (fetch
 (TEXTOBJ EDITOPACTIVE) of
 TEXTOBJ))
 
@@ -1705,6 +1730,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
                     (RETURN 'DON'T]
           (COND
              ([AND TEXTOBJ (OR FORCEFLG (fetch
 (TEXTOBJ EDITFINISHEDFLG) of
 TEXTOBJ)
+                               (fetch
 (TEXTOBJ TXTREADONLY) of
 TEXTOBJ)
                                (NOT (PROCESSP (WINDOWPROP W 'PROCESS]
                                                              (* ; 
 
                                   "Only do this if it's a TEdit window, and has been QUIT out of.")

@@ -2830,25 +2856,25 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by John Sybalsky & Xerox Corporat
 (PUTPROPS TEDITWINDOW COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 
 1989 1990 1991 1993 1994 1999 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7117 93041 (TEDIT.CREATEW 7127 . 8263) (\TEDIT.CREATEW.FROM.REGION 8265 . 9249) (
-TEDIT.CURSORMOVEDFN 9251 . 19903) (TEDIT.CURSOROUTFN 19905 . 20440) (TEDIT.WINDOW.SETUP 20442 . 22251)
- (TEDIT.MINIMAL.WINDOW.SETUP 22253 . 30042) (\TEDIT.ACTIVE.WINDOWP 30044 . 31025) (
-\TEDIT.BUTTONEVENTFN 31027 . 56017) (\TEDIT.WINDOW.OPS 56019 . 59822) (\TEDIT.EXPANDFN 59824 . 60227) 
-(\TEDIT.MAINW 60229 . 61518) (\TEDIT.PRIMARYW 61520 . 62732) (\TEDIT.COPYINSERTFN 62734 . 63705) (
-\TEDIT.NEWREGIONFN 63707 . 66174) (\TEDIT.SET.WINDOW.EXTENT 66176 . 72278) (\TEDIT.SHRINK.ICONCREATE 
-72280 . 74552) (\TEDIT.SHRINKFN 74554 . 75129) (\TEDIT.SPLITW 75131 . 81232) (\TEDIT.UNSPLITW 81234 . 
-86928) (\TEDIT.WINDOW.SETUP 86930 . 92650) (\SAFE.FIRST 92652 . 93039)) (94187 95094 (TEDITWINDOWP 
-94197 . 95092)) (95131 97627 (TEDIT.GETINPUT 95141 . 97124) (\TEDIT.MAKEFILENAME 97126 . 97625)) (
-97676 104127 (TEDIT.PROMPTPRINT 97686 . 100590) (TEDIT.PROMPTFLASH 100592 . 102547) (
-\TEDIT.PROMPT.PAGEFULLFN 102549 . 104125)) (104362 108424 (TEXTSTREAM.TITLE 104372 . 104993) (
-\TEDIT.ORIGINAL.WINDOW.TITLE 104995 . 107040) (\TEDIT.WINDOW.TITLE 107042 . 107712) (
-\TEXTSTREAM.FILENAME 107714 . 108422)) (108467 153208 (TEDIT.DEACTIVATE.WINDOW 108477 . 115626) (
-\TEDIT.REPAINTFN 115628 . 118485) (\TEDIT.RESHAPEFN 118487 . 124107) (\TEDIT.SCROLLFN 124109 . 153206)
-) (153250 155299 (\TEDIT.PROCIDLEFN 153260 . 154609) (\TEDIT.PROCENTRYFN 154611 . 154904) (
-\TEDIT.PROCEXITFN 154906 . 155297)) (155378 166378 (\EDIT.DOWNCARET 155388 . 156069) (\EDIT.FLIPCARET 
-156071 . 157606) (TEDIT.FLASHCARET 157608 . 158722) (\EDIT.UPCARET 158724 . 159177) (
-TEDIT.NORMALIZECARET 159179 . 165130) (\SETCARET 165132 . 166052) (\TEDIT.CARET 166054 . 166376)) (
-166412 180167 (TEDIT.ADD.MENUITEM 166422 . 168337) (TEDIT.DEFAULT.MENUFN 168339 . 177606) (
-TEDIT.REMOVE.MENUITEM 177608 . 178609) (\TEDIT.CREATEMENU 178611 . 179064) (\TEDIT.MENU.WHENHELDFN 
-179066 . 179836) (\TEDIT.MENU.WHENSELECTEDFN 179838 . 180165)))))
+  (FILEMAP (NIL (7291 94107 (TEDIT.CREATEW 7301 . 8437) (\TEDIT.CREATEW.FROM.REGION 8439 . 9423) (
+TEDIT.CURSORMOVEDFN 9425 . 20811) (TEDIT.CURSOROUTFN 20813 . 21348) (TEDIT.WINDOW.SETUP 21350 . 23159)
+ (TEDIT.MINIMAL.WINDOW.SETUP 23161 . 30950) (\TEDIT.ACTIVE.WINDOWP 30952 . 31933) (
+\TEDIT.BUTTONEVENTFN 31935 . 56925) (\TEDIT.WINDOW.OPS 56927 . 60888) (\TEDIT.EXPANDFN 60890 . 61293) 
+(\TEDIT.MAINW 61295 . 62584) (\TEDIT.PRIMARYW 62586 . 63798) (\TEDIT.COPYINSERTFN 63800 . 64771) (
+\TEDIT.NEWREGIONFN 64773 . 67240) (\TEDIT.SET.WINDOW.EXTENT 67242 . 73344) (\TEDIT.SHRINK.ICONCREATE 
+73346 . 75618) (\TEDIT.SHRINKFN 75620 . 76195) (\TEDIT.SPLITW 76197 . 82298) (\TEDIT.UNSPLITW 82300 . 
+87994) (\TEDIT.WINDOW.SETUP 87996 . 93716) (\SAFE.FIRST 93718 . 94105)) (95437 96344 (TEDITWINDOWP 
+95447 . 96342)) (96381 98877 (TEDIT.GETINPUT 96391 . 98374) (\TEDIT.MAKEFILENAME 98376 . 98875)) (
+98926 105377 (TEDIT.PROMPTPRINT 98936 . 101840) (TEDIT.PROMPTFLASH 101842 . 103797) (
+\TEDIT.PROMPT.PAGEFULLFN 103799 . 105375)) (105612 109674 (TEXTSTREAM.TITLE 105622 . 106243) (
+\TEDIT.ORIGINAL.WINDOW.TITLE 106245 . 108290) (\TEDIT.WINDOW.TITLE 108292 . 108962) (
+\TEXTSTREAM.FILENAME 108964 . 109672)) (109717 154616 (TEDIT.DEACTIVATE.WINDOW 109727 . 117034) (
+\TEDIT.REPAINTFN 117036 . 119893) (\TEDIT.RESHAPEFN 119895 . 125515) (\TEDIT.SCROLLFN 125517 . 154614)
+) (154658 156707 (\TEDIT.PROCIDLEFN 154668 . 156017) (\TEDIT.PROCENTRYFN 156019 . 156312) (
+\TEDIT.PROCEXITFN 156314 . 156705)) (156786 167786 (\EDIT.DOWNCARET 156796 . 157477) (\EDIT.FLIPCARET 
+157479 . 159014) (TEDIT.FLASHCARET 159016 . 160130) (\EDIT.UPCARET 160132 . 160585) (
+TEDIT.NORMALIZECARET 160587 . 166538) (\SETCARET 166540 . 167460) (\TEDIT.CARET 167462 . 167784)) (
+167820 181575 (TEDIT.ADD.MENUITEM 167830 . 169745) (TEDIT.DEFAULT.MENUFN 169747 . 179014) (
+TEDIT.REMOVE.MENUITEM 179016 . 180017) (\TEDIT.CREATEMENU 180019 . 180472) (\TEDIT.MENU.WHENHELDFN 
+180474 . 181244) (\TEDIT.MENU.WHENSELECTEDFN 181246 . 181573)))))
 STOP

library/TEXTOFD

@@ -1,11 +1,11 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED " 6-May-2021 10:18:06" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley2>library>TEXTOFD.;4
 176139 
 
-      changes to%:  (FNS \TEXTINIT)
+
(FILECREATED "22-Dec-2021 10:29:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;12
 182752 
 
-      previous date%: "11-Feb-2001 12:06:42" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley2>library>TEXTOFD.;2)
+      :CHANGES-TO (FNS \TEXTBIN \TEXTPEEKBIN)
+
+      :PREVIOUS-DATE "22-Dec-2021 10:01:53" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEXTOFD.;11)
 
 
 (* ; "
@@ -25,24 +25,24 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
         (FNS \INSERTCH \INSERTCR)
         (COMS 
 
-(* ;;; "Functions to manipulate the Piece Table (PCTB)")

+(* ;;; "Functions to manipulate the Piece Table (PCTB)")

 
               (FNS \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE 
                    \INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE))
-        (COMS                                                (* ; 
-
                                                           "Generic-IO type operations support")

+        (COMS                                                (* ; 
+
                                                             "Generic-IO type operations support")

               (FNS \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR 
                    \TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR 
-                   \TEXTBOUT \TEDITOUTCHARFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION 
+                   \TEXTBOUT \TEDITOUTCCODEFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION 
                    \TEXTDSPYPOSITION \TEXTLEFTMARGIN \TEXTRIGHTMARGIN \TEXTDSPCHARWIDTH 
                    \TEXTDSPSTRINGWIDTH \TEXTDSPLINEFEED)
               (FNS \TEXTBIN \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP 
                    \TEDIT.TEXTBIN.NEW.PAGE)
               (FNS \TEXTPEEKBIN \TEDIT.PEEKBIN.NEW.PAGE))
-        (COMS                                                (* ; "Support for TEXTPROP")

+        (COMS                                                (* ; "Support for TEXTPROP")

               (FNS CGETTEXTPROP CTEXTPROP GETTEXTPROP PUTTEXTPROP TEXTPROP))
         [COMS 
-              (* ;; "Support for error handling:  The old error handler for the stream-not-open error.  This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)")

+              (* ;; "Support for error handling:  The old error handler for the stream-not-open error.  This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)")

 
               (INITVARS (*TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN]
         (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTINIT)))
@@ -676,29 +676,29 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
           (RETURN PC])
 
 (\TEXTINIT

-  [LAMBDA NIL
                                           (* ; "Edited  6-May-2021 10:17 by rmk:")

-                                                             (* ; 
-
                                          "Create the FDEV and STREAM prototypes for TEXT streams.")

+  [LAMBDA NIL
                                           (* ; "Edited  7-Oct-2021 08:40 by rmk:")

+                                                             (* ; 
+
                                          "Create the FDEV and STREAM prototypes for TEXT streams.")

 
-    (* ;; "TEXT streams make use of the following STREAM fields:")

+    (* ;; "TEXT streams make use of the following STREAM fields:")

 
-    (* ;; "(DEVICE (* FDEV of this guy -- The TEXT device)")

+    (* ;; "(DEVICE (* FDEV of this guy -- The TEXT device)")

 
-    (* ;; "F1 (* The STREAM for the PFILE of the current piece (or NIL))")

+    (* ;; "F1 (* The STREAM for the PFILE of the current piece (or NIL))")

 
-    (* ;; "F2 (* # chars left in piece at end of underlying file's page)")

+    (* ;; "F2 (* # chars left in piece at end of underlying file's page)")

 
-    (* ;; "F3 (* The TEXTOBJ for this stream)")

+    (* ;; "F3 (* The TEXTOBJ for this stream)")

 
-    (* ;; "F4")

+    (* ;; "F4")

 
-    (* ;; "F5 (* The PIECE we're currently inside)")

+    (* ;; "F5 (* The PIECE we're currently inside)")

 
-    (* ;; "(FW6 WORD) (* CPAGE for the start of the piece, for BACKFILEPTR)")

+    (* ;; "(FW6 WORD) (* CPAGE for the start of the piece, for BACKFILEPTR)")

 
-    (* ;; "(FW7 WORD) (* COFFSET for the start of the piece, for BACKFILEPTR)")

+    (* ;; "(FW7 WORD) (* COFFSET for the start of the piece, for BACKFILEPTR)")

 
-    (* ;; "(FW8 WORD)")

+    (* ;; "(FW8 WORD)")

 
     (SETQ \TEXTIMAGEOPS (create
 IMAGEOPS
                                IMAGETYPE _ 'TEXT
@@ -745,6 +745,9 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
                            FDEXTENDABLE _ NIL
                            TRUNCATEFILE _ (FUNCTION NILL)
                            WRITEPAGES _ (FUNCTION NILL)))
+
+    (* ;; "The prototypical Text stream")

+
     (SETQ \TEXTOFD
      (create
 STREAM
             BINABLE _ T
@@ -761,10 +764,16 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
             FW7 _ 0
             MAXBUFFERS _ 10
             IMAGEOPS _ \TEXTIMAGEOPS
-            IMAGEDATA _ (create
 TEXTIMAGEDATA)
-            OUTCHARFN _ (FUNCTION \TEDITOUTCHARFN)))         (* ; "The prototypical Text stream")

+            IMAGEDATA _ (create
 TEXTIMAGEDATA)))
 
-    (* ;; "Set up so that FILE NOT OPENs on TEdit streams are caught and fixed.")

+    (* ;; "Maybe more functions later?")

+
+    (MAKE-EXTERNALFORMAT :TEDIT NIL NIL NIL (FUNCTION \TEDITOUTCCODEFN)
+           NIL
+           'CR)
+    (\EXTERNALFORMAT \TEXTOFD :TEDIT)
+
+    (* ;; "Set up so that FILE NOT OPENs on TEdit streams are caught and fixed.")

 
     (CL:SETF (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN)
            (FUNCTION (LAMBDA (CONDITION)
@@ -772,8 +781,8 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
                             (COND
                                [(AND (BOUNDP 'ERRORPOS)
                                      (TEXTSTREAMP
 STREAM))
-                                                             (* ; 
-
           "This happened in the error handler, and it happened to a TEdit stream, so try the fix:")

+                                                             (* ; 
+
           "This happened in the error handler, and it happened to a TEdit stream, so try the fix:")

                                 (LET ((XCL::RESULT (REOPENTEXTSTREAM
 STREAM)))
                                      (CL:WHEN XCL::RESULT
                                          (ENVAPPLY (STKNAME ERRORPOS)
@@ -781,8 +790,8 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
                                                 (STKNTH -1 ERRORPOS ERRORPOS)
                                                 ERRORPOS T T))]
                                (*TEDIT-OLD-STREAM-ERROR-HANDLER* 
-                                                             (* ; 
-
                         "Some other kind of stream, so punt to the old handler (if there is one):")

+                                                             (* ; 
+
                         "Some other kind of stream, so punt to the old handler (if there is one):")

                                       (APPLY* *TEDIT-OLD-STREAM-ERROR-HANDLER* CONDITION])
 
 (\TEXTMARK

@@ -1782,10 +1791,10 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
           (freplace
 (TEXTSTREAM CHARSLEFT) of
 STREAM with
 0)
           (freplace
 (TEXTSTREAM REALFILE) of
 STREAM with
 NIL])
 
-(\TEDITOUTCHARFN

-  [LAMBDA (STREAM CHARCODE)
                              (* ; "Edited 31-May-91 14:19 by jds")

+(\TEDITOUTCCODEFN

+  [LAMBDA (STREAM CHARCODE)
                             (* ; "Edited 12-Oct-2021 15:38 by rmk:")

 
-    (* ;; "OUTCHARFN for TEdit streams -- always BOUTs the character, because TEdit streams deal in complete charcodes rather than bytes. BUT -- does update the CHARPOSITION of the stream, which is used by some code to decide things.")

+    (* ;; "OUTCCODEFN for TEdit streams -- always BOUTs the character, because TEdit streams deal in complete charcodes rather than bytes (via \TEXTBOUT). BUT -- does update the CHARPOSITION of the stream, which is used by some code to decide things.")

 
     (COND
        ((EQ CHARCODE (CHARCODE EOL))
@@ -1903,214 +1912,248 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
 (DEFINEQ
 
 (\TEXTBIN

-  [LAMBDA (STREAM)
                                       (* ; "Edited 28-Mar-94 15:33 by jds")

+  [LAMBDA (STREAM)
+
+    (* ;; "Edited 22-Dec-2021 10:29 by rmk: Return value of OBJECTCHAR property for image objecdts")

+
+    (* ;; "Edited 28-Mar-94 15:33 by jds")

 
 (* ;;; "Do BIN slow case for a text stream")

                                                              (* ; 
-
                               "NB that PEEKBIN and BACKFILEPTR need to track changes in this code")

+
                                 "NB that PEEKBIN and BACKFILEPTR need to track changes in this code")

     (DECLARE
 (LOCALVARS . T))
-    (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
-          (COND
-             [(ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
-                     (fetch
 (STREAM CBUFSIZE) of
 STREAM))
+    (LET (BYTE)                                              (* ; 
+
                               "RMK:  Capture all return values for any special imageobject coercion")

+         [SETQ BYTE (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
+                          (COND
+                             [(ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
+                                     (fetch
 (STREAM CBUFSIZE) of
 STREAM))
                                                              (* ; 
-
                                                           "Simple case -- just do the usual BIN")

-              (COND
-                 [(SETQ PO (fetch
 (PIECE POBJ) of
 (fetch
 (TEXTSTREAM PIECE) of
 STREAM
-                                                                 )))
+
                                                             "Simple case -- just do the usual BIN")

+                              (COND
+                                 [(SETQ PO (fetch
 (PIECE POBJ) of
 (fetch
 (TEXTSTREAM PIECE)
+                                                                     of
 STREAM)))
                                                              (* ; "Handle objects specially")

-                  (COND
-                     ((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
+                                  (COND
+                                     ((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
                                                              (* ; 
-
                                       "If this object has a substream in it, go to that substream")

-                      (add
 (fetch
 (STREAM COFFSET) of
 STREAM)
-                             1)
-                      (RETURN (\BIN SUBSTREAM)))
-                     (T 
-                        (* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")

+
                                         "If this object has a substream in it, go to that substream")

+                                      (add
 (fetch
 (STREAM COFFSET) of
 STREAM)
+                                           1)
+                                      (RETURN (\BIN SUBSTREAM)))
+                                     (T 
+                                        (* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")

 
-                        (replace
 (STREAM COFFSET) of
 STREAM with
 (fetch
 (STREAM
-                                                                                         CBUFSIZE)
-                                                                                of
 STREAM))
-                        (replace
 (TEXTSTREAM CHARSLEFT) of
 STREAM with
 0)
-                        (RETURN PO]
-                 [(fetch
 (TEXTSTREAM FATSTREAMP) of
 STREAM)
+                                        (replace
 (STREAM COFFSET) of
 STREAM
+                                           with
 (fetch
 (STREAM CBUFSIZE) of
 STREAM))
+                                        (replace
 (TEXTSTREAM CHARSLEFT) of
 STREAM with
 0)
+                                        (RETURN PO]
+                                 [(fetch
 (TEXTSTREAM FATSTREAMP) of
 STREAM)
                                                              (* ; 
-
                                                           "This is a 16 bit BIN.  grab 2 bytes.")

+
                                                             "This is a 16 bit BIN.  grab 2 bytes.")

                                                              (* ; 
-
                                             "WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")

-                  (RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
-                                        256)
-                                 (COND
-                                    ((ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
-                                            (fetch
 (STREAM CBUFSIZE) of
 STREAM))
+
                                               "WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")

+                                  (RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
+                                                        256)
+                                                 (COND
+                                                    ((ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
+                                                            (fetch
 (STREAM CBUFSIZE) of
 STREAM))
                                                              (* ; 
-
            "This pair of characters doesn't straddle a file page bound.  Just grab the next char.")

-                                     (\PAGEDBIN STREAM))
-                                    (T                       (* ; 
-
      "Need to move to the next page on the backing file.  Doing so also grabs the next character.")

-                                       (\TEDIT.TEXTBIN.NEW.PAGE
 STREAM T]
-                 (T (RETURN (\PAGEDBIN STREAM]
-             (T                                              (* ; 
-
                                       "We've either hit a page bound in a file, or a piece bound.")

-                (RETURN (COND
-                           [(ZEROP (fetch
 (TEXTSTREAM CHARSLEFT) of
 STREAM))
+
              "This pair of characters doesn't straddle a file page bound.  Just grab the next char.")

+                                                     (\PAGEDBIN STREAM))
+                                                    (T       (* ; 
+
        "Need to move to the next page on the backing file.  Doing so also grabs the next character.")

+                                                       (\TEDIT.TEXTBIN.NEW.PAGE
 STREAM T]
+                                 (T (RETURN (\PAGEDBIN STREAM]
+                             (T                              (* ; 
+
                                         "We've either hit a page bound in a file, or a piece bound.")

+                                (RETURN (COND
+                                           [(ZEROP (fetch
 (TEXTSTREAM CHARSLEFT) of
 STREAM))
                                                              (* ; "Time for a new piece.")

-                            [repeatwhile
 (AND PC (ZEROP (fetch
 (PIECE PLEN) of
 PC)))
-                               do
                        (* ; 
-
                                         "Skip over any zero-length pieces at the end of the file.")

-                                     (SETQ OPC (fetch
 (TEXTSTREAM PIECE) of
 STREAM))
-                                     (SETQ PC (replace
 (TEXTSTREAM PIECE) of
 STREAM
-                                                 with
 (AND OPC (fetch
 (PIECE NEXTPIECE)
-                                                                      of
 OPC]
-                            (replace
 (STREAM BINABLE) of
 STREAM with
 T)
-                            (replace
 (TEXTSTREAM FATSTREAMP) of
 STREAM with
 NIL)
+                                            [repeatwhile
 (AND PC (ZEROP (fetch
 (PIECE PLEN)
+                                                                           of
 PC)))
+                                               do
            (* ; 
+
                                           "Skip over any zero-length pieces at the end of the file.")

+                                                  (SETQ OPC (fetch
 (TEXTSTREAM PIECE) of
 STREAM))
+                                                  (SETQ PC (replace
 (TEXTSTREAM PIECE) of
 STREAM
+                                                              with
 (AND OPC (fetch
 (PIECE NEXTPIECE)
+                                                                               of
 OPC]
+                                            (replace
 (STREAM BINABLE) of
 STREAM with
 T)
+                                            (replace
 (TEXTSTREAM FATSTREAMP) of
 STREAM with
 NIL)
                                                              (* ; 
-
                                                           "Move to the next piece in the chain")

-                            (COND
-                               [PC                           (* ; 
-
                                                           "There IS a next piece to move to.")

-                                   (AND (fetch
 (TEXTSTREAM LOOKSUPDATEFN) of
 STREAM)
-                                        (SETQ NPC (APPLY* (fetch
 (TEXTSTREAM LOOKSUPDATEFN)
-                                                             of
 STREAM)
-                                                         STREAM PC))
-                                        (replace
 (TEXTSTREAM PIECE) of
 STREAM
-                                           with
 (SETQ PC NPC)))
+
                                                             "Move to the next piece in the chain")

+                                            (COND
+                                               [PC           (* ; "There IS a next piece to move to.")

+                                                   (AND (fetch
 (TEXTSTREAM LOOKSUPDATEFN)
+                                                           of
 STREAM)
+                                                        (SETQ NPC (APPLY* (fetch
 (TEXTSTREAM 
+                                                                                        LOOKSUPDATEFN
+                                                                                        )
+                                                                             of
 STREAM)
+                                                                         STREAM PC))
+                                                        (replace
 (TEXTSTREAM PIECE) of
 STREAM
+                                                           with
 (SETQ PC NPC)))
                                                              (* ; 
-
 "Take care of any piece-change uproar.  uproar -- which may include picking a new piece to go to.")

-                                   [COND
-                                      (NPC                   (* ; 
-
                                    "If we got an NPC, this was taken care of by the LOOKSUPDATEFN")

-                                           )
-                                      ([AND (SETQ PO (fetch
 (PIECE POBJ) of
 PC))
-                                            (SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM]
-                                       (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM TEXTOBJ)
-                                                             of
 SUBSTREAM))
-                                       (replace
 (TEXTSTREAM CURRENTPARALOOKS) of
 STREAM
-                                          with
 (fetch
 (TEXTSTREAM CURRENTPARALOOKS)
-                                                      of
 SUBSTREAM))
-                                       (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
-                                          with
 (fetch
 (TEXTSTREAM CURRENTLOOKS) of
 
-                                                                                            SUBSTREAM
-                                                          )))
-                                      [(NEQ (fetch
 (PIECE PPARALOOKS) of
 OPC)
-                                            (fetch
 (PIECE PPARALOOKS) of
 PC))
-                                       (replace
 (TEXTSTREAM CURRENTPARALOOKS) of
 STREAM
-                                          with
 (\TEDIT.APPLY.PARASTYLES (fetch
 (PIECE 
-                                                                                           PPARALOOKS
-                                                                                              )
-                                                                               of
 PC)
-                                                          PC
-                                                          (fetch
 (TEXTSTREAM TEXTOBJ)
-                                                             of
 STREAM)))
-                                       (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
-                                          with
 (\TEDIT.APPLY.STYLES (fetch
 (PIECE PLOOKS)
-                                                                           of
 PC)
-                                                          PC
-                                                          (fetch
 (TEXTSTREAM TEXTOBJ)
-                                                             of
 STREAM]
-                                      ((NOT (EQCLOOKS (fetch
 (PIECE PLOOKS) of
 PC)
-                                                   (fetch
 (PIECE PLOOKS) of
 OPC)))
-                                       (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
-                                          with
 (\TEDIT.APPLY.STYLES (fetch
 (PIECE PLOOKS)
-                                                                           of
 PC)
-                                                          PC
-                                                          (fetch
 (TEXTSTREAM TEXTOBJ)
-                                                             of
 STREAM]
-                                   (COND
-                                      ((SETQ PS (fetch
 (PIECE PSTR) of
 PC))
+
   "Take care of any piece-change uproar.  uproar -- which may include picking a new piece to go to.")

+                                                   [COND
+                                                      (NPC   (* ; 
+
                                      "If we got an NPC, this was taken care of by the LOOKSUPDATEFN")

+                                                           )
+                                                      ([AND (SETQ PO (fetch
 (PIECE POBJ) of
 PC))
+                                                            (SETQ SUBSTREAM (IMAGEOBJPROP
+                                                                             PO
+                                                                             'SUBSTREAM]
+                                                       (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM TEXTOBJ)
+                                                                         of
 SUBSTREAM))
+                                                       (replace
 (TEXTSTREAM CURRENTPARALOOKS)
+                                                          of
 STREAM with
 (fetch
 (TEXTSTREAM 
+                                                                                     CURRENTPARALOOKS
+                                                                                       ) of
 SUBSTREAM
+                                                                                ))
+                                                       (replace
 (TEXTSTREAM CURRENTLOOKS)
+                                                          of
 STREAM with
 (fetch
 (TEXTSTREAM 
+                                                                                       CURRENTLOOKS)
+                                                                            of
 SUBSTREAM)))
+                                                      [(NEQ (fetch
 (PIECE PPARALOOKS) of
 OPC)
+                                                            (fetch
 (PIECE PPARALOOKS) of
 PC))
+                                                       (replace
 (TEXTSTREAM CURRENTPARALOOKS)
+                                                          of
 STREAM with
 (\TEDIT.APPLY.PARASTYLES
+                                                                          (fetch
 (PIECE PPARALOOKS)
+                                                                             of
 PC)
+                                                                          PC
+                                                                          (fetch
 (TEXTSTREAM TEXTOBJ)
+                                                                             of
 STREAM)))
+                                                       (replace
 (TEXTSTREAM CURRENTLOOKS)
+                                                          of
 STREAM with
 (\TEDIT.APPLY.STYLES
+                                                                          (fetch
 (PIECE PLOOKS)
+                                                                             of
 PC)
+                                                                          PC
+                                                                          (fetch
 (TEXTSTREAM TEXTOBJ)
+                                                                             of
 STREAM]
+                                                      ((NOT (EQCLOOKS (fetch
 (PIECE PLOOKS)
+                                                                         of
 PC)
+                                                                   (fetch
 (PIECE PLOOKS) of
 OPC)))
+                                                       (replace
 (TEXTSTREAM CURRENTLOOKS)
+                                                          of
 STREAM with
 (\TEDIT.APPLY.STYLES
+                                                                          (fetch
 (PIECE PLOOKS)
+                                                                             of
 PC)
+                                                                          PC
+                                                                          (fetch
 (TEXTSTREAM TEXTOBJ)
+                                                                             of
 STREAM]
+                                                   (COND
+                                                      ((SETQ PS (fetch
 (PIECE PSTR) of
 PC))
                                                              (* ; "This piece lives in a string.")

-                                       (\TEDIT.TEXTBIN.STRINGSETUP
 0 (fetch
 (PIECE PLEN)
-                                                                            of
 PC)
-                                              STREAM PS)
+                                                       (\TEDIT.TEXTBIN.STRINGSETUP

+                                                        0
+                                                        (fetch
 (PIECE PLEN) of
 PC)
+                                                        STREAM PS)
 
                                  (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")

                                                              (* ; 
-
                                "Then actually grab the next character to hand back to the caller.")

-                                       (\BIN STREAM))
-                                      ((SETQ PF (fetch
 (PIECE PFILE) of
 PC))
+
                                  "Then actually grab the next character to hand back to the caller.")

+                                                       (\BIN STREAM))
+                                                      ((SETQ PF (fetch
 (PIECE PFILE) of
 PC))
                                                              (* ; "This piece lives on a file.")

-                                       (\TEDIT.TEXTBIN.FILESETUP
 PC 0 (fetch
 (PIECE PLEN)
-                                                                             of
 PC)
-                                              STREAM PF (fetch
 (PIECE PFATP) of
 PC)
-                                              'PEEKBIN)
-                                       (\BIN STREAM))
-                                      [(SETQ PO (fetch
 (PIECE POBJ) of
 PC))
-                                       (replace
 (STREAM BINABLE) of
 STREAM with
 NIL)
-                                       (COND
-                                          (SUBSTREAM         (* ; 
-
                                          "There is a stream below this one, to feed chars upward.")

-                                                 (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM TEXTOBJ)
-                                                                       of
 SUBSTREAM))
-                                                 (freplace
 (STREAM COFFSET) of
 STREAM
-                                                    with
 0)
-                                                 (freplace
 (TEXTSTREAM CHARSLEFT) of
 STREAM
-                                                    with
 (fetch
 (PIECE PLEN) of
 PC))
-                                                 (freplace
 (STREAM CBUFSIZE) of
 STREAM
-                                                    with
 (fetch
 (PIECE PLEN) of
 PC))
-                                                 (freplace
 (STREAM CPAGE) of
 STREAM
-                                                    with
 0)
-                                                 (freplace
 (TEXTSTREAM PCSTARTCH) of
 STREAM
-                                                    with
 0)
-                                                 (freplace
 (TEXTSTREAM PCSTARTPG) of
 STREAM
-                                                    with
 0)
-                                                 (replace
 (TEXTSTREAM CURRENTPARALOOKS)
-                                                    of
 STREAM with
 (fetch
 (TEXTSTREAM
-                                                                                       
-                                                                                     CURRENTPARALOOKS
-                                                                                       ) of

-                                                                                         SUBSTREAM))
-                                                 (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
-                                                    with
 (fetch
 (TEXTSTREAM CURRENTLOOKS)
-                                                                of
 SUBSTREAM))
-                                                 (RETURN (\BIN SUBSTREAM)))
-                                          (T (replace
 (TEXTSTREAM CHARSLEFT) of
 STREAM
-                                                with
 0)
-                                             (RETURN PO]
-                                      (T (ERROR "CAN'T GET TO NEXT PIECE"]
-                               (T                            (* ; 
-
                                                       "There are no more pieces.  Punt gracefully")

-                                  (COND
-                                     ((fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM)
+                                                       (\TEDIT.TEXTBIN.FILESETUP
 PC 0
+                                                              (fetch
 (PIECE PLEN) of
 PC)
+                                                              STREAM PF (fetch
 (PIECE PFATP)
+                                                                           of
 PC)
+                                                              'PEEKBIN)
+                                                       (\BIN STREAM))
+                                                      [(SETQ PO (fetch
 (PIECE POBJ) of
 PC))
+                                                       (replace
 (STREAM BINABLE) of
 STREAM
+                                                          with
 NIL)
+                                                       (COND
+                                                          (SUBSTREAM 
                                                              (* ; 
-
                                           "If there's an EOF handler, call it & return the result")

-                                      (RETURN (APPLY* (fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM
-                                                             )
-                                                     STREAM)))
-                                     (T                      (* ; "Otherwise, return NIL")

-                                        (RETURN NIL]
-                           [(SETQ PO (fetch
 (PIECE POBJ) of
 (fetch
 (TEXTSTREAM PIECE)
-                                                                       of
 STREAM)))
+
                                            "There is a stream below this one, to feed chars upward.")

+                                                                 (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM
+                                                                                        TEXTOBJ)
+                                                                                   of
 SUBSTREAM))
+                                                                 (freplace
 (STREAM COFFSET)
+                                                                    of
 STREAM with
 0)
+                                                                 (freplace
 (TEXTSTREAM CHARSLEFT)
+                                                                    of
 STREAM
+                                                                    with
 (fetch
 (PIECE PLEN)
+                                                                            of
 PC))
+                                                                 (freplace
 (STREAM CBUFSIZE)
+                                                                    of
 STREAM
+                                                                    with
 (fetch
 (PIECE PLEN)
+                                                                            of
 PC))
+                                                                 (freplace
 (STREAM CPAGE)
+                                                                    of
 STREAM with
 0)
+                                                                 (freplace
 (TEXTSTREAM PCSTARTCH)
+                                                                    of
 STREAM with
 0)
+                                                                 (freplace
 (TEXTSTREAM PCSTARTPG)
+                                                                    of
 STREAM with
 0)
+                                                                 (replace
 (TEXTSTREAM 
+                                                                                 CURRENTPARALOOKS)
+                                                                    of
 STREAM
+                                                                    with
 (fetch
 (TEXTSTREAM 
+                                                                                     CURRENTPARALOOKS
+                                                                                       ) of
 SUBSTREAM
+                                                                                ))
+                                                                 (replace
 (TEXTSTREAM CURRENTLOOKS)
+                                                                    of
 STREAM
+                                                                    with
 (fetch
 (TEXTSTREAM 
+                                                                                       CURRENTLOOKS)
+                                                                            of
 SUBSTREAM))
+                                                                 (RETURN (\BIN SUBSTREAM)))
+                                                          (T (replace
 (TEXTSTREAM CHARSLEFT)
+                                                                of
 STREAM with
 0)
+                                                             (RETURN PO]
+                                                      (T (ERROR "CAN'T GET TO NEXT PIECE"]
+                                               (T            (* ; 
+
                                                         "There are no more pieces.  Punt gracefully")

+                                                  (COND
+                                                     ((fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM)
+                                                             (* ; 
+
                                             "If there's an EOF handler, call it & return the result")

+                                                      (RETURN (APPLY* (fetch
 (STREAM ENDOFSTREAMOP)
+                                                                         of
 STREAM)
+                                                                     STREAM)))
+                                                     (T      (* ; "Otherwise, return NIL")

+                                                        (RETURN NIL]
+                                           [(SETQ PO (fetch
 (PIECE POBJ) of
 (fetch
 (TEXTSTREAM PIECE)
+                                                                               of
 STREAM)))
                                                              (* ; "This is an object")

-                            (replace
 (STREAM BINABLE) of
 STREAM with
 NIL)
-                            (COND
-                               (SUBSTREAM                    (* ; 
-
                                          "There is a stream below this one, to feed chars upward.")

-                                      (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM TEXTOBJ) of

-                                                                                         SUBSTREAM))
-                                      (freplace
 (STREAM COFFSET) of
 STREAM with
 1)
-                                      (freplace
 (TEXTSTREAM CHARSLEFT) of
 STREAM with

-                                                                                         0)
-                                      (freplace
 (STREAM CBUFSIZE) of
 STREAM
-                                         with
 (fetch
 (PIECE PLEN) of
 PC))
-                                      (freplace
 (STREAM CPAGE) of
 STREAM with
 0)
-                                      (freplace
 (TEXTSTREAM PCSTARTCH) of
 STREAM with

-                                                                                         1)
-                                      (freplace
 (TEXTSTREAM PCSTARTPG) of
 STREAM with

-                                                                                         0)
-                                      (replace
 (TEXTSTREAM CURRENTPARALOOKS) of
 STREAM
-                                         with
 (fetch
 (TEXTSTREAM CURRENTPARALOOKS)
-                                                     of
 SUBSTREAM))
-                                      (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
-                                         with
 (fetch
 (TEXTSTREAM CURRENTLOOKS) of
 
-                                                                                            SUBSTREAM
-                                                         ))
-                                      (RETURN (\BIN SUBSTREAM)))
-                               (T (replace
 (TEXTSTREAM CHARSLEFT) of
 STREAM with
 0)
-                                  (RETURN PO]
-                           (T                                (* ; 
-
                                                         "Need to move to the next page in a file.")

-                              (RETURN (\TEDIT.TEXTBIN.NEW.PAGE
 STREAM])
+                                            (replace
 (STREAM BINABLE) of
 STREAM with
 NIL)
+                                            (COND
+                                               (SUBSTREAM    (* ; 
+
                                            "There is a stream below this one, to feed chars upward.")

+                                                      (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM TEXTOBJ)
+                                                                        of
 SUBSTREAM))
+                                                      (freplace
 (STREAM COFFSET) of
 STREAM
+                                                         with
 1)
+                                                      (freplace
 (TEXTSTREAM CHARSLEFT) of
 STREAM
+                                                         with
 0)
+                                                      (freplace
 (STREAM CBUFSIZE) of
 STREAM
+                                                         with
 (fetch
 (PIECE PLEN) of
 PC))
+                                                      (freplace
 (STREAM CPAGE) of
 STREAM with
 0)
+                                                      (freplace
 (TEXTSTREAM PCSTARTCH) of
 STREAM
+                                                         with
 1)
+                                                      (freplace
 (TEXTSTREAM PCSTARTPG) of
 STREAM
+                                                         with
 0)
+                                                      (replace
 (TEXTSTREAM CURRENTPARALOOKS)
+                                                         of
 STREAM with
 (fetch
 (TEXTSTREAM 
+                                                                                     CURRENTPARALOOKS
+                                                                                      ) of
 SUBSTREAM)
+                                                             )
+                                                      (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
+                                                         with
 (fetch
 (TEXTSTREAM CURRENTLOOKS)
+                                                                 of
 SUBSTREAM))
+                                                      (RETURN (\BIN SUBSTREAM)))
+                                               (T (replace
 (TEXTSTREAM CHARSLEFT) of
 STREAM
+                                                     with
 0)
+                                                  (RETURN PO]
+                                           (T                (* ; 
+
                                                           "Need to move to the next page in a file.")

+                                              (RETURN (\TEDIT.TEXTBIN.NEW.PAGE
 STREAM]
+         (IF
 (IMAGEOBJP BYTE)
+             THEN
 (OR (GETTEXTPROP
 (FETCH
 (TEXTSTREAM TEXTOBJ) OF
 STREAM)
+                             'OBJECTBYTE)
+                      BYTE)
+           ELSE
 BYTE])
 
 (\TEDIT.TEXTBIN.STRINGSETUP

   [LAMBDA (CHOFFSET CHARSLEFT STREAM PS)
                 (* ; "Edited 31-May-91 14:21 by jds")

@@ -2343,123 +2386,144 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
 (DEFINEQ
 
 (\TEXTPEEKBIN

-  [LAMBDA (STREAM NOERRORFLG)
                            (* ; "Edited 28-Mar-94 15:34 by jds")

+  [LAMBDA (STREAM NOERRORFLG)
+
+    (* ;; "Edited 22-Dec-2021 10:29 by rmk: Return OBJECTCHAR for image objects, if present")

+
+    (* ;; "Edited 28-Mar-94 15:34 by jds")

                                                              (* ; "DO PEEKBIN for a text stream")

-    (PROG (CH FILE STR PF PS PC PO SUBSTREAM)
-          (SETQ PC (fetch
 (TEXTSTREAM PIECE) of
 STREAM))
-          (COND
-             [(ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
-                     (fetch
 (STREAM CBUFSIZE) of
 STREAM))
+    (LET (BYTE)                                              (* ; 
+
                                               "BYTE to capture all returns for imageobject coercion")

+         [SETQ BYTE (PROG (CH FILE STR PF PS PC PO SUBSTREAM)
+                          (SETQ PC (fetch
 (TEXTSTREAM PIECE) of
 STREAM))
+                          (COND
+                             [(ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
+                                     (fetch
 (STREAM CBUFSIZE) of
 STREAM))
                                                              (* ; 
-
                                                         "Simple case -- just do the usual PEEKBIN")

-              (COND
-                 ((AND PC (fetch
 (PIECE POBJ) of
 PC))
-                  (RETURN (fetch
 (PIECE POBJ) of
 PC)))
-                 [(fetch
 (TEXTSTREAM FATSTREAMP) of
 STREAM)
-                                                             (* ; 
-
                                                     "This is a 16 bit PEEKBIN.  Grab two chars...")

-                  (RETURN (COND
-                             [(\EOFP STREAM)
+
                                                           "Simple case -- just do the usual PEEKBIN")

                               (COND
-                                 (NOERRORFLG NIL)
-                                 (T (\PEEKBIN STREAM]
-                             ((ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
-                                     (SUB1 (fetch
 (STREAM CBUFSIZE) of
 STREAM)))
+                                 ((AND PC (SETQ PO (fetch
 (PIECE POBJ) of
 PC)))
+                                  (RETURN PO))
+                                 [(fetch
 (TEXTSTREAM FATSTREAMP) of
 STREAM)
                                                              (* ; 
-
                                "We're sure of staying on the same page.  Just grab the characters")

-                              (PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
-                                                   256)
-                                            (\PAGEDPEEKBIN STREAM NOERRORFLG))
-                                     (\PAGEDBACKFILEPTR STREAM)))
-                             (T (SETQ PS (fetch
 (STREAM F1) of
 STREAM))
-                                (replace
 (STREAM COFFSET) of
 PS with
 (fetch

-                                                                                  (STREAM COFFSET)
-                                                                                    of
 STREAM))
-                                (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
-                                                     256)
-                                              (\PAGEDPEEKBIN PS NOERRORFLG))
-                                       (\PAGEDBACKFILEPTR PS]
-                 (T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
-             [PC                                             (* ; 
-
                                       "We've either hit a page bound in a file, or a piece bound.")

-                 (RETURN (COND
-                            [(ZEROP (fetch
 (TEXTSTREAM CHARSLEFT) of
 STREAM))
+
                                                       "This is a 16 bit PEEKBIN.  Grab two chars...")

+                                  (RETURN (COND
+                                             [(\EOFP STREAM)
+                                              (COND
+                                                 (NOERRORFLG NIL)
+                                                 (T (\PEEKBIN STREAM]
+                                             ((ILESSP (fetch
 (STREAM COFFSET) of
 STREAM)
+                                                     (SUB1 (fetch
 (STREAM CBUFSIZE) of
 STREAM)))
+                                                             (* ; 
+
                                  "We're sure of staying on the same page.  Just grab the characters")

+                                              (PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
+                                                                   256)
+                                                            (\PAGEDPEEKBIN STREAM NOERRORFLG))
+                                                     (\PAGEDBACKFILEPTR STREAM)))
+                                             (T (SETQ PS (fetch
 (STREAM F1) of
 STREAM))
+                                                (replace
 (STREAM COFFSET) of
 PS
+                                                   with
 (fetch
 (STREAM COFFSET) of
 STREAM))
+                                                (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
+                                                                     256)
+                                                              (\PAGEDPEEKBIN PS NOERRORFLG))
+                                                       (\PAGEDBACKFILEPTR PS]
+                                 (T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
+                             [PC                             (* ; 
+
                                         "We've either hit a page bound in a file, or a piece bound.")

+                                 (RETURN (COND
+                                            [(ZEROP (fetch
 (TEXTSTREAM CHARSLEFT) of
 STREAM))
                                                              (* ; "Time for a new piece.")

-                             (SETQ PC (replace
 (TEXTSTREAM PIECE) of
 STREAM
-                                         with
 (fetch
 (PIECE NEXTPIECE) of
 PC)))
+                                             (SETQ PC (replace
 (TEXTSTREAM PIECE) of
 STREAM
+                                                         with
 (fetch
 (PIECE NEXTPIECE) of
 PC)))
                                                              (* ; 
-
                                                           "Move to the next piece in the chain")

-                             (COND
-                                [PC (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
-                                       with
 (\TEDIT.APPLY.STYLES (fetch
 (PIECE PLOOKS)
-                                                                        of
 PC)
-                                                       PC
-                                                       (fetch
 (TEXTSTREAM TEXTOBJ) of
 STREAM)
-                                                       ))
-                                    (COND
-                                       [(SETQ PO (fetch
 (PIECE POBJ) of
 PC))
-                                        (replace
 (STREAM BINABLE) of
 STREAM with
 NIL)
-                                        (freplace
 (STREAM CBUFSIZE) of
 STREAM
-                                           with
 (fetch
 (PIECE PLEN) of
 PC))
-                                        (freplace
 (STREAM COFFSET) of
 STREAM with
 0)
-                                        (COND
-                                           (SUBSTREAM        (* ; 
-
                                          "There is a stream below this one, to feed chars upward.")

-                                                  (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM TEXTOBJ)
-                                                                        of
 SUBSTREAM))
-                                                  (freplace
 (TEXTSTREAM CHARSLEFT) of
 STREAM
-                                                     with
 (fetch
 (PIECE PLEN) of
 PC))
-                                                  (freplace
 (STREAM CPAGE) of
 STREAM
-                                                     with
 0)
-                                                  (freplace
 (TEXTSTREAM PCSTARTCH) of
 STREAM
-                                                     with
 0)
-                                                  (freplace
 (TEXTSTREAM PCSTARTPG) of
 STREAM
-                                                     with
 0)
-                                                  (replace
 (TEXTSTREAM CURRENTPARALOOKS)
-                                                     of
 STREAM with
 (fetch
 (TEXTSTREAM
-                                                                                        
+
                                                             "Move to the next piece in the chain")

+                                             (COND
+                                                [PC (replace
 (TEXTSTREAM CURRENTLOOKS) of
 STREAM
+                                                       with
 (\TEDIT.APPLY.STYLES (fetch
 (PIECE PLOOKS
+                                                                                               )
+                                                                                    of
 PC)
+                                                                   PC
+                                                                   (fetch
 (TEXTSTREAM TEXTOBJ)
+                                                                      of
 STREAM)))
+                                                    (COND
+                                                       [(SETQ PO (fetch
 (PIECE POBJ) of
 PC))
+                                                        (replace
 (STREAM BINABLE) of
 STREAM
+                                                           with
 NIL)
+                                                        (freplace
 (STREAM CBUFSIZE) of
 STREAM
+                                                           with
 (fetch
 (PIECE PLEN) of
 PC))
+                                                        (freplace
 (STREAM COFFSET) of
 STREAM
+                                                           with
 0)
+                                                        (COND
+                                                           (SUBSTREAM 
+                                                             (* ; 
+
                                            "There is a stream below this one, to feed chars upward.")

+                                                                  (\SETUPGETCH
 1 (fetch
 (TEXTSTREAM
+                                                                                         TEXTOBJ)
+                                                                                    of
 SUBSTREAM))
+                                                                  (freplace
 (TEXTSTREAM CHARSLEFT)
+                                                                     of
 STREAM
+                                                                     with
 (fetch
 (PIECE PLEN)
+                                                                             of
 PC))
+                                                                  (freplace
 (STREAM CPAGE)
+                                                                     of
 STREAM with
 0)
+                                                                  (freplace
 (TEXTSTREAM PCSTARTCH)
+                                                                     of
 STREAM with
 0)
+                                                                  (freplace
 (TEXTSTREAM PCSTARTPG)
+                                                                     of
 STREAM with
 0)
+                                                                  (replace
 (TEXTSTREAM 
+                                                                                  CURRENTPARALOOKS)
+                                                                     of
 STREAM
+                                                                     with
 (fetch
 (TEXTSTREAM 
                                                                                      CURRENTPARALOOKS
                                                                                         )
-                                                                               of
 SUBSTREAM))
-                                                  (replace
 (TEXTSTREAM CURRENTLOOKS) of

-                                                                                         STREAM
-                                                     with
 (fetch
 (TEXTSTREAM CURRENTLOOKS)
-                                                                 of
 SUBSTREAM))
-                                                  (RETURN (\BIN SUBSTREAM)))
-                                           (T (replace
 (TEXTSTREAM CHARSLEFT) of
 STREAM
-                                                 with
 0)
-                                              (RETURN PO]
-                                       ((SETQ PS (fetch
 (PIECE PSTR) of
 PC))
+                                                                             of
 SUBSTREAM))
+                                                                  (replace
 (TEXTSTREAM CURRENTLOOKS)
+                                                                     of
 STREAM
+                                                                     with
 (fetch
 (TEXTSTREAM 
+                                                                                        CURRENTLOOKS)
+                                                                             of
 SUBSTREAM))
+                                                                  (RETURN (\BIN SUBSTREAM)))
+                                                           (T (replace
 (TEXTSTREAM CHARSLEFT)
+                                                                 of
 STREAM with
 0)
+                                                              (RETURN PO]
+                                                       ((SETQ PS (fetch
 (PIECE PSTR) of
 PC))
                                                              (* ; "This piece lives in a string.")

-                                        (\TEDIT.TEXTBIN.STRINGSETUP
 0 (fetch
 (PIECE PLEN)
-                                                                             of
 PC)
-                                               STREAM PS)
+                                                        (\TEDIT.TEXTBIN.STRINGSETUP

+                                                         0
+                                                         (fetch
 (PIECE PLEN) of
 PC)
+                                                         STREAM PS)
 
                                  (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")

 
-                                        (\PEEKBIN STREAM NOERRORFLG))
-                                       ((SETQ PF (fetch
 (PIECE PFILE) of
 PC))
+                                                        (\PEEKBIN STREAM NOERRORFLG))
+                                                       ((SETQ PF (fetch
 (PIECE PFILE) of
 PC))
                                                              (* ; "This piece lives on a file.")

-                                        (\TEDIT.TEXTBIN.FILESETUP
 PC 0 (fetch
 (PIECE PLEN)
-                                                                              of
 PC)
-                                               STREAM PF (fetch
 (PIECE PFATP) of
 PC)
-                                               'PEEKBIN NOERRORFLG))
-                                       (T (ERROR "CAN'T GET TO NEXT PIECE"]
-                                (NOERRORFLG                  (* ; 
-
                                                       "There are no more pieces.  Punt gracefully")

-                                       (RETURN NIL))
-                                (T                           (* ; "He wants it the hard way.")

-                                   (APPLY* (fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM)
-                                          STREAM]
-                            (T                               (* ; 
-
                                                         "Need to move to the next page in a file.")

-                               (RETURN (\TEDIT.PEEKBIN.NEW.PAGE
 STREAM NOERRORFLG]
-             (NOERRORFLG                                     (* ; 
-
                                                       "There are no more pieces.  Punt gracefully")

-                    (RETURN NIL))
-             (T                                              (* ; "He wants it the hard way.")

-                (APPLY* (fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM)
-                       STREAM])
+                                                        (\TEDIT.TEXTBIN.FILESETUP
 PC 0
+                                                               (fetch
 (PIECE PLEN) of
 PC)
+                                                               STREAM PF (fetch
 (PIECE PFATP)
+                                                                            of
 PC)
+                                                               'PEEKBIN NOERRORFLG))
+                                                       (T (ERROR "CAN'T GET TO NEXT PIECE"]
+                                                (NOERRORFLG  (* ; 
+
                                                         "There are no more pieces.  Punt gracefully")

+                                                       (RETURN NIL))
+                                                (T           (* ; "He wants it the hard way.")

+                                                   (APPLY* (fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM)
+                                                          STREAM]
+                                            (T               (* ; 
+
                                                           "Need to move to the next page in a file.")

+                                               (RETURN (\TEDIT.PEEKBIN.NEW.PAGE
 STREAM NOERRORFLG]
+                             (NOERRORFLG                     (* ; 
+
                                                         "There are no more pieces.  Punt gracefully")

+                                    (RETURN NIL))
+                             (T                              (* ; "He wants it the hard way.")

+                                (APPLY* (fetch
 (STREAM ENDOFSTREAMOP) of
 STREAM)
+                                       STREAM]
+         (IF
 (IMAGEOBJP BYTE)
+             THEN
 (OR (GETTEXTPROP
 (FETCH
 (TEXTSTREAM TEXTOBJ) OF
 STREAM)
+                             'OBJECTBYTE)
+                      BYTE)
+           ELSE
 BYTE])
 
 (\TEDIT.PEEKBIN.NEW.PAGE

   [LAMBDA (STREAM NOERRORFLG)
                            (* ; "Edited 11-Jun-99 15:11 by rmk:")


@@ -2657,25 +2721,25 @@ Copyright (c) 1983-1991, 1993-1995, 1999-2001, 2021 by John Sybalsky & Xerox Cor
 (PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 
 1990 1991 1993 1994 1995 1999 2000 2001 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2982 52971 (COPYTEXTSTREAM 2992 . 6114) (OPENTEXTSTREAM 6116 . 20993) (REOPENTEXTSTREAM
- 20995 . 21417) (TEDIT.STREAMCHANGEDP 21419 . 21717) (TEXTSTREAMP 21719 . 22033) (TXTFILE 22035 . 
-22480) (\DELETECH 22482 . 33738) (\SETUPGETCH 33740 . 41019) (\TEDIT.REOPEN.STREAM 41021 . 42871) (
-\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42873 . 45311) (\TEXTINIT 45313 . 50864) (\TEXTMARK 50866 . 51614) (
-\TEXTTTYBOUT 51616 . 52969)) (52972 78404 (\INSERTCH 52982 . 76708) (\INSERTCR 76710 . 78402)) (78470 
-98786 (\CHTOPC 78480 . 79669) (\CHTOPCNO 79671 . 80933) (\CLEARPCTB 80935 . 81731) (
-\CREATEPIECEORSTREAM 81733 . 84707) (\DELETEPIECE 84709 . 85622) (\FINDPIECE 85624 . 85990) (
-\INSERTPIECE 85992 . 89002) (\MAKEPCTB 89004 . 90919) (\SPLITPIECE 90921 . 97880) (\INSERT.FIRST.PIECE
- 97882 . 98784)) (98838 123056 (\TEXTCLOSEF 98848 . 100075) (\TEXTCLOSEF-SUBTREE 100077 . 100783) (
-\TEXTDSPFONT 100785 . 101777) (\TEXTEOFP 101779 . 103138) (\TEXTGETEOFPTR 103140 . 103350) (
-\TEXTGETFILEPTR 103352 . 105415) (\TEXTOPENF 105417 . 106247) (\TEXTOPENF-SUBTREE 106249 . 107050) (
-\TEXTOUTCHARFN 107052 . 107400) (\TEXTBACKFILEPTR 107402 . 113303) (\TEXTBOUT 113305 . 116653) (
-\TEDITOUTCHARFN 116655 . 117901) (\TEXTSETEOF 117903 . 118412) (\TEXTSETFILEPTR 118414 . 119639) (
-\TEXTDSPXPOSITION 119641 . 120498) (\TEXTDSPYPOSITION 120500 . 121045) (\TEXTLEFTMARGIN 121047 . 
-121530) (\TEXTRIGHTMARGIN 121532 . 122468) (\TEXTDSPCHARWIDTH 122470 . 122708) (\TEXTDSPSTRINGWIDTH 
-122710 . 122950) (\TEXTDSPLINEFEED 122952 . 123054)) (123057 156801 (\TEXTBIN 123067 . 139853) (
-\TEDIT.TEXTBIN.STRINGSETUP 139855 . 145568) (\TEDIT.TEXTBIN.FILESETUP 145570 . 151956) (
-\TEDIT.TEXTBIN.NEW.PAGE 151958 . 156799)) (156802 170210 (\TEXTPEEKBIN 156812 . 165951) (
-\TEDIT.PEEKBIN.NEW.PAGE 165953 . 170208)) (170248 175466 (CGETTEXTPROP 170258 . 170734) (CTEXTPROP 
-170736 . 173080) (GETTEXTPROP 173082 . 173677) (PUTTEXTPROP 173679 . 175004) (TEXTPROP 175006 . 175464
+  (FILEMAP (NIL (2992 53117 (COPYTEXTSTREAM 3002 . 6124) (OPENTEXTSTREAM 6126 . 21003) (REOPENTEXTSTREAM
+ 21005 . 21427) (TEDIT.STREAMCHANGEDP 21429 . 21727) (TEXTSTREAMP 21729 . 22043) (TXTFILE 22045 . 
+22490) (\DELETECH 22492 . 33748) (\SETUPGETCH 33750 . 41029) (\TEDIT.REOPEN.STREAM 41031 . 42881) (
+\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42883 . 45321) (\TEXTINIT 45323 . 51010) (\TEXTMARK 51012 . 51760) (
+\TEXTTTYBOUT 51762 . 53115)) (53118 78550 (\INSERTCH 53128 . 76854) (\INSERTCR 76856 . 78548)) (78616 
+98932 (\CHTOPC 78626 . 79815) (\CHTOPCNO 79817 . 81079) (\CLEARPCTB 81081 . 81877) (
+\CREATEPIECEORSTREAM 81879 . 84853) (\DELETEPIECE 84855 . 85768) (\FINDPIECE 85770 . 86136) (
+\INSERTPIECE 86138 . 89148) (\MAKEPCTB 89150 . 91065) (\SPLITPIECE 91067 . 98026) (\INSERT.FIRST.PIECE
+ 98028 . 98930)) (98984 123222 (\TEXTCLOSEF 98994 . 100221) (\TEXTCLOSEF-SUBTREE 100223 . 100929) (
+\TEXTDSPFONT 100931 . 101923) (\TEXTEOFP 101925 . 103284) (\TEXTGETEOFPTR 103286 . 103496) (
+\TEXTGETFILEPTR 103498 . 105561) (\TEXTOPENF 105563 . 106393) (\TEXTOPENF-SUBTREE 106395 . 107196) (
+\TEXTOUTCHARFN 107198 . 107546) (\TEXTBACKFILEPTR 107548 . 113449) (\TEXTBOUT 113451 . 116799) (
+\TEDITOUTCCODEFN 116801 . 118067) (\TEXTSETEOF 118069 . 118578) (\TEXTSETFILEPTR 118580 . 119805) (
+\TEXTDSPXPOSITION 119807 . 120664) (\TEXTDSPYPOSITION 120666 . 121211) (\TEXTLEFTMARGIN 121213 . 
+121696) (\TEXTRIGHTMARGIN 121698 . 122634) (\TEXTDSPCHARWIDTH 122636 . 122874) (\TEXTDSPSTRINGWIDTH 
+122876 . 123116) (\TEXTDSPLINEFEED 123118 . 123220)) (123223 161060 (\TEXTBIN 123233 . 144112) (
+\TEDIT.TEXTBIN.STRINGSETUP 144114 . 149827) (\TEDIT.TEXTBIN.FILESETUP 149829 . 156215) (
+\TEDIT.TEXTBIN.NEW.PAGE 156217 . 161058)) (161061 176823 (\TEXTPEEKBIN 161071 . 172564) (
+\TEDIT.PEEKBIN.NEW.PAGE 172566 . 176821)) (176861 182079 (CGETTEXTPROP 176871 . 177347) (CTEXTPROP 
+177349 . 179693) (GETTEXTPROP 179695 . 180290) (PUTTEXTPROP 180292 . 181617) (TEXTPROP 181619 . 182077
 )))))
 STOP

lispusers/BACKGROUND-YIELD

@@ -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

lispusers/DATE

@@ -1,531 +0,0 @@
-
(FILECREATED "18-Feb-87 15:42:27" {SUMEX-AIM}PS:<TMAX.SOURCES>DATE.;4
 19668  
-
-      previous date: "17-Feb-87 14:29:37" {SUMEX-AIM}<GILMURRAY.LISP>DATE.;7)
-
-
-(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
-
-(PRETTYCOMPRINT DATECOMS)
-
-(RPAQQ DATECOMS
 ((* Developed under support from NIH grant RR-00785.)
-	(* Written by Frank Gilmurray and Sami Shaio.)
-	(FNS DATEOBJ DATEOBJP DATE.DISPLAYFN DATE.IMAGEBOXFN CURRENT.DISPLAY.FONT DATE.PUTFN 
-	     DATE.GETFN DATE.BUTTONEVENTINFN DATES.TEMPLATE AMPM DATES.MENU.APPLY 
-	     DATES.MENU.WHENSELECTEDFN DATES.SET FINDDAY FINDHOUR FINDMONTH FINDTIME FINDYEAR NUMP 
-	     WHICHDATE)
-	(RECORDS DATEOBJ STREAM FONTCLASS)))
-
-
-
-(* Developed under support from NIH grant RR-00785.)

-
-
-
-
-(* Written by Frank Gilmurray and Sami Shaio.)

-
-(DEFINEQ
-
-(DATEOBJ

-  (LAMBDA (TEMPLATE)                                         (* fsg "23-Jul-86 09:53")

-                                                             (* Create an instance of a date imageobj.

-							     A dateobj is also defined as a record with a 

-							     datestring field. *)

-    (LET* ((TEMPLATE.TYPE (
OR
 TEMPLATE '(M D Y F)))
-	   (DATEANDTIME (
MKSTRING
 (
DATE
)))
-	   (DISPLAYDATE (
MKSTRING
 (DATES.TEMPLATE
 DATEANDTIME TEMPLATE.TYPE)))
-	   (NEWOBJ (
IMAGEOBJCREATE
 (create
 DATEOBJ
-					       DATESTRING _ DATEANDTIME
-					       DISPLAY.DATE _ DISPLAYDATE
-					       TEMPLATE.DATE _ TEMPLATE.TYPE)
-				     (
IMAGEFNSCREATE
 (
FUNCTION
 DATE.DISPLAYFN)
-						       (
FUNCTION
 DATE.IMAGEBOXFN)
-						       (
FUNCTION
 DATE.PUTFN)
-						       (
FUNCTION
 DATE.GETFN)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 DATE.BUTTONEVENTINFN)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 NILL)
-						       (
FUNCTION
 NILL)))))
-                                                             (* By convention, every image object will have a type 

-							     property associated with it that will facilitate 

-							     imageobj mapping in a TEdit file.)

-          (
IMAGEOBJPROP
 NEWOBJ 'TYPE
-			  'DATEOBJ)
-      NEWOBJ)))
-
-(DATEOBJP

-  (LAMBDA (IMOBJ)                                            (* ss: "24-Jun-85 16:33")

-
-          (* Tests an imageobj to see if it is a date imageobject. By convention, testing functions for an imageobject will 

-	  be named (CONCAT <type of imageobj> "P"))

-
-
-    (
AND
 IMOBJ (
EQ
 (
IMAGEOBJPROP
 IMOBJ 'TYPE)
-		       'DATEOBJ))))
-
-(DATE.DISPLAYFN

-  (LAMBDA (OBJ STREAM STREAMTYPE HOSTSTREAM)                 (* fsg "17-Feb-87 09:28")

-
-          (* * Display function for date imageobjs.)

-
-
-    (
PRIN1
 (fetch
 DISPLAY.DATE of
 (fetch
 OBJECTDATUM of
 OBJ))
-	     STREAM)))
-
-(DATE.IMAGEBOXFN

-  (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN)                  (* fsg "15-Feb-87 14:05")

-
-          (* * Return the ImageBox for the date string. The size is determined by the stream's current font.)

-
-
-    (
DSPFONT
 (CURRENT.DISPLAY.FONT
 STREAM)
-	       STREAM)
-    (create
 IMAGEBOX
-	      XSIZE _(
STRINGWIDTH
 (fetch
 DISPLAY.DATE of
 (fetch
 OBJECTDATUM of
 OBJ))
-				    STREAM)
-	      YSIZE _(
FONTPROP
 STREAM 'HEIGHT)
-	      YDESC _(
FONTPROP
 STREAM 'DESCENT)
-	      XKERN _ 0)))
-
-(CURRENT.DISPLAY.FONT

-  (LAMBDA (STREAM)                                           (* fsg "17-Feb-87 10:19")

-
-          (* * Return the current font. This function is here instead of TMAX because the DATE code is also used in the 

-	  LetterHead code.)

-
-
-    (LET ((CURRENT.FONT (fetch
 CLFONT of
 (with
 TEXTSTREAM
-						     (
TEXTSTREAM
 (
CAR
 (fetch
 \WINDOW
-									     of
 TEXTOBJ)))
-						     CURRENTLOOKS))))
-         (
COND

-	   ((
TYPENAMEP
 CURRENT.FONT 'FONTDESCRIPTOR)
-	     CURRENT.FONT)
-	   ((
TYPENAMEP
 CURRENT.FONT 'FONTCLASS)
-	     (fetch
 DISPLAYFD of
 CURRENT.FONT))
-	   (T (
SHOULDNT
 "Can't get current font"))))))
-
-(DATE.PUTFN

-  (LAMBDA (DATEOBJ
 STREAM)                                 (* fsg " 4-Feb-87 09:40")

-    (
PRIN2
 (
LIST
 'Date
-		     (fetch
 (DATEOBJ
 TEMPLATE.DATE) of
 (fetch
 OBJECTDATUM of
 DATEOBJ)))
-	     STREAM)))
-
-(DATE.GETFN

-  (LAMBDA (STREAM)                                           (* fsg " 4-Feb-87 09:42")

-    (
OR
 (
WINDOWPROP
 (
PROCESSPROP
 (
THIS.PROCESS
)
-				       'WINDOW)
-			'IMAGEOBJ.MENUW)
-	  (
AND
 (
FGETD
 'TSP.FMMENU)
-		 (
TSP.FMMENU
 (
TEXTSTREAM
 (
PROCESSPROP
 (
THIS.PROCESS
)
-							    'WINDOW)))))
-    (
APPLY
 'DATEOBJ
-	     (
CDR
 (
READ
 STREAM)))))
-
-(DATE.BUTTONEVENTINFN

-  (LAMBDA (DATEOBJ
 WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON)
-                                                             (* fsg "26-Jan-87 10:06")

-    (
AND
 (MOUSESTATE MIDDLE)
-	   (LET ((DATE.MENU (create
 MENU
-				      TITLE _ "Date Menu"
-				      ITEMS _ '((Month% Day,% Year (DATES.TEMPLATE DATE
-										   '(M D Y F))
-								   
-						       "Insert current date as %"March 8, 1952%"")
-						(Month/Day/Year (DATES.TEMPLATE DATE '(M D Y A))
-								"Insert current date as %"3/8/52%"")
-						(Day% Month,% Year (DATES.TEMPLATE DATE
-										   '(D M Y F))
-								   
-						       "Insert current date as %"8 March, 1952%"")
-						(Day/Month/Year (DATES.TEMPLATE DATE '(D M Y A))
-								"Insert current date as %"8/3/52%"")
-						(Time (DATES.TEMPLATE DATE '(T F))
-						      "Insert current time as %"four thirty p.m.%"")
-						(Numbered% Time (DATES.TEMPLATE DATE '(T A))
-								
-							   "Insert current time as %"4:30 p.m.%"")
-						(Military% Time (DATES.TEMPLATE DATE '(T E))
-								"Insert current time as %"16:30%""))
-				      WHENSELECTEDFN _(
FUNCTION
 DATES.MENU.WHENSELECTEDFN))))
-	        (
PUTMENUPROP
 DATE.MENU 'IMAGEOBJ
-			       DATEOBJ)
-	        (
MENU
 DATE.MENU)
-	        'CHANGED))))
-
-(DATES.TEMPLATE

-  (LAMBDA (
DATE
 TEMPLATE)                                  (* fsg "24-Jul-86 14:43")

-
-          (* * comment)

-
-
-    (
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)
-					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 " ")
-					     then
 ", "
-					   else
 CH)
-					 (
APPLY
 (
CADR
 (
ASSOC
 (
CADDR
 TEMPLATE)
-								   FUNCLST))
-						  (
LIST
 DATE VERSION))))))))
-      (
DATE
))))
-
-(AMPM

-  (LAMBDA (HOUR)
-    (if
 (
OR
 (
LESSP
 (
MKATOM
 HOUR)
-			 12)
-		(
EQUAL
 (
MKATOM
 HOUR)
-			 24))
-	then
 "a.m."
-      else
 "p.m.")))
-
-(DATES.MENU.APPLY

-  (LAMBDA (ITEM MENU)                                        (* fsg "31-Jul-86 10:18")

-
-          (* This function serves the purpose of calculating the stream and the editing window from information stored on the

-	  window containing the menu. It then applies the appropiate function for each ITEM in the menu*)

-
-
-    (
SETQ
 ITEM (
COND

-	((
ATOM
 ITEM)
-	  ITEM)
-	(T (
CAR
 ITEM))))
-    (LET* ((DATE.RECORD (fetch
 OBJECTDATUM of
 (
GETMENUPROP
 MENU 'IMAGEOBJ)))
-	   (
DATE
 (fetch
 DATESTRING of
 DATE.RECORD)))
-          (
COND

-	    ((fetch
 ITEMS of
 MENU)
-	      (LET ((FUNCALL (
CADR
 (
ASSOC
 ITEM (fetch
 ITEMS of
 MENU)))))
-	           (replace
 DISPLAY.DATE of
 DATE.RECORD with
 (
EVAL
 FUNCALL))
-	           (replace
 TEMPLATE.DATE of
 DATE.RECORD with
 (
CADAR
 (
LAST
 FUNCALL)))))))))
-
-(DATES.MENU.WHENSELECTEDFN

-  (LAMBDA (ITEM MENU MB)                                     (* fsg "28-Jul-86 14:57")

-    (
COND

-      ((
OR
 (
EQ
 MB 'LEFT)
-	     (
EQ
 MB 'MIDDLE))
-	(DATES.MENU.APPLY
 ITEM MENU)))))
-
-(DATES.SET

-  (LAMBDA (PROPERTY VALUE)
-    (
WINDOWPROP
 (
CREATEW
)
-		  PROPERTY VALUE)
-    VALUE))
-
-(FINDDAY

-  (LAMBDA (OLDDATE VERSION)                                  (* shw: " 1-Jul-85 11:28")

-    (
MKATOM
 (if
 (NUMP
 (
SUBSTRING
 OLDDATE 1 2))
-		  then
 (
SUBSTRING
 OLDDATE 1 2)
-		else
 (
SUBSTRING
 OLDDATE 2 2)))))
-
-(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))))))
-
-(FINDMONTH

-  (LAMBDA (OLDDATE VERSION)                                  (* shw: " 1-Jul-85 11:38")

-    (
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))))
-
-(FINDTIME

-  (LAMBDA (OLDDATE VERSION)                                  (* shw: "24-Jul-85 15:39")

-    (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))))))))
-
-(FINDYEAR

-  (LAMBDA (OLDDATE VERSION)                                  (* shw: " 1-Jul-85 11:31")

-    (if
 (
EQ
 VERSION 'ABBREV)
-	then
 (
MKATOM
 (
SUBSTRING
 OLDDATE 8 9))
-      else
 (
MKATOM
 (
CONCAT
 "19" (
SUBSTRING
 OLDDATE 8 9))))))
-
-(NUMP

-  (LAMBDA (N)                                                (* edited: " 4-Apr-86 17:55")

-                                                             (* changed)

-    (
NOT
 (
NULL
 (
NUMBERP
 (
MKATOM
 N))))))
-
-(WHICHDATE

-  (LAMBDA (VAR1 VAR2 YEAR OLDDATE VERSION)                   (* edited " 1-Jan-00 00:00")

-
-          (* * comment)

-
-
-    (
PROG
 (DIVIDER)
-	    (
SETQ
 DIVIDER (if
 (
EQ
 VERSION 'ABBREV)
-				then
 "/"
-			      else
 " "))
-	    (
RETURN
 (
MKATOM
 (
CONCAT
 (
APPLY
 VAR1 (
LIST
 OLDDATE VERSION))
-					  DIVIDER
-					  (
APPLY
 VAR2 (
LIST
 OLDDATE VERSION))
-					  DIVIDER
-					  (
APPLY
 YEAR (
LIST
 OLDDATE VERSION))))))))
-)
-[DECLARE: EVAL@COMPILE 
-
-(RECORD DATEOBJ
 (DATESTRING DISPLAY.DATE TEMPLATE.DATE))
-
-(DATATYPE STREAM
 (                                         (* First 4 words are fixed for BIN, BOUT opcodes.

-							     Length of whole datatype is multiple of 4, so 

-							     quad-aligned)

-		    (COFFSET WORD)                           (* Offset in CPPTR of next bin or bout)

-		    (CBUFSIZE WORD)                          (* Offset past last byte in that buffer)

-		    (BINABLE FLAG)                           (* BIN punts unless this bit on)

-		    (BOUTABLE FLAG)                          (* BOUT punts unless this bit on)

-		    (EXTENDABLE FLAG)                        (* BOUT punts when COFFSET ge CBUFFSIZE unless this 

-							     bit set and COFFSET lt 512)

-		    (NIL BITS 5)
-		    (CBUFPTR POINTER)                        (* Pointer to current buffer)

-		    (NONDEFAULTDATEFLG FLAG)
-		    (REVALIDATEFLG FLAG)
-		    (MULTIBUFFERHINT FLAG)                   (* True if stream likes to read and write more than 

-							     one buffer at a time)

-		    (USERCLOSEABLE FLAG)                     (* Can be closed by CLOSEF;

-							     NIL for terminal, dribble...)

-		    (USERVISIBLE FLAG)                       (* Listed by OPENP; NIL for terminal, dribble ...)

-		    (ACCESSBITS BITS 3)                      (* What kind of access file is open for 

-							     (read, write, append))

-		    (FULLFILENAME POINTER)                   (* Name by which file is known to user)

-		    (DEVICE POINTER)                         (* FDEV of this guy)

-		    (VALIDATION POINTER)                     (* A number somehow identifying file, used to 

-							     determine if file has changed in our absence)

-		    (EPAGE WORD)
-		    (EOFFSET WORD)                           (* Page, byte offset of eof)

-                                                             (* Following are device-specific fields)

-		    (F1 POINTER)
-		    (F2 POINTER)
-		    (F3 POINTER)
-		    (F4 POINTER)
-		    (F5 POINTER)
-		    (FW6 WORD)
-		    (FW7 WORD)                               (* Following only filled in for open streams)

-		    (BYTESIZE BYTE)
-		    (BUFFS POINTER)
-		    (CPAGE WORD)
-		    (FW8 WORD)
-		    (MAXBUFFERS WORD)
-		    (CHARPOSITION WORD)                      (* Used by POSITION etc.)

-		    (DIRTYBITS WORD)
-		    (
LINELENGTH
 WORD)
-		    (EOLCONVENTION BITS 2)                   (* End-of-line convention)

-		    (CBUFDIRTY FLAG)
-		    (NIL BITS 5)
-		    (OUTCHARFN POINTER)
-		    (ENDOFSTREAMOP POINTER)                  (* For use of applications programs, not devices)

-		    (OTHERPROPS POINTER)
-		    (IMAGEOPS POINTER)                       (* Image operations vector)

-		    (IMAGEDATA POINTER)                      (* Image instance variables--format depends on 

-							     IMAGEOPS value)

-		    (EXTRASTREAMOP POINTER)
-		    (STRMBINFN POINTER)                      (* Either the BIN fn from the FDEV, or a trap)

-		    (STRMBOUTFN POINTER)                     (* Either the BIN fn from the FDEV, or a trap)

-		    (CBUFMAXSIZE WORD)
-		    (FW9 WORD)
-		    (F10 POINTER)                            (* the current character set for this stream.

-							     gbn 4-2-85)

-		    (
CHARSET
 BYTE))
-		   (
BLOCKRECORD
 STREAM ((NIL 2 WORD)
-				   (UCODEFLAGS BYTE)
-				   (NIL POINTER)))
-		   (
ACCESSFNS
 STREAM ((ACCESS \GETACCESS \SETACCESS)
-				 (
FULLNAME
 (
OR
 (fetch
 (STREAM FULLFILENAME) of
 DATUM)
-						   DATUM))
-				 (NAMEDP (
AND
 (fetch
 (STREAM FULLFILENAME) of
 DATUM)
-						T))))
-		   (
SYNONYM
 CBUFPTR (CPPTR))
-		   USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ NoBits BUFFS _ NIL BYTESIZE _ 8 
-		   CBUFPTR _ NIL MAXBUFFERS _(
PROGN
 (DECLARE
 (
GLOBALVARS
 
-								       \STREAM.DEFAULT.MAXBUFFERS))
-						      \STREAM.DEFAULT.MAXBUFFERS)
-		   CHARPOSITION _ 0 LINELENGTH _(
PROGN
 (DECLARE
 (
GLOBALVARS
 FILELINELENGTH))
-							 FILELINELENGTH)
-		   OUTCHARFN _(
FUNCTION
 \FILEOUTCHARFN)
-		   ENDOFSTREAMOP _(
FUNCTION
 \EOSERROR)
-		   IMAGEOPS _ \NOIMAGEOPS EOLCONVENTION _(
SELECTQ
 (
SYSTEMTYPE
)
-								    (D CR.EOLC)
-								    (VAX LF.EOLC)
-								    (JERICHO CRLF.EOLC)
-								    CR.EOLC)
-		   STRMBINFN _(
FUNCTION
 \STREAM.NOT.OPEN)
-		   STRMBOUTFN _(
FUNCTION
 \STREAM.NOT.OPEN))
-
-(DATATYPE FONTCLASS
 ((PRETTYFONT# BYTE)
-		       DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
-]
-(/DECLAREDATATYPE 'STREAM
-		  '(WORD WORD FLAG FLAG FLAG (BITS 5)
-			 POINTER FLAG FLAG FLAG FLAG FLAG (BITS 3)
-			 POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER 
-			 WORD WORD BYTE POINTER WORD WORD WORD WORD WORD WORD (BITS 2)
-			 FLAG
-			 (BITS 5)
-			 POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD 
-			 POINTER BYTE)
-		  '((STREAM 0 (BITS . 15))
-		    (STREAM 1 (BITS . 15))
-		    (STREAM 2 (FLAGBITS . 0))
-		    (STREAM 2 (FLAGBITS . 16))
-		    (STREAM 2 (FLAGBITS . 32))
-		    (STREAM 2 (BITS . 52))
-		    (STREAM 2 POINTER)
-		    (STREAM 4 (FLAGBITS . 0))
-		    (STREAM 4 (FLAGBITS . 16))
-		    (STREAM 4 (FLAGBITS . 32))
-		    (STREAM 4 (FLAGBITS . 48))
-		    (STREAM 4 (FLAGBITS . 64))
-		    (STREAM 4 (BITS . 82))
-		    (STREAM 4 POINTER)
-		    (STREAM 6 POINTER)
-		    (STREAM 8 POINTER)
-		    (STREAM 10 (BITS . 15))
-		    (STREAM 11 (BITS . 15))
-		    (STREAM 12 POINTER)
-		    (STREAM 14 POINTER)
-		    (STREAM 16 POINTER)
-		    (STREAM 18 POINTER)
-		    (STREAM 20 POINTER)
-		    (STREAM 22 (BITS . 15))
-		    (STREAM 23 (BITS . 15))
-		    (STREAM 20 (BITS . 7))
-		    (STREAM 24 POINTER)
-		    (STREAM 26 (BITS . 15))
-		    (STREAM 27 (BITS . 15))
-		    (STREAM 28 (BITS . 15))
-		    (STREAM 29 (BITS . 15))
-		    (STREAM 30 (BITS . 15))
-		    (STREAM 31 (BITS . 15))
-		    (STREAM 24 (BITS . 1))
-		    (STREAM 24 (FLAGBITS . 32))
-		    (STREAM 24 (BITS . 52))
-		    (STREAM 32 POINTER)
-		    (STREAM 34 POINTER)
-		    (STREAM 36 POINTER)
-		    (STREAM 38 POINTER)
-		    (STREAM 40 POINTER)
-		    (STREAM 42 POINTER)
-		    (STREAM 44 POINTER)
-		    (STREAM 46 POINTER)
-		    (STREAM 48 (BITS . 15))
-		    (STREAM 49 (BITS . 15))
-		    (STREAM 50 POINTER)
-		    (STREAM 50 (BITS . 7)))
-		  '52)
-(/DECLAREDATATYPE 'FONTCLASS
-		  '(BYTE POINTER POINTER POINTER POINTER POINTER)
-		  '((FONTCLASS 0 (BITS . 7))
-		    (FONTCLASS 0 POINTER)
-		    (FONTCLASS 2 POINTER)
-		    (FONTCLASS 4 POINTER)
-		    (FONTCLASS 6 POINTER)
-		    (FONTCLASS 8 POINTER))
-		  '10)
-(PUTPROPS DATE COPYRIGHT ("Leland Stanford Junior University" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (850 12872 (DATEOBJ 862 . 2359) (DATEOBJP 2363 . 2736) (DATE.DISPLAYFN 2740 . 3015) (
-DATE.IMAGEBOXFN 3019 . 3575) (CURRENT.DISPLAY.FONT 3579 . 4284) (DATE.PUTFN 4288 . 4541) (DATE.GETFN 
-4545 . 4956) (DATE.BUTTONEVENTINFN 4960 . 6275) (DATES.TEMPLATE 6279 . 7439) (AMPM 7443 . 7615) (
-DATES.MENU.APPLY 7619 . 8538) (DATES.MENU.WHENSELECTEDFN 8542 . 8780) (DATES.SET 8784 . 8895) (FINDDAY
- 8899 . 9154) (FINDHOUR 9158 . 9662) (FINDMONTH 9666 . 10427) (FINDTIME 10431 . 11846) (FINDYEAR 11850
- . 12124) (NUMP 12128 . 12368) (WHICHDATE 12372 . 12869)))))
-STOP

lispusers/DINFO

@@ -1,15 +1,16 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "14-Feb-2021 23:11:36" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;5
 64800  
 
-      changes to%:  (VARS DINFOCOMS)
+
(FILECREATED "25-Oct-2021 23:24:46" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;2
 65213  
 
-      previous date%: "14-Feb-2021 14:55:19" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;4)
+      changes to%:  (FNS DINFO.CREATE.FMENU)
+
+      previous date%: "14-Feb-2021 23:11:36" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>DINFO.;1)
 
 
 (* ; "
-Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
+Copyright (c) 1985-1987, 2020-2021 by Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT DINFOCOMS)
@@ -19,24 +20,24 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
         (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DINFOGRAPH DINFONODE)
                (FUNCTIONS DINFOGRAPHPROP))
         (INITRECORDS DINFOGRAPH)
-        (FNS                                                 (* ; "Primary functions")

+        (FNS                                                 (* ; "Primary functions")

              DINFO DINFO.UPDATE DINFOGRAPH DINFO.SPECIAL.UPDATE DINFO.READ.GRAPH DINFO.WRITE.GRAPH 
              DINFO.SELECT.GRAPH DINFO.DEFAULT.MENU DINFO.FIND DINFO.LOOKUP)
-        (FNS                                                 (* ; "Koto compatability")

+        (FNS                                                 (* ; "Koto compatability")

              DINFO.READ.KOTO.GRAPH)
-        (FNS                                                 (* ; "Window functions")

+        (FNS                                                 (* ; "Window functions")

              DINFO.SETUP.WINDOW DINFO.CLOSEFN DINFO.SHRINKFN DINFO.EXPANDFN DINFO.ICONFN)
-        (FNS                                                 (* ; "FreeMenu functions")

+        (FNS                                                 (* ; "FreeMenu functions")

              DINFO.ADD.FMENU DINFO.CREATE.FMENU DINFO.FMW.CLOSEFN DINFO.FMENU.HANDLER 
              DINFO.UPDATE.FMENU DINFO.TOGGLE.MENU DINFO.TOGGLE.GRAPH DINFO.TOGGLE.HISTORY 
              DINFO.TOGGLE.TEXT)
-        (FNS                                                 (* ; "Other menu functions")

+        (FNS                                                 (* ; "Other menu functions")

              DINFO.UPDATE.MENU.DISPLAY DINFO.UPDATE.FROM.MENU DINFO.UPDATE.HISTORY 
              DINFO.HISTORIC.UPDATE)
-        (FNS                                                 (* ; "Interface to GRAPHER")

+        (FNS                                                 (* ; "Interface to GRAPHER")

              DINFO.UPDATE.GRAPH.DISPLAY DINFO.UPDATE.FROM.GRAPH DINFO.GET.GRAPH.WINDOW 
              DINFO.CREATE.GRAPH.WINDOW DINFO.SHOWGRAPH DINFO.INVERT.NODE DINFO.LAYOUTGRAPH)
-        (FNS                                                 (* ; "Interface to TEdit")

+        (FNS                                                 (* ; "Interface to TEdit")

              DINFO.UPDATE.TEXT.DISPLAY DINFO.TITLEMENUFN DINFO.OPENTEXTSTREAM DINFO.SHOWSEL 
              DINFO.GET.FILENAME)
         (ADDVARS (BackgroundMenuCommands (DInfo (DINFO.SELECT.GRAPH)
@@ -539,14 +540,17 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
                 (DINFO.UPDATE.FMENU
 GRAPH])
 
 (DINFO.CREATE.FMENU

-  [LAMBDA (GRAPH)
                                            (* jow "15-Jul-86 17:39")

-          
-          (* * Makes a DInfo FreeMenu for GRAPH)

+  [LAMBDA (GRAPH)
                                       (* ; "Edited 25-Oct-2021 23:23 by rmk:")


+                                                             (* jow "15-Jul-86 17:39")

+
+(* ;;; "Makes a DInfo FreeMenu for GRAPH")

+
+    (* ;; "RMK:  Added MINSIZE and MAXSIZE so that the menu doesn't get distorted during reshaping")

 
     (LET* [(ADD.ITEMS (fetch
 (DINFOGRAPH
 FREEMENUITEMS) of
 GRAPH))
            (FONT (OR (FONTP (fetch
 (DINFOGRAPH
 MENUFONT) of
 GRAPH))
                      MENUFONT))
-           (FM (FREEMENU `((PROPS FONT %, FONT)
+           [FM (FREEMENU `((PROPS FONT %, FONT)
                            ((LABEL Node%: TYPE DISPLAY FONT (HELVETICA 10))
                             (ID NODE LABEL "" TYPE DISPLAY))
                            ((LABEL Top! SELECTEDFN DINFO.FMENU.HANDLER FONT (HELVETICA 10 BOLD)
@@ -585,8 +589,12 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
                                             (HELVETICA 10 BOLD)
                                             MESSAGE 
                             "Lookup a term in this graph.  LEFT for new term, MIDDLE to repeat last."
-                                            )) ADD.ITEMS]
+                                            ))
+                                  ADD.ITEMS]
+           (HEIGHT (FETCH
 (REGION HEIGHT) OF
 (WINDOWPROP FM 'REGION]
           (WINDOWPROP FM 'FM.DONTRESHAPE T)
+          (WINDOWPROP FM 'MINSIZE (CONS 0 HEIGHT))
+          (WINDOWPROP FM 'MAXSIZE (CONS 64000 HEIGHT))
           FM])
 
 (DINFO.FMW.CLOSEFN

@@ -1110,20 +1118,20 @@ Copyright (c) 1985, 1986, 1987, 2020, 2021 by Xerox Corporation.
 )
 (PUTPROPS DINFO COPYRIGHT ("Xerox Corporation" 1985 1986 1987 2020 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7732 24558 (DINFO 7742 . 9356) (DINFO.UPDATE 9358 . 12222) (DINFOGRAPH 12224 . 12642) (
-DINFO.SPECIAL.UPDATE 12644 . 14342) (DINFO.READ.GRAPH 14344 . 16199) (DINFO.WRITE.GRAPH 16201 . 17291)
- (DINFO.SELECT.GRAPH 17293 . 18200) (DINFO.DEFAULT.MENU 18202 . 20726) (DINFO.FIND 20728 . 23112) (
-DINFO.LOOKUP 23114 . 24556)) (24559 27253 (DINFO.READ.KOTO.GRAPH 24569 . 27251)) (27254 29568 (
-DINFO.SETUP.WINDOW 27264 . 27945) (DINFO.CLOSEFN 27947 . 28380) (DINFO.SHRINKFN 28382 . 28578) (
-DINFO.EXPANDFN 28580 . 29137) (DINFO.ICONFN 29139 . 29566)) (29569 40417 (DINFO.ADD.FMENU 29579 . 
-30674) (DINFO.CREATE.FMENU 30676 . 34213) (DINFO.FMW.CLOSEFN 34215 . 35060) (DINFO.FMENU.HANDLER 35062
- . 35701) (DINFO.UPDATE.FMENU 35703 . 37908) (DINFO.TOGGLE.MENU 37910 . 38500) (DINFO.TOGGLE.GRAPH 
-38502 . 39001) (DINFO.TOGGLE.HISTORY 39003 . 39547) (DINFO.TOGGLE.TEXT 39549 . 40415)) (40418 48116 (
-DINFO.UPDATE.MENU.DISPLAY 40428 . 44448) (DINFO.UPDATE.FROM.MENU 44450 . 44749) (DINFO.UPDATE.HISTORY 
-44751 . 47285) (DINFO.HISTORIC.UPDATE 47287 . 48114)) (48117 58283 (DINFO.UPDATE.GRAPH.DISPLAY 48127
- . 49445) (DINFO.UPDATE.FROM.GRAPH 49447 . 49890) (DINFO.GET.GRAPH.WINDOW 49892 . 50477) (
-DINFO.CREATE.GRAPH.WINDOW 50479 . 51596) (DINFO.SHOWGRAPH 51598 . 53323) (DINFO.INVERT.NODE 53325 . 
-54713) (DINFO.LAYOUTGRAPH 54715 . 58281)) (58284 64140 (DINFO.UPDATE.TEXT.DISPLAY 58294 . 60155) (
-DINFO.TITLEMENUFN 60157 . 61282) (DINFO.OPENTEXTSTREAM 61284 . 62500) (DINFO.SHOWSEL 62502 . 63235) (
-DINFO.GET.FILENAME 63237 . 64138)))))
+  (FILEMAP (NIL (7733 24559 (DINFO 7743 . 9357) (DINFO.UPDATE 9359 . 12223) (DINFOGRAPH 12225 . 12643) (
+DINFO.SPECIAL.UPDATE 12645 . 14343) (DINFO.READ.GRAPH 14345 . 16200) (DINFO.WRITE.GRAPH 16202 . 17292)
+ (DINFO.SELECT.GRAPH 17294 . 18201) (DINFO.DEFAULT.MENU 18203 . 20727) (DINFO.FIND 20729 . 23113) (
+DINFO.LOOKUP 23115 . 24557)) (24560 27254 (DINFO.READ.KOTO.GRAPH 24570 . 27252)) (27255 29569 (
+DINFO.SETUP.WINDOW 27265 . 27946) (DINFO.CLOSEFN 27948 . 28381) (DINFO.SHRINKFN 28383 . 28579) (
+DINFO.EXPANDFN 28581 . 29138) (DINFO.ICONFN 29140 . 29567)) (29570 40830 (DINFO.ADD.FMENU 29580 . 
+30675) (DINFO.CREATE.FMENU 30677 . 34626) (DINFO.FMW.CLOSEFN 34628 . 35473) (DINFO.FMENU.HANDLER 35475
+ . 36114) (DINFO.UPDATE.FMENU 36116 . 38321) (DINFO.TOGGLE.MENU 38323 . 38913) (DINFO.TOGGLE.GRAPH 
+38915 . 39414) (DINFO.TOGGLE.HISTORY 39416 . 39960) (DINFO.TOGGLE.TEXT 39962 . 40828)) (40831 48529 (
+DINFO.UPDATE.MENU.DISPLAY 40841 . 44861) (DINFO.UPDATE.FROM.MENU 44863 . 45162) (DINFO.UPDATE.HISTORY 
+45164 . 47698) (DINFO.HISTORIC.UPDATE 47700 . 48527)) (48530 58696 (DINFO.UPDATE.GRAPH.DISPLAY 48540
+ . 49858) (DINFO.UPDATE.FROM.GRAPH 49860 . 50303) (DINFO.GET.GRAPH.WINDOW 50305 . 50890) (
+DINFO.CREATE.GRAPH.WINDOW 50892 . 52009) (DINFO.SHOWGRAPH 52011 . 53736) (DINFO.INVERT.NODE 53738 . 
+55126) (DINFO.LAYOUTGRAPH 55128 . 58694)) (58697 64553 (DINFO.UPDATE.TEXT.DISPLAY 58707 . 60568) (
+DINFO.TITLEMENUFN 60570 . 61695) (DINFO.OPENTEXTSTREAM 61697 . 62913) (DINFO.SHOWSEL 62915 . 63648) (
+DINFO.GET.FILENAME 63650 . 64551)))))
 STOP

lispusers/EXAMINEDEFS

@@ -0,0 +1,120 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+
(FILECREATED "20-Dec-2021 11:06:33" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;7
 6367   
+
+      :CHANGES-TO (FNS EXAMINEDEFS)
+
+      :PREVIOUS-DATE "19-Dec-2021 22:45:48" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>EXAMINEDEFS.;5)
+
+
+(PRETTYCOMPRINT EXAMINEDEFSCOMS)
+
+(RPAQQ EXAMINEDEFSCOMS
 ((FNS EXAMINEDEFS EXAMINEDEFS-REGION)
+                        (INITVARS (EXAMINEDEFS-PROCESS-LIST))))
+(DEFINEQ
+
+(EXAMINEDEFS

+  [LAMBDA (NAME TYPE SOURCE1 SOURCE2 TITLE1 TITLE2 REGION)   (* ; "Edited 20-Dec-2021 11:06 by rmk")

+
+    (* ;; "This provides for side-by-side examination of separate but presumably related expressions.  The (LISTP) expressions can be provided directly as SOURCE1 and SOURCE2 or, if NAME is given the copies of the definitions of NAME as TYPE on the two sources are examined.")

+
+    (* ;; "")

+
+    (* ;; "Examination is in side-by-side attached SEDIT windows if SEDIT is the EDITMODE.  You can use SEDIT operations to zoom in on the location of any changes, deleting common stuff for example.  But you are always working on a copy, so that changes are safe and ephemeral.  This is an examination, not an edit.")

+
+    (CL:UNLESS NAME
+        (CL:UNLESS (LISTP SOURCE1)
+               (ERROR SOURCE1 " cannot be examined"))
+        (CL:UNLESS (LISTP SOURCE2)
+               (ERROR SOURCE2 " cannot be examined")))
+
+    (* ;; "TITLE1 and TITLE2 are optional strings that will be used to construct the titles of the SEDIT windows. We would like to know where GETDEF got the definition so we can use that, but there isn't an interface that provides that information (extended WHEREIS?)")

+
+    (LET (DEF1 DEF2)
+         (SETQ DEF1 (IF
 (LISTP SOURCE1)
+                        THEN
 
+                             (* ;; "Copy to simulate READONLY")

+
+                             (SETQ DEF1 (COPY SOURCE1))
+                      ELSEIF
 (GETDEF NAME TYPE SOURCE1)
+                      ELSE
 (ERROR NAME " not found on " SOURCE1)))
+         (SETQ DEF2 (IF
 (LISTP SOURCE2)
+                        THEN
 (COPY SOURCE2)
+                      ELSEIF
 (GETDEF NAME TYPE SOURCE2)
+                      ELSE
 (ERROR NAME " not found on " SOURCE2)))
+         (CL:UNLESS TITLE1
+             (SETQ TITLE1 (OR SOURCE1 "File 1")))
+         (CL:UNLESS TITLE2
+             (SETQ TITLE2 (OR SOURCE2 "File 2")))
+         (SELECTQ (EDITMODE)
+             (SEDIT:SEDIT 
+                          (* ;; 
+
                          "A kludge to eliminate dangling SEDIT processes from previous examinations")

+
+                          [SETQ EXAMINEDEFS-PROCESS-LIST
+                           (FOR
 PAIR IN
 EXAMINEDEFS-PROCESS-LIST
+                              COLLECT
 (IF
 (OPENWP (CAR PAIR))
+                                          THEN
 PAIR
+                                        ELSE
 (DEL.PROCESS (CDR PAIR))
+                                             (GO $$ITERATE]
+
+                          (* ;; "Set it up for new side-by-side regions that are forgotten when the window is closed.  Their shape is usually not that useful for regular edits.")

+
+                          (* ;; 
+
     "Crude suggestions for height, width, position.  Suggest shorter window for  smaller structures")

+
+                          (CL:UNLESS (REGIONP REGION)
+                              (SETQ REGION (GETREGION)))
+                          (LET (W1 W2 HALFWIDTH)
+                               (SETQ HALFWIDTH (IQUOTIENT (FETCH
 (REGION WIDTH) OF
 REGION)
+                                                      2))
+                               [SETQ W1
+                                (SEDIT:GET-WINDOW (SEDIT:SEDIT DEF1
+                                                         `(:NAME ,(CONCAT NAME " from " TITLE1)
+                                                                 :REGION
+                                                                 ,(CREATE
 REGION
+                                                                     USING
 REGION WIDTH _ HALFWIDTH)
+                                                                 :DONT-KEEP-WINDOW-REGION T]
+                               [SETQ W2
+                                (SEDIT:GET-WINDOW
+                                 (SEDIT:SEDIT DEF2
+                                        `(:NAME ,(CONCAT NAME " from " TITLE2)
+                                                :REGION
+                                                ,(CREATE
 REGION USING
 REGION LEFT _
+                                                                      (IPLUS (FETCH
 (REGION LEFT)
+                                                                                OF
 REGION)
+                                                                             HALFWIDTH)
+                                                                      WIDTH _ HALFWIDTH)
+                                                :DONT-KEEP-WINDOW-REGION T]
+
+                               (* ;; 
+
   "So we can kill the processes on the next call, if they still exist after the windows are closed.")

+
+                               [PUSH
 EXAMINEDEFS-PROCESS-LIST (CONS W1 (WINDOWPROP W1 'PROCESS))
+                                     (CONS W2 (WINDOWPROP W2 'PROCESS]
+                               (ATTACHWINDOW W2 W1 'RIGHT 'JUSTIFY)
+                               (MODERNWINDOW W2)))
+             (PROGN (EDITE DEF1)
+                    (EDITE DEF2])
+
+(EXAMINEDEFS-REGION

+  [LAMBDA (WIDTH HEIGHT)                                     (* ; "Edited 10-Dec-2021 10:15 by rmk")

+
+    (* ;; "Prompts for a WIDTH-HEIGHT region with the top-left corner positioned at the initial cursor but the cursor then moved to the bottom-right for size adjustments.  Thus the default behavior is that the upper left corner is fixed.")

+
+    (GETMOUSESTATE)
+    (LET* ((LEFT LASTMOUSEX)
+           (RIGHT (IPLUS LEFT WIDTH))
+           (TOP LASTMOUSEY)
+           (BOTTOM (IDIFFERENCE TOP HEIGHT)))
+          (\CURSORPOSITION RIGHT BOTTOM)
+          (GETREGION NIL NIL (CREATEREGION LEFT BOTTOM WIDTH HEIGHT)
+                 NIL NIL (LIST LEFT TOP RIGHT BOTTOM])
+)
+
+(RPAQ? EXAMINEDEFS-PROCESS-LIST
 )
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (513 6305 (EXAMINEDEFS 523 . 5601) (EXAMINEDEFS-REGION 5603 . 6303)))))
+STOP

lispusers/LIFE

@@ -1,119 +1,156 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-
(filecreated "20-Aug-88 12:18:43" {erinyes}<lispusers>medley>life.\;5
 8231   
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
 
-      |previous| |date:| " 6-Mar-87 19:11:20" {erinyes}<lispusers>medley>life.\;3)
+
(FILECREATED " 6-Dec-2021 15:21:48" |{DSK}<home>medley>medley>lispusers>LIFE.;3|
 9875   
+
+      |changes| |to:|  (VARS LIFECOMS)
+                       (FNS EXPAND.BITMAP.VERTICALLY)
+
+      |previous| |date:| "20-Aug-88 12:18:43" |{DSK}<home>medley>medley>lispusers>LIFE.;1|)
 
 
-; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.
+; Copyright (c) 1987-1988 by Xerox Corporation.
 
-(prettycomprint lifecoms)
+(PRETTYCOMPRINT LIFECOMS)
 
-(rpaqq lifecoms

-       ((functions |Life| |LifeIdle|)
-        (fns expand.bitmap.vertically expand.bitmap.horizontally)
-        (addvars (idle.functions ("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|)
-                                                                ("Double bits" '(lambda (\w)
+(RPAQQ LIFECOMS

+       ((PROP FILETYPE LIFE)
+        (FUNCTIONS |Life| |LifeIdle|)
+        (FNS EXPAND.BITMAP.VERTICALLY EXPAND.BITMAP.HORIZONTALLY)
+        (ADDVARS (IDLE.FUNCTIONS ("Life" '|LifeIdle| NIL (SUBITEMS ("Single bits" '|LifeIdle|)
+                                                                ("Double bits" '(LAMBDA (\w)
                                                                                        (|LifeIdle|
                                                                                         \w 2)))
                                                                 ("Quadruple bits"
-                                                                 '(lambda (\w)
+                                                                 '(LAMBDA (\w)
                                                                          (|LifeIdle| \w 4)))
-                                                                ("Eight bits" '(lambda (\w)
+                                                                ("Eight bits" '(LAMBDA (\w)
                                                                                       (|LifeIdle|
                                                                                        \w 8)))))))))
 
-(cl:defun |Life|
 (win &optional (n 1))
-   (let* ((w (windowprop win 'width))
-          (w1 (idifference w n))
-          (h (iquotient (windowprop win 'height)
-                    n))
-          (h1 (sub1 h))
-          (a (bitmapcreate w h))
-          (b (bitmapcreate w h))
-          (c (bitmapcreate w h))
-          (d (bitmapcreate w h))
-          (e (bitmapcreate w h))
-          pbt temp)
-         (|if|
 (neq n 1)
-             |then|
 (setq temp (bitmapcreate (iquotient w n)
-                                          h))
-                   (setq pbt (|create|
 pilotbbt))
-                   (bitblt win 0 0 temp 0 0)
-                   (expand.bitmap.horizontally
 temp n a pbt)
-                   (setq temp (bitmapcreate w (windowprop win 'height)))
-                   (bitblt a 0 0 temp 0 0 w h)
-           |else|
 (bitblt win 0 0 a 0 0 w h))
-         (cl:loop (block)
-                (cl:macrolet ((bitbltbitmap (source sourceleft sourcebottom destination 
-                                                   destinationleft destinationbottom width height 
-                                                   &optional sourcetype operation)
-                                     `(\\bitblt.bitmap ,source ,sourceleft ,sourcebottom 
-                                             ,destination ,destinationleft ,destinationbottom
-                                             ,width
-                                             ,height
-                                             ,sourcetype
-                                             ,operation nil nil ,sourceleft ,sourcebottom))
-                              (shuffle (inhi lo horiz?)
-                                     `(progn ,@(|if|
 horiz?
-                                                   |then|
 `((bitbltbitmap ,inhi n 0 ,lo 0 0 w1 h)
-                                                                (bitbltbitmap ,inhi 0 0 ,lo w1 0 n h)
-                                                                (bitbltbitmap ,inhi 0 0 c n 0 w1 h)
-                                                                (bitbltbitmap ,inhi w1 0 c 0 0 n h))
-                                                 |else|
 `((bitbltbitmap ,inhi 0 1 ,lo 0 0 w h1)
-                                                              (bitbltbitmap ,inhi 0 0 ,lo 0 h1 w 1)
-                                                              (bitbltbitmap ,inhi 0 0 c 0 1 w h1)
-                                                              (bitbltbitmap ,inhi 0 h1 c 0 0 w 1)))
-                                             (bitbltbitmap c 0 0 ,lo 0 0 w h 'input 'invert)
-                                             (bitbltbitmap ,lo 0 0 c 0 0 w h 'input 'erase)
-                                             (bitbltbitmap ,inhi 0 0 ,lo 0 0 w h 'input 'invert)
-                                             (bitbltbitmap ,lo 0 0 ,inhi 0 0 w h 'input 'erase)
-                                             (bitbltbitmap c 0 0 ,inhi 0 0 w h 'input 'paint))))
-                       (shuffle a b t)
-                       (shuffle b d nil)
-                       (shuffle a e nil)
-                       (bitbltbitmap d 0 0 c 0 0 w h)
-                       (bitbltbitmap b 0 0 c 0 0 w h 'input 'invert)
-                       (bitbltbitmap e 0 0 c 0 0 w h 'input 'invert)
-                       (|if|
 (eq n 1)
-                           |then|
 (bitblt win 0 0 d 0 0 w h 'input 'paint)
-                         |else|
 (bitbltbitmap temp 0 0 d 0 0 w h 'input 'paint))
-                       (|if|
 (shiftdownp 'ctrl)
-                           |then|
 (bitbltbitmap d 0 0 a 0 0 w h)
-                         |else|
 (bitbltbitmap b 0 0 e 0 0 w h 'input 'paint)
-                               (bitbltbitmap e 0 0 a 0 0 w h 'input 'invert)
-                               (bitbltbitmap c 0 0 a 0 0 w h 'input 'erase)
-                               (bitbltbitmap d 0 0 a 0 0 w h 'invert 'erase))
-                       (|if|
 (eq n 1)
-                           |then|
 (bitblt a 0 0 win 0 0 w h)
-                         |else|
 (expand.bitmap.vertically
 a n temp pbt)
-                               (bitblt temp 0 0 win 0 0)
-                               (bitbltbitmap a 0 0 temp 0 0 w h))))))
+(PUTPROPS LIFE
 FILETYPE
 :COMPILE-FILE)
 
-(cl:defun |LifeIdle|
 (\w &optional (\n 1))
-   (bitblt (windowprop \w 'imagecovered)
+(CL:DEFUN |Life|
 (WIN &OPTIONAL (N 1))
+   (LET* ((W (WINDOWPROP WIN 'WIDTH))
+          (W1 (IDIFFERENCE W N))
+          (H (IQUOTIENT (WINDOWPROP WIN 'HEIGHT)
+                    N))
+          (H1 (SUB1 H))
+          (A (BITMAPCREATE W H))
+          (B (BITMAPCREATE W H))
+          (C (BITMAPCREATE W H))
+          (D (BITMAPCREATE W H))
+          (E (BITMAPCREATE W H))
+          PBT TEMP)
+         (|if|
 (NEQ N 1)
+             |then|
 (SETQ TEMP (BITMAPCREATE (IQUOTIENT W N)
+                                          H))
+                   (SETQ PBT (|create|
 PILOTBBT))
+                   (BITBLT WIN 0 0 TEMP 0 0)
+                   (EXPAND.BITMAP.HORIZONTALLY
 TEMP N A PBT)
+                   (SETQ TEMP (BITMAPCREATE W (WINDOWPROP WIN 'HEIGHT)))
+                   (BITBLT A 0 0 TEMP 0 0 W H)
+           |else|
 (BITBLT WIN 0 0 A 0 0 W H))
+         (CL:LOOP (BLOCK)
+                (CL:MACROLET ((BITBLTBITMAP (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION 
+                                                   DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT 
+                                                   &OPTIONAL SOURCETYPE OPERATION)
+                                     `(\\BITBLT.BITMAP ,SOURCE ,SOURCELEFT ,SOURCEBOTTOM 
+                                             ,DESTINATION ,DESTINATIONLEFT ,DESTINATIONBOTTOM
+                                             ,WIDTH
+                                             ,HEIGHT
+                                             ,SOURCETYPE
+                                             ,OPERATION NIL NIL ,SOURCELEFT ,SOURCEBOTTOM))
+                              (SHUFFLE (INHI LO HORIZ?)
+                                     `(PROGN ,@(|if|
 HORIZ?
+                                                   |then|
 `((BITBLTBITMAP ,INHI N 0 ,LO 0 0 W1 H)
+                                                                (BITBLTBITMAP ,INHI 0 0 ,LO W1 0 N H)
+                                                                (BITBLTBITMAP ,INHI 0 0 C N 0 W1 H)
+                                                                (BITBLTBITMAP ,INHI W1 0 C 0 0 N H))
+                                                 |else|
 `((BITBLTBITMAP ,INHI 0 1 ,LO 0 0 W H1)
+                                                              (BITBLTBITMAP ,INHI 0 0 ,LO 0 H1 W 1)
+                                                              (BITBLTBITMAP ,INHI 0 0 C 0 1 W H1)
+                                                              (BITBLTBITMAP ,INHI 0 H1 C 0 0 W 1)))
+                                             (BITBLTBITMAP C 0 0 ,LO 0 0 W H 'INPUT 'INVERT)
+                                             (BITBLTBITMAP ,LO 0 0 C 0 0 W H 'INPUT 'ERASE)
+                                             (BITBLTBITMAP ,INHI 0 0 ,LO 0 0 W H 'INPUT 'INVERT)
+                                             (BITBLTBITMAP ,LO 0 0 ,INHI 0 0 W H 'INPUT 'ERASE)
+                                             (BITBLTBITMAP C 0 0 ,INHI 0 0 W H 'INPUT 'PAINT))))
+                       (SHUFFLE A B T)
+                       (SHUFFLE B D NIL)
+                       (SHUFFLE A E NIL)
+                       (BITBLTBITMAP D 0 0 C 0 0 W H)
+                       (BITBLTBITMAP B 0 0 C 0 0 W H 'INPUT 'INVERT)
+                       (BITBLTBITMAP E 0 0 C 0 0 W H 'INPUT 'INVERT)
+                       (|if|
 (EQ N 1)
+                           |then|
 (BITBLT WIN 0 0 D 0 0 W H 'INPUT 'PAINT)
+                         |else|
 (BITBLTBITMAP TEMP 0 0 D 0 0 W H 'INPUT 'PAINT))
+                       (|if|
 (SHIFTDOWNP 'CTRL)
+                           |then|
 (BITBLTBITMAP D 0 0 A 0 0 W H)
+                         |else|
 (BITBLTBITMAP B 0 0 E 0 0 W H 'INPUT 'PAINT)
+                               (BITBLTBITMAP E 0 0 A 0 0 W H 'INPUT 'INVERT)
+                               (BITBLTBITMAP C 0 0 A 0 0 W H 'INPUT 'ERASE)
+                               (BITBLTBITMAP D 0 0 A 0 0 W H 'INVERT 'ERASE))
+                       (|if|
 (EQ N 1)
+                           |then|
 (BITBLT A 0 0 WIN 0 0 W H)
+                         |else|
 (EXPAND.BITMAP.VERTICALLY
 A N TEMP PBT)
+                               (BITBLT TEMP 0 0 WIN 0 0)
+                               (BITBLTBITMAP A 0 0 TEMP 0 0 W H))))))
+
+(CL:DEFUN |LifeIdle|
 (\w &OPTIONAL (\n 1))
+   (BITBLT (WINDOWPROP \w 'IMAGECOVERED)
           0 0 \w)
-   (|Life| \w \n))
-(defineq
+   (|Life|
 \w \n))
+(DEFINEQ
 
-(expand.bitmap.vertically

-(lambda (bitmap m bm2 pbt) (* \; "Edited  6-Mar-87 15:02 by Masinter") (or bm2 (setq bm2 (bitmapcreate (|fetch| bitmapwidth bitmap) (times m (|fetch| bitmapheight bitmap))))) (or pbt (setq pbt (|create| pilotbbt))) (|with| pilotbbt pbt (*) (setq pbtdesthi (|ffetch| |BitMapHiLoc| bm2)) (setq pbtdestlo (|ffetch| |BitMapLoLoc| bm2)) (setq pbtsourcehi (|ffetch| |BitMapHiLoc| bitmap)) (setq pbtsourcelo (|ffetch| |BitMapLoLoc| bitmap)) (setq pbtdestbpl (times 16 m (|ffetch| bitmaprasterwidth bm2))) (setq pbtsourcebpl (times 16 (|ffetch| bitmaprasterwidth bitmap))) (setq pbtsourcebit 0) (setq pbtdestbit 0) (setq pbtflags 16384) (setq pbtheight (|fetch| bitmapheight bitmap)) (setq pbtwidth (|fetch| bitmapwidth bitmap)) (|for| i |from| 0 |while| (lessp i m) |do| (\\pilotbitblt pbt 0) (|add| pbtdestlo (|fetch| bitmaprasterwidth bm2)))) bm2)
-)
+(EXPAND.BITMAP.VERTICALLY

+  (LAMBDA (BITMAP M BM2 PBT)                                 (* \; 
+
                                                           "Edited  6-Dec-2021 15:04 by medley")

+                                                             (* \; 
+
                                                           "Edited  6-Dec-2021 14:47 by medley")

+                                                             (* \; 
+
                                                           "Edited  6-Dec-2021 13:54 by medley")

+                                                             (* \; 
+
                                                           "Edited  6-Dec-2021 13:51 by medley")

+                                                             (* \; 
+
                                                           "Edited  6-Dec-2021 13:11 by medley")

+                                                             (* \; 
+
                                                           "Edited  6-Mar-87 15:02 by Masinter")

+    (OR BM2 (SETQ BM2 (BITMAPCREATE (|fetch|
 BITMAPWIDTH BITMAP)
+                             (TIMES M (|fetch|
 BITMAPHEIGHT BITMAP)))))
+    (OR PBT (SETQ PBT (|create|
 PILOTBBT)))
+    (|with|
 PILOTBBT PBT                                 (*)

+           (SETQ PBTDESTHI (|ffetch|
 |BitMapHiLoc| BM2))
+           (SETQ PBTDESTLO (|ffetch|
 |BitMapLoLoc| BM2))
+           (SETQ PBTSOURCEHI (|ffetch|
 |BitMapHiLoc| BITMAP))
+           (SETQ PBTSOURCELO (|ffetch|
 |BitMapLoLoc| BITMAP))
+           (SETQ PBTDESTBPL (TIMES 16 M (|ffetch|
 BITMAPRASTERWIDTH BM2)))
+           (SETQ PBTSOURCEBPL (TIMES 16 (|ffetch|
 BITMAPRASTERWIDTH BITMAP)))
+           (SETQ PBTSOURCEBIT 0)
+           (SETQ PBTDESTBIT 0)
+           (SETQ PBTFLAGS 16384)
+           (SETQ PBTHEIGHT (|fetch|
 BITMAPHEIGHT BITMAP))
+           (SETQ PBTWIDTH (|fetch|
 BITMAPWIDTH BITMAP))
+           (|for|
 I |from|
 1 |to|
 M |do|
 (\\PILOTBITBLT PBT 0)
+                                                      (|add|
 PBTDESTLO (|fetch|
 
+                                                                                  BITMAPRASTERWIDTH
+                                                                              |of|
 BM2))))
+    BM2))
 
 (expand.bitmap.horizontally

 (lambda (bitmap n bm2 pbt) (* \; "Edited  6-Mar-87 17:08 by Masinter") (or bm2 (setq bm2 (bitmapcreate (times n (|fetch| bitmapwidth bitmap)) (|fetch| bitmapheight bitmap)))) (or pbt (setq pbt (|create| pilotbbt))) (let ((sourcebase (|fetch| bitmapbase bitmap)) (destbase (|fetch| bitmapbase bm2))) (|with| pilotbbt pbt (setq pbtdestbpl n) (setq pbtsourcebpl 1) (setq pbtsourcebit 0) (setq pbtflags 16384) (setq pbtwidth 1) (let ((ht (times (|fetch| bitmapwidth bitmap) (|fetch| bitmapheight bitmap)))) (|do| (setq pbtdest destbase) (setq pbtsource sourcebase) (setq pbtheight (min (times 1024 16) ht)) (setq pbtdestbit 0) (|for| i |from| 0 |while| (lessp i n) |do| (\\pilotbitblt pbt 0) (|add| pbtdestbit 1)) (setq ht (- ht (times 1024 16))) (|if| (leq ht 0) |then| (return)) (setq destbase (\\addbase destbase (times n 1024))) (setq sourcebase (\\addbase sourcebase 1024)))))) bm2)
 )
 )
 
-(addtovar idle.functions

-          ("Life" '|LifeIdle| nil (subitems ("Single bits" '|LifeIdle|)
-                                         ("Double bits" '(lambda (\w)
+(ADDTOVAR IDLE.FUNCTIONS

+          ("Life" '|LifeIdle| NIL (SUBITEMS ("Single bits" '|LifeIdle|)
+                                         ("Double bits" '(LAMBDA (\w)
                                                                 (|LifeIdle| \w 2)))
-                                         ("Quadruple bits" '(lambda (\w)
+                                         ("Quadruple bits" '(LAMBDA (\w)
                                                                    (|LifeIdle| \w 4)))
-                                         ("Eight bits" '(lambda (\w)
+                                         ("Eight bits" '(LAMBDA (\w)
                                                                (|LifeIdle| \w 8))))))
-(putprops life copyright ("Xerox Corporation" 1987 1988))
-(declare\: dontcopy
-  (filemap (nil (5774 7579 (expand.bitmap.vertically 5784 . 6658) (expand.bitmap.horizontally 6660 . 
-7577)))))
-stop
+(PUTPROPS LIFE COPYRIGHT ("Xerox Corporation" 1987 1988))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1557 5825 (|Life| 1557 . 5825)) (5827 5955 (|LifeIdle| 5827 . 5955)) (5956 9223 (
+EXPAND.BITMAP.VERTICALLY 5966 . 8302) (EXPAND.BITMAP.HORIZONTALLY 8304 . 9221)))))
+STOP

lispusers/MIGRATION/DIR.TXT

@@ -0,0 +1,3 @@
+Contains a tool for translating File Manger format Interlisp source
+files from Medley into Common Lisp text files.  The software runs in
+the Medley system.

lispusers/MIGRATION/FILEPKGRECORDS

@@ -0,0 +1,116 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+(* "
+Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation.  All rights reserved.
+The following program was created in 1982 but has not been published
+within the meaning of the copyright law, is furnished under license,
+and may not be used, copied and/or disclosed except in accordance
+with the terms of said license.
+")
+
+(PRETTYCOMPRINT FILEPKGRECORDSCOMS)
+
+(RPAQQ FILEPKGRECORDSCOMS
 
+       [(COMS                                                (* ; 
+
             "standard records for accessing file package type/command parts.  Exported for PRETTY")

+              (RECORDS * FILEPKGRECORDS)])
+
+(RPAQQ FILEPKGRECORDS
 (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
+
+(ACCESSFNS FILEPKGCOM
 [[ADD
 (GETPROP DATUM 'ADDTOPRETTYCOM)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
+                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
+                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
+                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
+                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
+                                               (T (/REMPROP DATUM 'PRETTYTYPE]
+                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
+                                  (UNDOABLE (COND
+                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
+                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
+                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
+                                  (STANDARD [COND
+                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
+                                                                (OR (LISTP (GETTOPVAL 
+                                                                                  'PRETTYDEFMACROS))
+                                                                    (SETTOPVAL 'PRETTYDEFMACROS
+                                                                           (LIST (LIST DATUM]
+                                               (T (SETTOPVAL 'PRETTYDEFMACROS
+                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
+                                                                                'PRETTYDEFMACROS))
+                                                                (GETTOPVAL 'PRETTYDEFMACROS]
+                                         UNDOABLE
+                                         (COND
+                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
+                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
+                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
+                                                                        (LIST (LIST DATUM]
+                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
+                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
+                                                                                   'PRETTYDEFMACROS))
+                                                             (GETTOPVAL 'PRETTYDEFMACROS]
+                                                             (* Not an atom record cause want 
+
                                                           REMPROP on NILs.)

+                                                             (* NOTE%: PRETTCOM on PRETTY has 
+
                                                           open-coded access to the MACRO 
+
                                                           property.)

+                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
+                                       FILEPKGCONTENTS)))
+
+
+
+(ATOMRECORD FILEPKGTYPE
 (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
+                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
+                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
+                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
+                                                           )
+                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
+                                                                              DATUM)))
+                                                           (STANDARD (SETTOPVAL (CAR (
+                                                                                  SEARCHPRETTYTYPELST
+                                                                                      DATUM NEWVALUE)
+                                                                                     )
+                                                                            NEWVALUE)
+                                                                  UNDOABLE
+                                                                  (/SETTOPVAL (CAR (
+                                                                                  SEARCHPRETTYTYPELST
+                                                                                    DATUM NEWVALUE))
+                                                                         NEWVALUE)))
+                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
+                                                                             DATUM)))
+                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
+                                                                               DATUM NEWVALUE))
+                                                                       NEWVALUE)))
+                                                    (ALLFIELDS NIL (/SETTOPVAL
+                                                                    'PRETTYTYPELST
+                                                                    (REMOVE (SEARCHPRETTYTYPELST
+                                                                             DATUM)
+                                                                           (GETTOPVAL 'PRETTYTYPELST]
+                                                             (* NOTE%: PRETTYCOM on PRETTY has 
+
                                                           open-coded access to GETDEF property)

+                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
+                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
+                                                                                   (PUT X
+                                                                                        'PROPTYPE
+                                                                                        'FILEPKGCOMS]
+                                         (ADDTOVAR PRETTYTYPELST))))
+
+
+(ATOMRECORD FILE
 (FILECHANGES FILEDATES FILEMAP)
+                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
+                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
+                                                    UNDOABLE
+                                                    (/PUTPROP DATUM 'FILE NEWVALUE])
+
+(RECORD FILEDATEPAIR
 (FILEDATE . DATEFILENAME))
+
+(RECORD FILEPROP
 ((COMSNAME . LOADTYPE) . TOBEDUMPED))
+
+
+
+IL:STOP

lispusers/MIGRATION/FILEPKGRECORDS.LCOM

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

lispusers/MIGRATION/IL-CONVERT

@@ -0,0 +1,805 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL-CONVERT" BASE 10)
+
(IL:FILECREATED "26-Jan-90 10:28:55" IL:|{DSK}/users/welch/migration/IL-CONVERT.;5|
 30652  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:IL-CONVERTCOMS)
+
+      IL:|previous| IL:|date:| "25-Jan-90 14:45:43" IL:|{DSK}/users/welch/migration/IL-CONVERT.;4|)
+
+
+; Copyright (c) 1989, 1990 by ENVOS Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:IL-CONVERTCOMS)
+
+(IL:RPAQQ IL:IL-CONVERTCOMS
 
+          ((IL:FUNCTIONS IL-DEFCONV)
+           
+           (IL:* IL:|;;| 
+
        "Used when an Interlisp function is the same as the Common Lisp function of the same name.")

+
+           (IL:FUNCTIONS IL-COPYDEF)
+           
+           (IL:* IL:|;;| "Used to define a run-time function (not a converter function).")

+
+           (IL:FUNCTIONS IL-DEFUN IL-DEFVAR)
+           
+           (IL:* IL:|;;| "
+; Creates an external symbol in the IL package.
+(defmacro il-defsym (name)
+    `(export (intern (symbol-name ',name) *il-package*) *il-package*))
+
+(defmacro il-import (symbol)
+  `(progn (import ,symbol 'il)
+	  (export (find-symbol (symbol-name ,symbol) 'il) 'il)))
+")

+
+           (IL:FUNCTIONS IL-COPYCONV)
+           
+           (IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")

+
+           (IL:FUNCTIONS IL-WARNINGFORM)
+           
+           (IL:* IL:|;;| "Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1.  Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR).")

+
+           (IL:P
+            (MACROLET ((DEF-*-IF-NEEDED
+                        (NAME)
+                        (LET ((NAME-STRING (SYMBOL-NAME NAME)))
+                             `(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED"))
+                                     (ARGS)
+                                     (CASE (LENGTH ARGS)
+                                         (0 ,(EVAL `(,NAME)))
+                                         (1 (FIRST ARGS))
+                                         (T `(,',NAME ,@ARGS)))))))
+                   (DEF-*-IF-NEEDED PROGN)
+                   (DEF-*-IF-NEEDED AND)
+                   (DEF-*-IF-NEEDED OR)))
+           (IL:STRUCTURES FAKE-SYMBOL SHARP-DOT SHARP-COMMA)
+           
+           (IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")

+
+           (IL:FUNCTIONS QUOTED-SYMBOL-P)
+           (IL:VARIABLES *ORIGINAL-READTABLE*)
+           (IL:FUNCTIONS OLD-CONVERT-FILE)
+           (IL:P (EXPORT 'CONVERT-FILE))
+           
+           (IL:* IL:|;;| "(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")")

+
+           (IL:P (EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES)))
+           (IL:FUNCTIONS READ-EXPORTS)
+                                                             (IL:* IL:\; "Get the symbol list")

+           (IL:FUNCTIONS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES READ-HASH-TABLE 
+                  WRITE-HASH-TABLE)
+           (IL:FUNCTIONS CONVERT-FILE CONVERT-FILECOMS CONVERT-ONE-FILECOM 
+                  EXPURGATE-EXTRANEOUS-PROGNS REORDER-FILECOMS MAKE-EXPORT-FORM)
+           (IL:VARIABLES *WALKER-TEMPLATES*)
+           (IL:FUNCTIONS GET-WALKER-TEMPLATE WALK-FORM-INTERNAL WALK-TEMPLATE 
+                  WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-REPEAT-EVAL RECONS 
+                  RELIST RELIST* RELIST-INTERNAL)
+           (IL:VARIABLES *GETVALUE-TRANSLATION* *CURRENT-DEFINITION* *CURRENT-DEFINITION-TYPE* 
+                  *CURRENT-EXPRESSION* *CURRENT-LOCALS* *FILE-CONTEXT* *WALKER-FIND-PARAMETER-LIST* 
+                  *WARNINGS-MADE* *PACKAGE-FOR-IL-SYMBOLS* *PACKAGE-FOR-RESULT-FILE* 
+                  *PARAMETERS-ALWAYS-OPTIONAL* *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE* 
+                  *UNKNOWN-MACRO-ACTION* *ALWAYS-INCLUDE-PROPS*)
+           (IL:DECLARE\: IL:DONTCOPY (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE)
+                                            IL:IL-CONVERT))))
+
+(XCL:DEFDEFINER IL-DEFCONV
 IL:FUNCTIONS (NAME ARGLIST &REST REST)
+   (CHECK-TYPE NAME SYMBOL)
+   (LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
+                         *IL-PACKAGE*)))
+        (IF FN-NAME
+            `(SETF (GET ',FN-NAME 'CONVERT-FORM)
+                   #'(LAMBDA ,ARGLIST ,@REST))
+            (PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
+                   NIL))))
+
+
+
+(IL:* IL:|;;| 
+"Used when an Interlisp function is the same as the Common Lisp function of the same name.")

+
+
+(DEFMACRO IL-COPYDEF
 (NAME &OPTIONAL (NEWNAME NAME))
+   (LET ((SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
+                     *IL-PACKAGE*)))
+        (UNLESS SYM (ERROR "No symbol ~:@(~a~) found in IL package." SYM))
+        `(SETF (GET ',SYM 'CONVERT-FORM)
+               #'(LAMBDA (&REST ARGS)
+                        (CONS ',NAME (MAPCONVERT ARGS))))))
+
+
+
+(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")

+
+
+(XCL:DEFDEFINER IL-DEFUN
 IL:FUNCTIONS (NAME &REST REST)
+   (CHECK-TYPE NAME SYMBOL)
+   (LET* ((NAME-STRING (SYMBOL-NAME NAME))
+          (IL-SYM (INTERN NAME-STRING 'IL))
+          (IL-SYM1 (IF (CHAR/= (ELT NAME-STRING 0)
+                              #\/)
+                       (INTERN (CONCATENATE 'STRING "/" NAME-STRING)
+                              'IL))))
+         `(PROGN (EXPORT ',IL-SYM 'IL)
+                 (DEFUN ,IL-SYM ,@REST)                      (IL:* IL:\; 
+
                                                           "Also make a version starting with a /")

+                 ,@(IF IL-SYM1
+                       `((EXPORT ',IL-SYM1 'IL)
+                         (SETF (SYMBOL-FUNCTION ',IL-SYM1)
+                               (SYMBOL-FUNCTION ',IL-SYM)))))))
+
+(XCL:DEFDEFINER IL-DEFVAR
 IL:FUNCTIONS (NAME &REST ARGS)
+   (LET ((IL-SYM (INTERN (SYMBOL-NAME NAME)
+                        *IL-PACKAGE*)))
+        `(PROGN (EXPORT ',IL-SYM 'IL)
+                (DEFVAR ,IL-SYM ,@(MAPCONVERT ARGS)))))
+
+
+
+(IL:* IL:|;;| 
+"
+; Creates an external symbol in the IL package.
+(defmacro il-defsym (name)
+    `(export (intern (symbol-name ',name) *il-package*) *il-package*))
+
+(defmacro il-import (symbol)
+  `(progn (import ,symbol 'il)
+	  (export (find-symbol (symbol-name ,symbol) 'il) 'il)))
+")

+
+
+(DEFMACRO IL-COPYCONV
 (OLDNAME NEWNAME)
+   (LET* ((OLD-SYM (FIND-SYMBOL (SYMBOL-NAME OLDNAME)
+                          *IL-PACKAGE*))
+          (NEW-SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
+                          *IL-PACKAGE*)))
+         (UNLESS OLD-SYM (ERROR "No symbol ~:@(~a~) found in IL package." OLD-SYM))
+         (UNLESS NEW-SYM (ERROR "No symbol ~:@(~a~) found in IL package." NEW-SYM))
+         `(SETF (GET ',NEW-SYM 'CONVERT-FORM)
+                #'(LAMBDA (&REST ARGS)
+                         (APPLY (GET ',OLD-SYM 'CONVERT-FORM)
+                                ARGS)))))
+
+
+
+(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")

+
+
+(XCL:DEFDEFINER IL-WARNINGFORM
 IL:FUNCTIONS (NAME &OPTIONAL (TEMPLATE '(NIL REPEAT (EVAL)))
+                                                      (WARN-SWITCH '*WARN-ON-UNTRANSLATABLE-IL-FORM*)
+                                                      )
+   (LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
+                         *IL-PACKAGE*)))
+        (IF FN-NAME
+            `(SETF (GET ',FN-NAME 'CONVERT-FORM)
+                   #'(LAMBDA (&REST REST)
+                            (DECLARE
 (SPECIAL ,WARN-SWITCH))
+                            (WHEN ,WARN-SWITCH
+                                (WARN "Unable to translate a ~a form." ',FN-NAME))
+                            (WALK-TEMPLATE (CONS ',FN-NAME REST)
+                                   ',TEMPLATE)))
+            (PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
+                   NIL))))
+
+
+
+(IL:* IL:|;;| 
+"Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1.  Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR)."
+)

+
+
+(MACROLET ((DEF-*-IF-NEEDED (NAME)
+                  (LET ((NAME-STRING (SYMBOL-NAME NAME)))
+                       `(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED")) (ARGS)
+                           (CASE (LENGTH ARGS)
+                               (0 ,(EVAL `(,NAME)))
+                               (1 (FIRST ARGS))
+                               (T `(,',NAME ,@ARGS)))))))
+       (DEF-*-IF-NEEDED PROGN)
+       (DEF-*-IF-NEEDED AND)
+       (DEF-*-IF-NEEDED OR))
+
+(DEFSTRUCT (FAKE-SYMBOL
 (:CONSTRUCTOR MAKE-FAKE-SYMBOL (NAME))
+                            (:PRINT-FUNCTION (LAMBDA (OBJ STREAM DEPTH)
+                                                    (PRINC (FAKE-SYMBOL-NAME OBJ)
+                                                           STREAM))))
+   NAME)
+
+(DEFSTRUCT (SHARP-DOT
 (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
+                                                  (WRITE-STRING "#." STREAM)
+                                                  (WRITE (SHARP-DOT-CONTENTS SELF)
+                                                         :STREAM STREAM))))
+   CONTENTS)
+
+(DEFSTRUCT (SHARP-COMMA
 (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
+                                                    (WRITE-STRING "#," STREAM)
+                                                    (WRITE (SHARP-COMMA-CONTENTS SELF)
+                                                           :STREAM STREAM))))
+   CONTENTS)
+
+
+
+(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")

+
+
+(DEFUN QUOTED-SYMBOL-P
 (X)
+   (AND (CONSP X)
+        (EQ (CAR X)
+            'QUOTE)
+        (SYMBOLP (CADR X))
+        (NULL (CDDR X))))
+
+(DEFVAR *ORIGINAL-READTABLE*
 (COPY-READTABLE NIL))
+
+(DEFUN OLD-CONVERT-FILE
 (INFILE OUTFILE)
+   (WITH-OPEN-FILE (INSTREAM INFILE)
+          (IF OUTFILE
+              (WITH-OPEN-STREAM (OUTSTREAM (COND
+                                              ((EQ OUTFILE 'T)
+                                               (MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
+                                              (T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS 
+                                                       :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
+                     (CONVERT-FILE-INTERNAL INSTREAM OUTSTREAM))
+              (CONVERT-FILE-INTERNAL INSTREAM NIL))))
+
+(EXPORT 'CONVERT-FILE)
+
+
+
+(IL:* IL:|;;| 
+"(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")"
+)

+
+
+(EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES))
+
+(DEFUN READ-EXPORTS
 (FILE)
+
+   (IL:* IL:|;;| "Read the exported-symbols file if it exists")

+
+   (WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
+          (WHEN STREAM
+              (READ STREAM)                                  (IL:* IL:\; 
+
                                                           "Read the \"(in-package)\" form")

+              (SETQ *EXPORTED-IL-SYMBOLS* (CADADR (READ STREAM))))))
+
+
+
+(IL:* IL:\; "Get the symbol list")

+
+
+(DEFUN WRITE-EXPORTS
 (FILE)
+   (WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
+          (SETQ *EXPORTED-IL-SYMBOLS* (SORT *EXPORTED-IL-SYMBOLS* #'STRING< :KEY #'SYMBOL-NAME))
+          (LET ((*PACKAGE* *IL-PACKAGE*))
+               (FORMAT STREAM "(lisp:in-package \"IL\")~%(lisp:export '(")
+               (DOLIST (SYM *EXPORTED-IL-SYMBOLS*)
+                   (FORMAT STREAM "~% ~s" SYM))
+               (FORMAT STREAM ")~%"))))
+
+(DEFUN READ-RECORD-TYPES
 (FILE)                          (IL:* IL:\; 
+
                                                          "Read the record-types file if it exists")

+   (WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
+          (WHEN STREAM (READ-HASH-TABLE *RECORD-TYPES* STREAM))))
+
+(DEFUN WRITE-RECORD-TYPES
 (FILE)
+   (WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
+          (WRITE-HASH-TABLE *RECORD-TYPES* STREAM)
+          (TERPRI STREAM)))
+
+(DEFUN READ-HASH-TABLE
 (HT STREAM &AUX ITEM)
+   (LOOP (WHEN (EQ (SETQ ITEM (READ STREAM NIL 'STOP))
+                   'STOP)
+               (RETURN))
+         (SETF (GETHASH (CAR ITEM)
+                      HT)
+               (CDR ITEM))))
+
+(DEFUN WRITE-HASH-TABLE
 (HT STREAM)
+   (LET* ((COUNT (HASH-TABLE-COUNT HT))
+          (SORTED-TABLE (MAKE-ARRAY COUNT))
+          (I 0))
+         (MAPHASH #'(LAMBDA (KEY VALUE)
+                           (SETF (SVREF SORTED-TABLE I)
+                                 (CONS KEY VALUE))
+                           (INCF I))
+                HT)
+         (SORT SORTED-TABLE #'STRING< :KEY #'(LAMBDA (X)
+                                                    (SYMBOL-NAME (CAR X))))
+         (DOTIMES (I COUNT)
+             (PPRINT (SVREF SORTED-TABLE I)
+                    STREAM))))
+
+(DEFUN CONVERT-FILE
 (FILENAME OUTFILE)
+   (LET* ((REAL-FILENAME (FIND-SYMBOL (STRING FILENAME)
+                                (FIND-PACKAGE 'IL)))
+          (COMS (SYMBOL-VALUE (OR (CAAR (GET REAL-FILENAME 'IL:FILE))
+                                  (ERROR "~a has no FILES definition." FILENAME)))))
+         (IF OUTFILE
+             (WITH-OPEN-STREAM (OUTSTREAM (COND
+                                             ((EQ OUTFILE 'T)
+                                              (MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
+                                             (T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS 
+                                                      :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
+                    (CONVERT-FILECOMS COMS REAL-FILENAME OUTSTREAM))
+             (CONVERT-FILECOMS COMS REAL-FILENAME NIL))))
+
+(DEFUN CONVERT-FILECOMS
 (COMS FILENAME &OPTIONAL OUTSTREAM)
+   (LET ((*EXPORTED-IL-SYMBOLS* NIL)
+         REORDERED-FILECOMS CONVERTED-FILE-LIST)
+        (FORMAT T "~&Processing Forms...~%")
+        (SETQ REORDERED-FILECOMS (REORDER-FILECOMS COMS)
+              CONVERTED-FILE-LIST
+              (EXPURGATE-EXTRANEOUS-PROGNS (MAPCAR 'CONVERT-ONE-FILECOM REORDERED-FILECOMS)))
+        (WHEN OUTSTREAM
+            (FORMAT T "~&Writing output...")
+            (LET* ((MFE (GET FILENAME 'IL:MAKEFILE-ENVIRONMENT))
+                   (*PACKAGE* (OR (FIND-PACKAGE (EVAL (GETF MFE :PACKAGE)))
+                                  *IL-PACKAGE*))
+                   (*PRINT-PRETTY* T)
+                   (*PRINT-CASE* :DOWNCASE))
+                  (WHEN MFE
+                      (PRINT '(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL"))
+                             OUTSTREAM))
+                  (PRINT (IF MFE
+                             (LIST 'IN-PACKAGE (GETF MFE ':PACKAGE))
+                             '(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL")))
+                         OUTSTREAM)
+                  (TERPRI OUTSTREAM)
+                  (WHEN *EXPORTED-IL-SYMBOLS*
+                      (PRINT (MAKE-EXPORT-FORM *EXPORTED-IL-SYMBOLS*)
+                             OUTSTREAM)
+                      (TERPRI OUTSTREAM))
+                  (DOLIST (FORM CONVERTED-FILE-LIST)
+                      (WHEN FORM
+                          (PRINT FORM OUTSTREAM)
+                          (TERPRI OUTSTREAM)))))))
+
+(DEFUN CONVERT-ONE-FILECOM
 (COM)
+   (UNLESS (CONSP COM)
+          (ERROR "Invalid filecom: ~s" COM))
+   (LET (
+         (IL:* IL:|;;| "We bind these for the warnings mechanism in case the filecom type is unknown...  They'll be rebound lower down.")

+
+         (*CURRENT-EXPRESSION* COM)
+         (*CURRENT-DEFINITION* (CAR COM))
+         (*CURRENT-DEFINITION-TYPE* "Filecom")
+         (*WARNINGS-MADE* NIL)
+         (CONVERTER (GET (CAR COM)
+                         'CONVERT-COM))
+
+         (IL:* IL:|;;| "FILEVARS are handled at this level, except in PROP and IFPROP coms.")

+
+         (FILEVAR-P (AND (EQ (SECOND COM)
+                             'IL:*)
+                         (NOT (MEMBER (FIRST COM)
+                                     '                       (IL:* IL:PROP IL:IFPROP)
)))))
+        (FUNCALL (OR CONVERTER 'CONVERT-UNKNOWN-COM)
+               (IF CONVERTER
+                   (IF FILEVAR-P
+                       (IL:EVAL (THIRD COM))
+                       (CDR COM))
+                   COM))))
+
+(DEFUN EXPURGATE-EXTRANEOUS-PROGNS
 (FORMS-LIST)
+   (LET (RESULT)
+        (DOLIST (FORM FORMS-LIST)
+            (SETQ RESULT (NCONC RESULT (IF (AND (CONSP FORM)
+                                                (EQ (CAR FORM)
+                                                    'PROGN))
+                                           (EXPURGATE-EXTRANEOUS-PROGNS (CDR FORM))
+                                           (CONS FORM NIL)))))
+        RESULT))
+
+(DEFUN REORDER-FILECOMS
 (COMS-LIST)
+   (LET (EARLY-LIST LATE-LIST)
+        (LABELS ((EARLY-P (COM)
+                        (AND (CONSP COM)
+                             (OR (MEMBER (CAR COM)
+                                        '(IL:CONSTANTS IL:MACROS))
+                                 (AND (MEMBER (CAR COM)
+                                             '(IL:DECLARE\:
))
+                                      (SOME #'EARLY-P (CDR COM)))))))
+               (DOLIST (COM COMS-LIST)
+                   (IF (EARLY-P COM)
+                       (PUSH COM EARLY-LIST)
+                       (PUSH COM LATE-LIST)))
+               (NCONC (NREVERSE EARLY-LIST)
+                      (NREVERSE LATE-LIST)))))
+
+(DEFUN MAKE-EXPORT-FORM
 (LIST-OF-SYMBOLS)
+   (LET (SORTED)
+        (DOLIST (S LIST-OF-SYMBOLS)
+            (LET ((A (ASSOC (SYMBOL-PACKAGE S)
+                            SORTED)))
+                 (IF A
+                     (PUSH S (CDR A))
+                     (PUSH (CONS (SYMBOL-PACKAGE S)
+                                 (LIST S))
+                           SORTED))))
+        (CONS 'PROGN (MAPCAR #'(LAMBDA (P)
+                                      `(EXPORT (MAPCAR 'INTERN ',(MAPCAR 'STRING (CDR P))
+                                                      ',(PACKAGE-NAME (CAR P)))))
+                            SORTED))))
+
+(DEFPARAMETER *WALKER-TEMPLATES*

+   '(BLOCK (NIL NIL REPEAT (EVAL))
+        CATCH
+        (NIL EVAL REPEAT (EVAL))
+        CHECK-TYPE
+        (NIL EVAL REPEAT (NIL))
+        COMPILER-LET
+        (NIL (REPEAT (NIL EVAL))
+             REPEAT
+             (EVAL))
+        DECLARE
+        (REPEAT (NIL))
+        EVAL-WHEN
+        (NIL QUOTE REPEAT (EVAL))
+        FLET
+        (NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
+             REPEAT
+             (EVAL))
+        FUNCTION
+        (NIL CALL)
+        GO
+        (NIL QUOTE)
+        IF
+        (NIL REPEAT (EVAL))
+        LABELS
+        (NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
+             REPEAT
+             (EVAL))
+        LAMBDA
+        (NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
+        LET
+        (NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
+             REPEAT
+             (EVAL))
+        LET*
+        (NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
+             REPEAT
+             (EVAL))
+        LOCALLY
+        (NIL REPEAT (EVAL))
+        MACROLET
+        (NIL (REPEAT ((NIL NIL REPEAT (EVAL))))
+             REPEAT
+             (EVAL))
+        MULTIPLE-VALUE-CALL
+        (NIL EVAL REPEAT (EVAL))
+        MULTIPLE-VALUE-LIST
+        (NIL EVAL)
+        MULTIPLE-VALUE-PROG1
+        (NIL RETURN REPEAT (EVAL))
+        MULTIPLE-VALUE-SETQ
+        (NIL (REPEAT (SET))
+             EVAL)
+        MULTIPLE-VALUE-BIND
+        (NIL BINDING-CONTOUR (REPEAT (SET))
+             REPEAT
+             (EVAL))
+        IL:NLSETQ
+        (NIL REPEAT (EVAL))
+        PROGN
+        (NIL REPEAT (EVAL))
+        PROGV
+        (NIL EVAL EVAL REPEAT (EVAL))
+        QUOTE
+        (NIL QUOTE)
+        RETURN-FROM
+        (NIL QUOTE REPEAT (RETURN))
+        SETQ
+        (NIL REPEAT (SET EVAL))
+        SETF
+        (NIL REPEAT (SET EVAL))
+        TAGBODY
+        (NIL REPEAT (EVAL))
+        THE
+        (NIL QUOTE EVAL)
+        THROW
+        (NIL EVAL EVAL)
+        UNLESS
+        (NIL REPEAT (EVAL))
+        UNWIND-PROTECT
+        (NIL RETURN REPEAT (EVAL))
+        WHEN
+        (NIL REPEAT (EVAL))
+        DO
+        (NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
+             (EVAL EVAL)
+             REPEAT
+             (EVAL))
+        DO*
+        (NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
+             (EVAL EVAL)
+             REPEAT
+             (EVAL))
+        DOLIST
+        (NIL (NIL EVAL)
+             REPEAT
+             (EVAL))
+        DOTIMES
+        (NIL (NIL EVAL)
+             REPEAT
+             (EVAL))
+        PROG
+        (NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
+             REPEAT
+             (EVAL))
+        PROG*
+        (NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
+             REPEAT
+             (EVAL))
+        COND
+        (NIL REPEAT ((TEST REPEAT (EVAL))))
+        DEFINE-SETF-METHOD
+        (NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
+        DEFUN
+        (NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
+        DEFMACRO
+        (NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
+        CASE
+        (NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
+        ECASE
+        (NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
+        TYPECASE
+        (NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
+        ETYPECASE
+        (NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
+        XCL:DEFDEFINER
+        (NIL NIL NIL NIL REPEAT (EVAL))
+        INCF
+        (NIL EVAL EVAL)
+        DECF
+        (NIL EVAL EVAL)
+        WITH-INPUT-FROM-STRING
+        (NIL (NIL EVAL REPEAT (EVAL))
+             REPEAT
+             (EVAL))
+        WITH-OUTPUT-TO-STRING
+        (NIL (NIL EVAL)
+             REPEAT
+             (EVAL))
+        WITH-OPEN-FILE
+        (NIL (NIL REPEAT (EVAL))
+             REPEAT
+             (EVAL))
+        LOOP
+        (NIL REPEAT (EVAL))
+        POP
+        (NIL EVAL)
+        PUSH
+        (NIL EVAL EVAL)
+        PUSHNEW
+        (NIL EVAL EVAL REPEAT EVAL)))
+
+(DEFUN GET-WALKER-TEMPLATE
 (FN)
+   (GETF *WALKER-TEMPLATES* FN NIL))
+
+(DEFUN WALK-FORM-INTERNAL
 (FORM &AUX NEWFORM NEWNEWFORM WALK-NO-MORE-P MACROP FN TEMPLATE)
+   (COND
+      ((ATOM FORM)
+       (WHEN (AND (SYMBOLP FORM)
+                  (NOT (NULL *CURRENT-FREE-REFERENCES*))
+                  (NOT (KEYWORDP FORM))
+                  (NOT (MEMBER FORM '(T NIL)))
+                  (NULL (ASSOC FORM *LOCALS*)))
+
+           (IL:* IL:|;;| "Almost certainly a free ref.  Note for later analysis.")

+
+           (PUSHNEW FORM *CURRENT-FREE-REFERENCES*))
+       FORM)
+      ((SETQ TEMPLATE (GET-WALKER-TEMPLATE (SETQ FN (CAR FORM))))
+       (IF (SYMBOLP TEMPLATE)
+           (FUNCALL TEMPLATE FORM)
+           (WALK-TEMPLATE FORM TEMPLATE)))
+      ((AND (SYMBOLP FN)
+            (OR (GET FN 'CONVERT-FORM)
+                (EQ (CAR (GET FN 'IL:CLISPWORD))
+                    'IL:FORWORD)))
+       (CONVERT FORM))
+      ((AND (SYMBOLP FN)
+            (MACRO-FUNCTION FN))
+       (LET ((*CURRENT-EXPRESSION* FORM))
+            (WARN "Macro form ~s not translated" FN))
+       FORM)
+      ((AND (SYMBOLP FN)
+            (NOT (FBOUNDP FN))
+            (SPECIAL-FORM-P FN))
+       (UNKNOWN-MACRO-FORM FORM))
+      (T 
+         (IL:* IL:|;;| "Otherwise, walk the form as if its just a standard ")

+
+         (IL:* IL:|;;| "functioncall using a template for standard function")

+
+         (IL:* IL:|;;| "call.")

+
+         (WALK-TEMPLATE FORM '(CALL REPEAT (EVAL))))))
+
+(DEFUN WALK-TEMPLATE
 (FORM TEMPLATE)
+   (IF (ATOM TEMPLATE)
+       (ECASE TEMPLATE
+           ((EVAL SET FUNCTION TEST EFFECT RETURN) 
+              (WHEN *WALKER-FIND-PARAMETER-LIST*
+                  (THROW 'PARAMETER-LIST NIL))
+              (WALK-FORM-INTERNAL FORM))
+           ((NIL QUOTE) FORM)
+           ((BINDING) 
+
+              (IL:* IL:|;;| "This should only appear inside (after)  a BINDING-CONTOUR...")

+
+              (WHEN (SYMBOLP FORM)
+
+                  (IL:* IL:|;;| "Perhaps this should note if FORM is declared special somehow...")

+
+                  (PUSH (CONS FORM ':LOCAL)
+                        *LOCALS*)
+                  (PUSHNEW FORM *CURRENT-LOCALS*))
+              FORM)
+           ((LAMBDA CALL) (COND
+                             ((SYMBOLP FORM)
+                              (UNLESS (NULL *CURRENT-FUNCTION-CALLS*)
+                                     (PUSHNEW FORM *CURRENT-FUNCTION-CALLS*))
+                              FORM)
+                             (T 
+                                (IL:* IL:|;;| "Have we a \"#'foo\" here?")

+
+                                (WHEN (AND (CONSP FORM)
+                                           (EQ (CAR FORM)
+                                               'FUNCTION)
+                                           (NULL (CDDR FORM))
+                                           (SYMBOLP (SECOND FORM)))
+
+                                    (IL:* IL:|;;| "Record it if we do...")

+
+                                    (PUSHNEW (SECOND FORM)
+                                           *CURRENT-FUNCTION-CALLS*))
+                                (WALK-FORM-INTERNAL FORM))))
+           ((NAME) 
+              (WHEN (NULL *CURRENT-FUNCTION-CALLS*)
+
+                  (IL:* IL:|;;| "Don't record name in a nested def, if we ever see one.")

+
+                  (SETQ *CURRENT-DEFINITION* FORM)
+                  (PUSH FORM *CURRENT-FUNCTION-CALLS*)
+                  (PUSH FORM *CURRENT-FREE-REFERENCES*))
+              FORM)
+           ((PARAMETER) (IF (SYMBOLP FORM)
+                            (WALK-TEMPLATE FORM 'BINDING)
+                            (WALK-TEMPLATE FORM '(BINDING EVAL REPEAT (BINDING)))))
+           ((PARAMETER-LIST) 
+              (WHEN *WALKER-FIND-PARAMETER-LIST*
+
+                  (IL:* IL:|;;| "Some code-analysis stuff uses this.")

+
+                  (THROW 'PARAMETER-LIST FORM))
+              (WALK-TEMPLATE FORM '(REPEAT (PARAMETER)))))
+       (CASE (CAR TEMPLATE)
+           (REPEAT (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE)
+
+                          (IL:* IL:|;;| "For the case where nothing happens")

+
+                          (IL:* IL:|;;| "after the repeat optimize out the")

+
+                          (IL:* IL:|;;| "call to length.")

+
+                          (IF (NULL (CDDR TEMPLATE))
+                              NIL
+                              (NTHCDR (- (LENGTH FORM)
+                                         (LENGTH (CDDR TEMPLATE)))
+                                     FORM))))
+           (IF (WALK-TEMPLATE FORM (IF (IF (LISTP (CADR TEMPLATE))
+                                           (EVAL (CADR TEMPLATE))
+                                           (FUNCALL (CADR TEMPLATE)
+                                                  FORM))
+                                       (CADDR TEMPLATE)
+                                       (CADDDR TEMPLATE))))
+           (BINDING-CONTOUR (LET ((*LOCALS* *LOCALS*))
+                                 (WALK-TEMPLATE FORM (CDR TEMPLATE))))
+           (REMOTE (WALK-TEMPLATE FORM (CADR TEMPLATE)))
+           (WARN 
+              (WARN (SECOND TEMPLATE))
+              (IF (NULL (CDDR TEMPLATE))
+                  FORM
+                  (WALK-TEMPLATE FORM (CDDR TEMPLATE))))
+           (OTHERWISE (COND
+                         ((ATOM FORM)
+                          FORM)
+                         (T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
+                                                (CAR TEMPLATE))
+                                   (WALK-TEMPLATE (CDR FORM)
+                                          (CDR TEMPLATE)))))))))
+
+(DEFUN WALK-TEMPLATE-HANDLE-REPEAT
 (FORM TEMPLATE STOP-FORM)
+   (IF (EQ FORM STOP-FORM)
+       (WALK-TEMPLATE FORM (CDR TEMPLATE))
+       (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
+              STOP-FORM)))
+
+(DEFUN WALK-TEMPLATE-HANDLE-REPEAT-1
 (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM)
+   (COND
+      ((NULL FORM)
+       NIL)
+      ((EQ FORM STOP-FORM)
+       (IF (NULL REPEAT-TEMPLATE)
+           (WALK-TEMPLATE STOP-FORM (CDR TEMPLATE))
+           (ERROR 
+       "While handling repeat:
+                     ~%~Ran into stop while still in repeat template.")))
+      ((NULL REPEAT-TEMPLATE)
+       (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
+              STOP-FORM))
+      (T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
+                             (CAR REPEAT-TEMPLATE))
+                (WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM)
+                       TEMPLATE
+                       (CDR REPEAT-TEMPLATE)
+                       STOP-FORM)))))
+
+(DEFUN WALK-REPEAT-EVAL
 (FORM ENV)
+   (AND FORM (RECONS FORM (WALK-FORM-INTERNAL (CAR FORM))
+                    (WALK-REPEAT-EVAL (CDR FORM)))))
+
+(DEFUN RECONS
 (X CAR CDR)
+   (IF (OR (NOT (EQ (CAR X)
+                    CAR))
+           (NOT (EQ (CDR X)
+                    CDR)))
+       (CONS CAR CDR)
+       X))
+
+(DEFUN RELIST
 (X &REST ARGS)
+   (RELIST-INTERNAL X ARGS NIL))
+
+(DEFUN RELIST*
 (X &REST ARGS)
+   (RELIST-INTERNAL X ARGS 'T))
+
+(DEFUN RELIST-INTERNAL
 (X ARGS *P)
+   (IF (NULL (CDR ARGS))
+       (IF *P
+           (CAR ARGS)
+           (LIST (CAR ARGS)))
+       (RECONS X (CAR ARGS)
+              (RELIST-INTERNAL (CDR X)
+                     (CDR ARGS)
+                     *P))))
+
+(DEFVAR *GETVALUE-TRANSLATION*
 :SLOT-VALUE)
+
+(DEFVAR *CURRENT-DEFINITION*
)
+
+(DEFVAR *CURRENT-DEFINITION-TYPE*
)
+
+(DEFVAR *CURRENT-EXPRESSION*
)
+
+(DEFVAR *CURRENT-LOCALS*
 NIL)
+
+(DEFVAR *FILE-CONTEXT*
 NIL)
+
+(DEFVAR *WALKER-FIND-PARAMETER-LIST*
 NIL)
+
+(DEFVAR *WARNINGS-MADE*
 NIL)
+
+(DEFVAR *PACKAGE-FOR-IL-SYMBOLS*
 NIL)
+
+(DEFVAR *PACKAGE-FOR-RESULT-FILE*
 "CL")
+
+(DEFVAR *PARAMETERS-ALWAYS-OPTIONAL*
 NIL)
+
+(DEFVAR *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE*
 NIL)
+
+(DEFVAR *UNKNOWN-MACRO-ACTION*
 :UM-WARN)
+
+(DEFVAR *ALWAYS-INCLUDE-PROPS*
 NIL)
+(IL:DECLARE\: IL:DONTCOPY 
+
+(IL:PUTPROPS IL:IL-CONVERT IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE "IL-CONVERT" :BASE
+                                                              10))
+
+(IL:PUTPROPS IL:IL-CONVERT IL:FILETYPE
 :COMPILE-FILE)
+)
+(IL:PUTPROPS IL:IL-CONVERT IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

lispusers/MIGRATION/IL-LOOPS

@@ -0,0 +1,420 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED "26-Jan-90 10:12:33" {DSK}/users/welch/migration/IL-LOOPS.;8
 28689  
+
+      changes to%:  (FUNCTIONS IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::GetValue IL-CONVERT::_Super)
+
+      previous date%: "25-Jan-90 14:14:46" {DSK}/users/welch/migration/IL-LOOPS.;6)
+
+
+(* "
+Copyright (c) 1989, 1990 by Savoir, Inc..  All rights reserved.
+")
+
+(PRETTYCOMPRINT IL-LOOPSCOMS)
+
+(RPAQQ IL-LOOPSCOMS
 
+       ((FUNCTIONS IL-CONVERT::@ IL-CONVERT::_ IL-CONVERT::$ IL-CONVERT::_! IL-CONVERT::_Super 
+               IL-CONVERT::_Super? IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC 
+               IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER IL-CONVERT::CONVERT-CLASSES 
+               IL-CONVERT::CONVERT-METHODS IL-CONVERT::CONVERT-ONE-CLASS 
+               IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::Class 
+               IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
+               IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER 
+               IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER IL-CONVERT::GETFROMIV-ACCESSOR-WRITER 
+               IL-CONVERT::GetValue)
+        (PROP IL-CONVERT::CONVERT-COM CLASSES METHODS)
+        (PROP IL-CONVERT::ACCESSOR-WRITER EveryFetch FFGetFromIV FFSendSelf FirstFetch GetFromIV 
+              AVSendSelf)))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::@
 (&REST IL-CONVERT::ARGS)
+                                          (LET [(IL-CONVERT::EXPANSION (Parse@ IL-CONVERT::ARGS
+                                                                              'IV]
+                                               (OR (AND IL-CONVERT::EXPANSION (IL-CONVERT:CONVERT
+                                                                               IL-CONVERT::EXPANSION)
+                                                        )
+                                                   (PROGN (CL:WARN "Unrecognizable @ form")
+                                                          IL-CONVERT::*CURRENT-EXPRESSION*))))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::_
 (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
+                                          `(,IL-CONVERT::METH ,(IL-CONVERT:CONVERT IL-CONVERT::INST)
+                                                  ,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::$
 (IL-CONVERT::NAME)
+                                          (LET ((IL-CONVERT::REC ($! IL-CONVERT::NAME)))
+                                               (CL:IF (Class? IL-CONVERT::REC)
+                                                   `[,(IL-CONVERT::MAKE-FAKE-SYMBOL "FIND-CLASS")
+                                                     ',(IL-CONVERT:CONVERT IL-CONVERT::NAME]
+                                                   (PROGN (CL:WARN 
+                                                              "$ form doesn't refer to a known class"
+                                                                 )
+                                                          IL-CONVERT::*CURRENT-EXPRESSION*))))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::_!
 (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
+                                           `(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::METH)
+                                                   ,(IL-CONVERT:CONVERT IL-CONVERT::INST)
+                                                   ,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super
 (&OPTIONAL IL-CONVERT::OBJ IL-CONVERT::SEL &REST 
+                                                      IL-CONVERT::ARGS)
+                                               (DECLARE
 (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL))
+                                               (CONS (IL-CONVERT::MAKE-FAKE-SYMBOL "CALL-NEXT-METHOD"
+                                                            )
+                                                     (IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super?
 (IL-CONVERT::OBJ IL-CONVERT::SEL &REST 
+                                                       IL-CONVERT::ARGS)
+                                                (DECLARE
 (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL)
+                                                       )
+                                                `[AND (,(IL-CONVERT::MAKE-FAKE-SYMBOL "NEXT-METHOD-P"
+                                                               ))
+                                                      (,(IL-CONVERT::MAKE-FAKE-SYMBOL 
+                                                               "CALL-NEXT-METHOD")
+                                                       ,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS])
+
+(CL:DEFUN IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
 (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ 
+                                                        IL-CONVERT::CLASS-NAME)
+   (DECLARE
 (CL:DECLARATION CL:VALUES)
+          (CL:VALUES IL-CONVERT::SLOT-SPEC &REST IL-CONVERT::AUX-DEFS))
+   (CASE IL-CONVERT::*GETVALUE-TRANSLATION*
+       (:SLOT-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
+                         (CL:WARN "Active value in SLOT-VALUE GetValue mode")
+                         IL-CONVERT::OBJ))
+       (:ACCESSOR (CASE (ClassName IL-CONVERT::OBJ)
+                      (ExplicitFnActiveValue (IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC 
+                                                    IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
+                                                    IL-CONVERT::CLASS-NAME))
+                      (CL:OTHERWISE 
+                         [LET* ((IL-CONVERT::GM (GetIt (Class IL-CONVERT::OBJ)
+                                                       'GetWrappedValue NIL 'METHOD))
+                                [IL-CONVERT::GMCLASS (CL:SECOND (GETDEF IL-CONVERT::GM 'METHODS]
+                                (IL-CONVERT::PM (GetIt (Class IL-CONVERT::OBJ)
+                                                       'PutWrappedValue NIL 'METHOD))
+                                (IL-CONVERT::PMCLASS (CL:SECOND (GETDEF IL-CONVERT::PM 'METHODS]
+                         (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
+                              (CL:WARN "Unconvertable ~a in defclass" (ClassName IL-CONVERT::OBJ)))
+                         IL-CONVERT::OBJ)))
+       (:ACTIVE-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
+                           (CL:WARN "Active value emulator not written yet")
+                           IL-CONVERT::OBJ))))
+
+(CL:DEFUN IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER
 (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR 
+                                                            IL-CONVERT::LOCALSTATE)
+   [IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)])
+
+(CL:DEFUN IL-CONVERT::CONVERT-CLASSES
 (IL-CONVERT::CS)
+   (IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::CS))
+
+(CL:DEFUN IL-CONVERT::CONVERT-METHODS
 (IL-CONVERT::MS)
+   (CONS 'PROGN (IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::MS)))
+
+(CL:DEFUN IL-CONVERT::CONVERT-ONE-CLASS
 (IL-CONVERT::C)
+   ""
+   [LET*
+    ((IL-CONVERT::SRC (_ [OR ($! IL-CONVERT::C)
+                             (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::C))
+                                  (CL:WARN "Class not found")
+                                  (CL:RETURN-FROM IL-CONVERT::CONVERT-ONE-CLASS
+                                         (LIST '* ';; (CL:FORMAT NIL "Class ~a not found." 
+                                                             IL-CONVERT::C]
+                         MakeFileSource))
+     (IL-CONVERT::CLASSNAME (IL-CONVERT:CONVERT (CL:SECOND IL-CONVERT::SRC)))
+     (IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::CLASSNAME)
+     (IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Class")
+     (IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::CLASSNAME))
+     (IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::CLASSNAME))
+     (IL-CONVERT::ATTRIBUTES (CDDR IL-CONVERT::SRC))
+     (IL-CONVERT::META (CDR (CL:ASSOC 'MetaClass IL-CONVERT::ATTRIBUTES)))
+     (IL-CONVERT::SUPERS (CDR (CL:ASSOC 'Supers IL-CONVERT::ATTRIBUTES)))
+     (IL-CONVERT::CVS (CDR (CL:ASSOC 'ClassVariables IL-CONVERT::ATTRIBUTES)))
+     (IL-CONVERT::IVS (CDR (CL:ASSOC 'InstanceVariables IL-CONVERT::ATTRIBUTES)))
+     IL-CONVERT::PROPS-ALIST IL-CONVERT::AUX-DEFS)
+    (CL:LABELS
+     ([IL-CONVERT::LOOPS-CONVERT (IL-CONVERT::X)
+             (COND
+                [(Class? IL-CONVERT::X)
+                 `(IL-CONVERT::FIND-CLASS ',(IL-CONVERT:CONVERT (_ IL-CONVERT::X ClassName)]
+                ((AnnotatedValue? IL-CONVERT::X)
+                 (IL-CONVERT::AV-CONVERT IL-CONVERT::X))
+                ((CL:CONSP IL-CONVERT::X)
+                 (CL:MAPCAR #'IL-CONVERT::LOOPS-CONVERT IL-CONVERT::X))
+                ((Instance? IL-CONVERT::X)
+                 (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::X))
+                      (CL:WARN "Unconvertable LOOPS object in defclass"))
+                 IL-CONVERT::X)
+                (T (IL-CONVERT:CONVERT IL-CONVERT::X]
+      (IL-CONVERT::AV-CONVERT (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ)
+             (CL:SETQ IL-CONVERT::OBJ (fetch
 annotatedValue of
 IL-CONVERT::OBJ))
+             (LET [(CL:VALUES (CL:MULTIPLE-VALUE-LIST (IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC 
+                                                             IL-CONVERT::NAME IL-CONVERT::DOC 
+                                                             IL-CONVERT::OBJ IL-CONVERT::CLASSNAME]
+                  (CL:SETQ IL-CONVERT::AUX-DEFS (NCONC IL-CONVERT::AUX-DEFS (CDR CL:VALUES)))
+                  (CAR CL:VALUES)))
+      (IL-CONVERT::PROCESS-IV
+       (IL-CONVERT::SPEC &OPTIONAL IL-CONVERT::ALLOC &AUX IL-CONVERT::DOC)
+       (LET* [(IL-CONVERT::NAME (IL-CONVERT:CONVERT (CL:FIRST IL-CONVERT::SPEC)))
+              (IL-CONVERT::OBJ (CL:SECOND IL-CONVERT::SPEC))
+              (IL-CONVERT::DOC (CL:GETF (CDDR IL-CONVERT::SPEC)
+                                      'doc))
+              [IL-CONVERT::CONVERSION (CL:IF (type?
 annotatedValue IL-CONVERT::OBJ)
+                                          (IL-CONVERT::AV-CONVERT IL-CONVERT::NAME IL-CONVERT::DOC 
+                                                 IL-CONVERT::OBJ)
+                                          `[,IL-CONVERT::NAME
+                                            ,@[AND (CDR IL-CONVERT::SPEC)
+                                                   `(:INITFORM ,(IL-CONVERT::LOOPS-CONVERT 
+                                                                       IL-CONVERT::OBJ]
+                                            :INITARG
+                                            ,(CL:INTERN (STRING (CL:FIRST IL-CONVERT::SPEC))
+                                                    *KEYWORD-PACKAGE*)
+                                            ,@[AND IL-CONVERT::ALLOC `(:ALLOCATION 
+                                                                             ,IL-CONVERT::ALLOC]
+                                            ,@(AND IL-CONVERT::DOC `(:DOCUMENTATION ,IL-CONVERT::DOC])
+                     ]
+              (IL-CONVERT::PROPS (CL:COPY-LIST (CL:IF IL-CONVERT::DOC
+                                                   (AND (CDDR (CDDR IL-CONVERT::SPEC))
+                                                        (CDDR IL-CONVERT::SPEC))
+                                                   (CDDR IL-CONVERT::SPEC))]
+
+             (* ;; "The following (when not quoted) fails to compile, for some reason:")

+
+             '(CL:REMF IL-CONVERT::PROPS 'doc)
+             (CL:WHEN IL-CONVERT::PROPS
+                 (CL:PUSH (CONS IL-CONVERT::NAME IL-CONVERT::PROPS)
+                        IL-CONVERT::PROPS-ALIST))
+             IL-CONVERT::CONVERSION)))
+     (LET [(IL-CONVERT::FORM `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFCLASS")
+                               ,IL-CONVERT::CLASSNAME
+                               ,(IL-CONVERT::MAPCONVERT IL-CONVERT::SUPERS)
+                               [,@(CL:REMOVE-IF 'NULL (CL:MAPCAR #'IL-CONVERT::PROCESS-IV 
+                                                             IL-CONVERT::IVS))
+                                ,@(CL:REMOVE-IF 'NULL (for
 IL-CONVERT::CV in
 IL-CONVERT::CVS
+                                                         collect
 (IL-CONVERT::PROCESS-IV 
+                                                                            IL-CONVERT::CV :CLASS)))
+                                ,@(AND (OR IL-CONVERT::PROPS-ALIST IL-CONVERT::*ALWAYS-INCLUDE-PROPS*
+                                           )
+                                       `(IL-CONVERT::.PROPS-ALIST. :INITFORM '
+                                                                              ,
+                                                                              IL-CONVERT::PROPS-ALIST
+                                               ]
+                               ,@(CL:UNLESS (EQ (CAR IL-CONVERT::META)
+                                                'Class)
+                                     [LET [(IL-CONVERT::*CURRENT-EXPRESSION* (IL-CONVERT:CONVERT
+                                                                              (CAR IL-CONVERT::META]
+                                          (CL:WARN "Metaclass might be incorrect")
+                                          `(:METACLASS ,IL-CONVERT::*CURRENT-EXPRESSION*])]
+          (CL:IF IL-CONVERT::AUX-DEFS
+              `(PROGN ,IL-CONVERT::FORM ,.IL-CONVERT::AUX-DEFS)
+              IL-CONVERT::FORM)])
+
+(CL:DEFUN IL-CONVERT::CONVERT-ONE-METHOD
 (IL-CONVERT::M)
+   (LET* ((IL-CONVERT::METHOD-BODY (\DEFINE-TYPE-GETDEF IL-CONVERT::M 'METHOD-FNS))
+          [IL-CONVERT::METHOD-CLASS (CL:FIRST (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
+          [IL-CONVERT::METHOD-SELECTOR (CL:SECOND (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
+          (IL-CONVERT::METHOD-ARGS (CDR (CL:SECOND IL-CONVERT::METHOD-BODY)))
+          (IL-CONVERT::METHOD-FNBODY (CDDR IL-CONVERT::METHOD-BODY))
+          (IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::M)
+          (IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Function")
+          (IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::M))
+          (IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::M))
+          (IL-CONVERT::*SELF-VARIABLE* (CL:FIRST IL-CONVERT::METHOD-ARGS)))
+         (DECLARE
 (CL:SPECIAL IL-CONVERT::*SELF-VARIABLE*))
+         (CL:VALUES [CL:MULTIPLE-VALUE-BIND (IL-CONVERT::NEW-VARLST IL-CONVERT::VARNAMES)
+                           (IL-CONVERT::EXPAND-VARLIST IL-CONVERT::METHOD-ARGS)
+                           [LET ((IL-CONVERT::*LOCALS* (CL:COPY-LIST IL-CONVERT::VARNAMES)))
+                                (CL:WHEN (AND (CDR IL-CONVERT::NEW-VARLST)
+                                              IL-CONVERT::*PARAMETERS-ALWAYS-OPTIONAL*)
+                                    (CL:PUSH '&OPTIONAL (CDR IL-CONVERT::NEW-VARLST)))]
+                           `(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::DEFMETHOD)
+                             ,IL-CONVERT::METHOD-SELECTOR
+                             [(,(CL:FIRST IL-CONVERT::NEW-VARLST)
+                               ,IL-CONVERT::METHOD-CLASS)
+                              ,@(CDR IL-CONVERT::NEW-VARLST)
+                              ,@(AND IL-CONVERT::*ADD-REST-ARG* '(&REST IL-CONVERT::$EXTRA-ARGS$]
+                             ,.(IL-CONVERT::MAPCONVERT IL-CONVERT::METHOD-FNBODY]
+                (CL:NREVERSE IL-CONVERT::*CURRENT-FUNCTION-CALLS*)
+                (CL:NREVERSE IL-CONVERT::*CURRENT-FREE-REFERENCES*))))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::Class
 (IL-CONVERT::X)
+                                              `(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::CLASS-OF)
+                                                ,(IL-CONVERT:CONVERT IL-CONVERT::X)))
+
+(CL:DEFUN IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER
 (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR 
+                                                            IL-CONVERT::LOCALSTATE)
+   (CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
+              (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
+       `(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE))
+       (IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE)))
+
+(CL:DEFUN IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
 (IL-CONVERT::NAME IL-CONVERT::DOC 
+                                                                    IL-CONVERT::OBJ 
+                                                                    IL-CONVERT::CLASS-NAME)
+
+   (* ;; "Old-style AVs done here.  ")

+
+   (LET* ((IL-CONVERT::LS (@ IL-CONVERT::OBJ localState))
+          (IL-CONVERT::GF (@ IL-CONVERT::OBJ getFn))
+          (IL-CONVERT::PF (@ IL-CONVERT::OBJ putFn))
+          (IL-CONVERT::CODEWRITER (GET IL-CONVERT::GF 'IL-CONVERT::ACCESSOR-WRITER))
+          IL-CONVERT::DEFS)
+
+         (* ;; " Write the accessor...")

+
+         (CL:UNLESS IL-CONVERT::CODEWRITER
+             (LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM IL-CONVERT::OBJ
+                                                           )))
+                  (CL:WARN "No accessor-writer for ~a" IL-CONVERT::GF)
+                  (CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC 
+                         IL-CONVERT::*CURRENT-EXPRESSION*)))
+         (LET* [(CL:NAMESTRING (CL:IF (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::NAME)
+                                   (IL-CONVERT::FAKE-SYMBOL-NAME IL-CONVERT::NAME)
+                                   (STRING IL-CONVERT::NAME)))
+                [IL-CONVERT::VARNAME (AND (CL:CONSP IL-CONVERT::CODEWRITER)
+                                          (CDR IL-CONVERT::CODEWRITER)
+                                          (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING 
+                                                                               "!CACHE-FOR-" 
+                                                                               CL:NAMESTRING]
+                (IL-CONVERT::CODE (CL:FUNCALL (CL:IF (CL:CONSP IL-CONVERT::CODEWRITER)
+                                                  (CAR IL-CONVERT::CODEWRITER)
+                                                  IL-CONVERT::CODEWRITER)
+                                         IL-CONVERT::VARNAME
+                                         'self IL-CONVERT::LS))
+                (IL-CONVERT::ACCESSOR (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING 
+                                                                           "!ACCESSOR-FOR-" 
+                                                                           CL:NAMESTRING]
+               (CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
+                          ,IL-CONVERT::ACCESSOR
+                          ((,(IL-CONVERT::MAKE-FAKE-SYMBOL "SELF")
+                            ,IL-CONVERT::CLASS-NAME))
+                          ,IL-CONVERT::CODE)
+                      IL-CONVERT::DEFS)
+
+               (* ;; "Look at putfn...")

+
+               (CL:UNLESS (CL:MEMBER IL-CONVERT::PF '(ReplaceMe NoUpdatePermitted))
+                   (LET [(IL-CONVERT::CODEWRITER (GET IL-CONVERT::PF 'IL-CONVERT::ACCESSOR-WRITER]
+                        (CL:UNLESS IL-CONVERT::CODEWRITER
+                            (LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM
+                                                                          IL-CONVERT::OBJ)))
+                                 (CL:WARN "No accessor-writer for ~a" IL-CONVERT::PF)
+                                 (CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC 
+                                        IL-CONVERT::*CURRENT-EXPRESSION*)))
+                        (LET ((IL-CONVERT::CODE (CL:FUNCALL IL-CONVERT::CODEWRITER 
+                                                       IL-CONVERT::VARNAME 'self IL-CONVERT::LS)))
+                             (CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
+                                        (CL:SETF ,IL-CONVERT::ACCESSOR)
+                                        ((self ,IL-CONVERT::CLASS-NAME))
+                                        ,IL-CONVERT::CODE)
+                                    IL-CONVERT::DEFS))))
+
+               (* ;; "Make slot spec...")

+
+               (CL:APPLY 'CL:VALUES                          (* ; "values-list* y'might say")

+                      [AND IL-CONVERT::VARNAME
+                           `(,IL-CONVERT::VARNAME ,@(AND (EQ IL-CONVERT::PF 'ReplaceMe)
+                                                         `(:WRITER (CL:SETF ,IL-CONVERT::ACCESSOR]
+                      IL-CONVERT::DEFS))))
+
+(CL:DEFUN IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER
 (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR 
+                                                             IL-CONVERT::LOCALSTATE)
+   `(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+        (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+        [CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+               (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE]))
+
+(CL:DEFUN IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER
 (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR 
+                                                            IL-CONVERT::LOCALSTATE)
+   `(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+        (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+        [CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+               ,(IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)]))
+
+(CL:DEFUN IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER
 (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR 
+                                                            IL-CONVERT::LOCALSTATE)
+   `(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+        (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+        (CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
+               ,(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
+                           (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
+                    `(CL:FUNCALL ,IL-CONVERT::LOCALSTATE)
+                    IL-CONVERT::LOCALSTATE))))
+
+(CL:DEFUN IL-CONVERT::GETFROMIV-ACCESSOR-WRITER
 (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR 
+                                                           IL-CONVERT::LOCALSTATE)
+   `(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE))
+
+(IL-CONVERT::IL-DEFCONV IL-CONVERT::GetValue
 (IL-CONVERT::INST &OPTIONAL IL-CONVERT::VAR 
+                                                        IL-CONVERT::PROP)
+                                                 [COND
+                                                    (IL-CONVERT::PROP (LIST (
+                                                                         IL-CONVERT::MAKE-FAKE-SYMBOL
+                                                                             "SLOT-PROP-VALUE")
+                                                                            (IL-CONVERT:CONVERT
+                                                                             IL-CONVERT::INST)
+                                                                            (IL-CONVERT:CONVERT
+                                                                             IL-CONVERT::VAR)
+                                                                            (IL-CONVERT:CONVERT
+                                                                             IL-CONVERT::PROP)))
+                                                    [IL-CONVERT::VAR
+                                                     (CL:ECASE IL-CONVERT::*GETVALUE-TRANSLATION*
+                                                         (:SLOT-VALUE (LIST 
+                                                                     IL-CONVERT::*SLOT-VALUE-FAKESYM*
+                                                                            (IL-CONVERT:CONVERT
+                                                                             IL-CONVERT::INST)
+                                                                            (IL-CONVERT:CONVERT
+                                                                             IL-CONVERT::VAR)))
+                                                         (:ACCESSOR 
+                                                            (CL:IF (AND (CL:CONSP IL-CONVERT::VAR)
+                                                                        (EQ (CAR IL-CONVERT::VAR)
+                                                                            'QUOTE))
+                                                                (LIST
+                                                                 [IL-CONVERT::MAKE-FAKE-SYMBOL
+                                                                  (CL:CONCATENATE
+                                                                   'STRING "access-"
+                                                                   (LET [(IL-CONVERT::NEWNAME
+                                                                          (IL-CONVERT:CONVERT
+                                                                           (CL:SECOND IL-CONVERT::VAR
+                                                                                  ]
+                                                                        (CL:IF (
+                                                                            IL-CONVERT::FAKE-SYMBOL-P
+                                                                                IL-CONVERT::NEWNAME)
+                                                                            (
+                                                                         IL-CONVERT::FAKE-SYMBOL-NAME
+                                                                             IL-CONVERT::NEWNAME)
+                                                                            (CL:SYMBOL-NAME 
+                                                                                  IL-CONVERT::NEWNAME
+                                                                                   ))]
+                                                                 (IL-CONVERT:CONVERT IL-CONVERT::INST
+                                                                        ))
+                                                                (PROGN (CL:WARN 
+                                                        "Unquoted IV spec in :ACCESSOR GetValue mode"
+                                                                              )
+                                                                       
+                                                                     IL-CONVERT::*CURRENT-EXPRESSION*
+                                                                       )))
+                                                         (:ACTIVE-VALUE (IL-CONVERT::MAKE-FAKE-SYMBOL
+                                                                         "ACTIVE-VALUE"
+                                                                         (IL-CONVERT:CONVERT 
+                                                                                IL-CONVERT::INST)
+                                                                         (IL-CONVERT:CONVERT 
+                                                                                IL-CONVERT::VAR))))]
+                                                    (T (IL-CONVERT:CONVERT `(GetValue self
+                                                                                   ,IL-CONVERT::INST])
+
+(PUTPROPS CLASSES IL-CONVERT::CONVERT-COM
 IL-CONVERT::CONVERT-CLASSES)
+
+(PUTPROPS METHODS IL-CONVERT::CONVERT-COM
 IL-CONVERT::CONVERT-METHODS)
+
+(PUTPROPS EveryFetch IL-CONVERT::ACCESSOR-WRITER
 IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER)
+
+(PUTPROPS FFGetFromIV IL-CONVERT::ACCESSOR-WRITER
 (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER . T))
+
+(PUTPROPS FFSendSelf IL-CONVERT::ACCESSOR-WRITER
 (IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER . T))
+
+(PUTPROPS FirstFetch IL-CONVERT::ACCESSOR-WRITER
 (IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER . T))
+
+(PUTPROPS GetFromIV IL-CONVERT::ACCESSOR-WRITER
 (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER))
+
+(PUTPROPS AVSendSelf IL-CONVERT::ACCESSOR-WRITER
 IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER)
+(PUTPROPS IL-LOOPS COPYRIGHT ("Savoir, Inc." 1989 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

lispusers/MIGRATION/IL-RECORD

@@ -0,0 +1,214 @@
+(DEFINE-FILE-INFO PACKAGE "IL-CONVERT" READTABLE "XCL")
+
(IL:FILECREATED "14-Sep-89 10:03:02" IL:|{DSK}/python2/aria/migration/interlisp/IL-RECORD.;2|
 21305  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS MAKE-RECORD-ACCESSORS |fetch| |replace| |DO-create|)
+
+      IL:|previous| IL:|date:| " 2-Mar-89 13:12:40" IL:|{DSK}/users/eweaver/convert/IL-RECORD.;4|)
+
+
+; Copyright (c) 1989 by ENVOS Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:IL-RECORDCOMS)
+
+(IL:RPAQQ IL:IL-RECORDCOMS
 ((IL:* IL:\| "chapter 8") (IL:VARIABLES *RECORD-TYPES*) (IL:FUNCTIONS ADD-EXPORTS ASSOCRECORD PROPRECORD ATOMRECORD BLOCKRECORD) (IL:FUNCTIONS ARRAYRECORD DEFINE-ARRAYRECORD-STRUCTURE) (IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)") (IL:FUNCTIONS INTERLISP-COMMENT-P) (IL:FUNCTIONS RECORD) (IL:FUNCTIONS TYPERECORD FLATTEN MAKE-RECORD-ACCESSORS DEFINE-RECORD-STRUCTURE) (IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ") (IL:* IL:|;;| "
+; this version defines a defstruct which is not really the same
+; as the IL record type.
+(defun
+  define-record-structure (record-name record-fields named record-tail)
+  (let* ((name-string (symbol-name record-name))
+	(struct-name (intern name-string))
+	(*current-record-name* record-name)
+	(slots nil))
+   (declare (special *current-record-name*))
+   (setq record-fields (make-true-list record-fields))
+   (do ((fields record-fields (rest fields))
+	field)
+       ((null fields) (setq slots (nreverse slots)))
+       (setq field (first fields))
+       (cond
+	((null field )
+	 (warn \"NIL as record field name not supported\"))
+	((atom field) (push field slots))
+	((eq (first field) '*)) ;Ignore comments
+	(t (setq slots (append (reverse (flatten field)) slots)))))
+   (setf (gethash struct-name *record-types*) slots)
+   (multiple-value-bind
+    (record-tail-forms record-tail-inits)
+    (process-record-tail record-tail)
+    (add-exports
+     `((defstruct
+	 ,struct-name
+	 (:type list)
+	 (:named ,named)
+	 ,@(mapcar
+	    #'(lambda (slot &aux pair)
+		(if (setq pair (assoc slot record-tail-inits))
+		    `(,slot ,(cdr pair))
+		  slot))
+	    slots))
+       ,@record-tail-forms)))))
+") (IL:* IL:|;;| "Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.") (IL:FUNCTIONS PROCESS-RECORD-TAIL) (IL:* IL:|;;| "Define user-created access functions.  It doesn't matter if these fields are part of the structure or not.  If so, they will redefine the access functions created by defstruct.") (IL:FUNCTIONS ACCESSFNS) (IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))") (IL:FUNCTIONS DATATYPE FIELD-TO-SLOT-TYPE /DECLAREDATATYPE FIND-RECORD-TYPE FIND-RECORD-FIELDS |fetch| |replace| TYPE? |create| |DO-create|) (IL:P (IL-COPYCONV |fetch| FETCH) (IL-COPYCONV |fetch| |ffetch|) (IL-COPYCONV |ffetch| FFETCH) (IL-COPYCONV |replace| REPLACE) (IL-COPYCONV |replace| |freplace|) (IL-COPYCONV |freplace| FREPLACE) (IL-COPYCONV TYPE? |type?|) (IL-COPYCONV |create| CREATE)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-RECORD))
+)
+
+
+
+(IL:* IL:\| "chapter 8")

+
+
+(DEFVAR *RECORD-TYPES* (MAKE-HASH-TABLE :SIZE 100))
+
+(DEFUN ADD-EXPORTS (FORMS &AUX (EXPORT-LIST NIL)) (DOLIST (FORM FORMS) (AND (CONSP FORM) (MEMBER (FIRST FORM) (QUOTE (DEFUN DEFMACRO)) :TEST (FUNCTION EQ)) (PUSH (SECOND FORM) EXPORT-LIST))) (IF EXPORT-LIST (IL:BQUOTE (PROGN (EXPORT (QUOTE (IL:\\\, (REVERSE EXPORT-LIST)))) (IL:\\\,@ FORMS))) (PROGN-IF-NEEDED FORMS)))
+
+(IL-DEFCONV ASSOCRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ASSOCRECORD not supported") (IL:* IL:|;;| "
+ (setf
+  (gethash record-name *record-types*)
+  (mapcar #'car record-fields))
+ (process-record-tail record-tail)
+"))
+
+(IL-DEFCONV PROPRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "PROPRECORD not supported") (IL:* IL:|;;| "
+ (setf
+  (gethash record-name *record-types*)
+  (do ((fields record-fields (rest (rest fields)))
+       (slots nil))
+      ((endp fields) (nreverse slots))
+      (push (first fields) slots))
+  (process-record-tail record-tail))
+"))
+
+(IL-DEFCONV ATOMRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ATOMRECORD not supported"))
+
+(IL-DEFCONV BLOCKRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-TAIL)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (WARN "BLOCKRECORD not supported") (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) (SLOTS NIL) FIELD) ((ENDP FIELDS) (SETF (GETHASH RECORD-NAME *RECORD-TYPES*) (IF (BOUNDP (QUOTE *ADD-TO-RECORD-DEFN*)) (APPEND (NREVERSE SLOTS) (GETHASH RECORD-NAME *RECORD-TYPES*)) (NREVERSE SLOTS)))) (SETQ FIELD (FIRST FIELDS)) (WHEN (CONSP FIELD) (SETQ FIELD (FIRST FIELD))) (WHEN (AND FIELD (NOT (INTEGERP FIELD))) (PUSH FIELD SLOTS))) NIL)
+
+(IL-DEFCONV ARRAYRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DEFINE-ARRAYRECORD-STRUCTURE RECORD-NAME RECORD-FIELDS RECORD-TAIL))
+
+(DEFUN DEFINE-ARRAYRECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS RECORD-TAIL) (LET ((*CURRENT-RECORD-NAME* RECORD-NAME)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (FIELD-FNS NIL) (INITS NIL) (KEYS NIL) CREATE-FN (LENGTH 0)) (DO ((I 0 (1+ I)) (FIELDS RECORD-FIELDS (REST FIELDS)) FIELD) ((ENDP FIELDS) (SETQ FIELD-FNS (NREVERSE FIELD-FNS)) (SETQ INITS (NREVERSE INITS)) (SETQ KEYS (NREVERSE KEYS))) (IL:* IL:|;;| "Define accessor functions.  We don't need to define") (IL:* IL:|;;| "setf methods because the accessors are actually") (IL:* IL:|;;| "macros which generate calls to svref, and setf") (IL:* IL:\; "already knows how to handle svref.") (SETQ FIELD (FIRST FIELDS)) (INCF LENGTH) (COND ((INTEGERP FIELD) (INCF I (1- FIELD)) (INCF LENGTH (1- FIELD))) ((NULL FIELD)) (T (PUSH (IL:BQUOTE (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME FIELD)))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (SVREF (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X))) (IL:\\\, I))))))) FIELD-FNS) (LET ((SVAR (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME FIELD) "-SET")))) (PUSH (IL:BQUOTE (WHEN (IL:\\\, SVAR) (SETF (SVREF $X$ (IL:\\\, I)) (IL:\\\, FIELD)))) INITS) (PUSH (IL:BQUOTE ((IL:\\\, FIELD) (IL:\\\, (CDR (ASSOC FIELD RECORD-TAIL-INITS))) (IL:\\\, SVAR))) KEYS))))) (SETQ CREATE-FN (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ KEYS)) (LET (($X$) (MAKE-ARRAY (IL:\\\, LENGTH))) (IL:\\\,@ INITS) $X$)))) (ADD-EXPORTS (IL:BQUOTE ((IL:\\\, CREATE-FN) (IL:\\\,@ FIELD-FNS) (IL:\\\,@ RECORD-TAIL-FORMS))))))))
+
+
+
+(IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)")

+
+
+(DEFUN INTERLISP-COMMENT-P (X) (AND (CONSP X) (EQ (FIRST X) (QUOTE *))))
+
+(IL-DEFCONV RECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) NIL (REST (REST ARGS))))
+
+(IL-DEFCONV TYPERECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) T (REST (REST ARGS))))
+
+(DEFUN FLATTEN (X) (COND ((CONSP X) (APPEND (FLATTEN (CAR X)) (FLATTEN (CDR X)))) ((NULL X) NIL) (T (CONS X NIL))))
+
+(DEFUN MAKE-RECORD-ACCESSORS (RECORD-NAME TREE PATH) (COND ((NULL TREE) NIL) ((ATOM TREE) (LET ((ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) RECORD-NAME "-" (SYMBOL-NAME TREE))))) (IL:BQUOTE ((DEFSETF (IL:\\\, ACCESSOR-NAME) (X) (VAL) (LIST (QUOTE SETF) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ)))) VAL)) (DEFMACRO (IL:\\\, ACCESSOR-NAME) (X) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ))))))))) ((EQ (CAR TREE) (QUOTE *)) NIL) (T (APPEND (MAKE-RECORD-ACCESSORS RECORD-NAME (CAR TREE) (IL:BQUOTE (CAR (IL:\\\, PATH)))) (MAKE-RECORD-ACCESSORS RECORD-NAME (CDR TREE) (IL:BQUOTE (CDR (IL:\\\, PATH))))))))
+
+(DEFUN DEFINE-RECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS NAMED RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) (SLOTS (REMOVE-IF (FUNCTION NULL) (FLATTEN RECORD-FIELDS))) (ACCESSORS (MAKE-RECORD-ACCESSORS NAME-STRING RECORD-FIELDS (IF NAMED (QUOTE (CDR T)) T)))) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (ADD-EXPORTS (IL:BQUOTE ((DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT &AUX PAIR) (IF (SETQ PAIR (ASSOC SLOT RECORD-TAIL-INITS :TEST (FUNCTION EQ))) (LIST SLOT (CDR PAIR)) SLOT))) SLOTS))) (IL:\\\, (MAKE-BQ (LET ((FORM (SUBLIS (MAPCAR (FUNCTION (LAMBDA (SLOT) (CONS SLOT (MAKE-MACRO-ARG :ELEMENT SLOT)))) SLOTS) RECORD-FIELDS))) (IF NAMED (CONS RECORD-NAME FORM) FORM))))) (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (COPY-TREE (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X)))))))) (IL:\\\,@ ACCESSORS) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
+
+
+
+(IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ")

+
+
+
+
+(IL:* IL:|;;| 
+"
+; this version defines a defstruct which is not really the same
+; as the IL record type.
+(defun
+  define-record-structure (record-name record-fields named record-tail)
+  (let* ((name-string (symbol-name record-name))
+	(struct-name (intern name-string))
+	(*current-record-name* record-name)
+	(slots nil))
+   (declare (special *current-record-name*))
+   (setq record-fields (make-true-list record-fields))
+   (do ((fields record-fields (rest fields))
+	field)
+       ((null fields) (setq slots (nreverse slots)))
+       (setq field (first fields))
+       (cond
+	((null field )
+	 (warn \"NIL as record field name not supported\"))
+	((atom field) (push field slots))
+	((eq (first field) '*)) ;Ignore comments
+	(t (setq slots (append (reverse (flatten field)) slots)))))
+   (setf (gethash struct-name *record-types*) slots)
+   (multiple-value-bind
+    (record-tail-forms record-tail-inits)
+    (process-record-tail record-tail)
+    (add-exports
+     `((defstruct
+	 ,struct-name
+	 (:type list)
+	 (:named ,named)
+	 ,@(mapcar
+	    #'(lambda (slot &aux pair)
+		(if (setq pair (assoc slot record-tail-inits))
+		    `(,slot ,(cdr pair))
+		  slot))
+	    slots))
+       ,@record-tail-forms)))))
+")

+
+
+
+
+(IL:* IL:|;;| 
+"Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.")

+
+
+(DEFUN PROCESS-RECORD-TAIL (RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((SPECS RECORD-TAIL (REST SPECS)) SPEC (FORMS NIL) (INITS NIL)) ((ENDP SPECS) (VALUES FORMS (REVERSE INITS))) (COND ((AND (ATOM (FIRST SPECS)) (REST SPECS) (EQ (SECOND SPECS) (QUOTE IL:_))) (IF (EQ *CURRENT-RECORD-NAME* (FIRST SPECS)) (WARN "implicit CREATE record spec (by assignment to record name) not supported") (PUSH (CONS (FIRST SPECS) (CONVERT (THIRD SPECS))) INITS)) (IL:* IL:|;;| "A \"field-name _ form\" spec is not a list -- it is") (IL:* IL:|;;| "three separate entries in the record-tail.") (POP SPECS) (POP SPECS)) (T (IL:* IL:\; "All others are lists.") (SETQ SPEC (FIRST SPECS)) (CASE (FIRST SPEC) ((IL:CREATE IL:INIT IL:SUBRECORD IL:SYSTEM) (WARN "~:@(~s~) record spec not supported" (FIRST SPEC))) (IL:TYPE? (PUSH (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME *CURRENT-RECORD-NAME*) "-P"))) (DATUM) (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (IL:\\\,@ (MAPCONVERT (REST SPEC)))))) FORMS)) ((IL:ACCESSFNS IL:BLOCKRECORD) (LET ((*ADD-TO-RECORD-DEFN* T)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (SETQ FORMS (APPEND FORMS (LIST (CONVERT SPEC)))))) (T (WARN "unknown record spec  ~s ignored" SPEC)))))))
+
+
+
+(IL:* IL:|;;| 
+"Define user-created access functions.  It doesn't matter if these fields are part of the structure or not.  If so, they will redefine the access functions created by defstruct."
+)

+
+
+(IL-DEFCONV ACCESSFNS (RECORD-NAME &OPTIONAL RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DECLARE (SPECIAL *LOCALS*)) (IL:* IL:|;;| "The manual says the record name is the first argument, but it appears that sometimes it is missing when this is a subdeclaration, so we get it from a special variable which is set while processing the main declaration.") (UNLESS (ATOM RECORD-NAME) (SETQ RECORD-FIELDS RECORD-NAME RECORD-NAME *CURRENT-RECORD-NAME*)) (WHEN) (DO ((FORMS NIL) FIELD FIELD-NAME ACCESSOR-NAME (FIELDS (IF (AND (= (LENGTH RECORD-FIELDS) 2) (ATOM (FIRST RECORD-FIELDS))) (IL:* IL:|;;| "Pidgin single accessfn declaration...") (LIST RECORD-FIELDS) RECORD-FIELDS) (REST FIELDS))) ((ENDP FIELDS) (ADD-EXPORTS (REVERSE FORMS))) (SETQ FIELD (FIRST FIELDS)) (SETQ FIELD-NAME (POP FIELD)) (SETQ ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:* IL:\; "Define the accessor function") (WHEN FIELD (IL:* IL:|;;| "Also remember that we know about this field") (PUSH FIELD-NAME (GETHASH RECORD-NAME *RECORD-TYPES*)) (PUSH (IL:BQUOTE (DEFUN (IL:\\\, ACCESSOR-NAME) (DATUM) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (CONVERT (POP FIELD)))))) FORMS) (IL:* IL:\; "Define the function to set a new value") (WHEN FIELD (PUSH (IL:BQUOTE (DEFSETF (IL:\\\, ACCESSOR-NAME) (DATUM) (NEWVALUE) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE NEWVALUE) :LOCAL (ACONS (QUOTE DATUM) :LOCAL *LOCALS*)))) (CONVERT (POP FIELD)))))) FORMS)))))
+
+
+
+(IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))")

+
+
+(IL-DEFCONV DATATYPE (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) RECORD-TAIL-FORMS RECORD-TAIL-INITS (SLOTS NIL) (SLOT-DEFNS NIL) (FIELD-TYPES NIL)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) SLOT-NAME FIELD-TYPE FIELD) ((ENDP FIELDS) (SETQ SLOTS (NREVERSE SLOTS))) (SETQ FIELD (FIRST FIELDS)) (SETQ SLOT-NAME (COND ((CONSP FIELD) (CASE (FIRST FIELD) ((NIL) (IL:* IL:|;;| "Some code has field specs like \"(nil 5 word))\"") (WARN "record spec ~s ignored -- NIL not allowed as field name" FIELD) NIL) (IL:* NIL) (IL:* IL:\; "Ignore comments") (T (SETQ FIELD-TYPE (REST FIELD)) (FIRST FIELD)))) (T (SETQ FIELD-TYPE NIL) FIELD))) (WHEN SLOT-NAME (PUSH SLOT-NAME SLOTS) (PUSH FIELD-TYPE FIELD-TYPES))) (IL:* IL:|;;| "Have to set the field names defined here before calling") (IL:* IL:|;;| "process-record-tail since it will add to them.") (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-SETQ (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL)) (IL:* IL:|;;| "This could be changed to a mapcar.  Previous definitions of il-defconv") (IL:* IL:|;;| "for some reason did not correctly handle lambda's.") (DO ((SLOTS SLOTS (REST SLOTS)) (FIELD-TYPES FIELD-TYPES (REST FIELD-TYPES)) SLOT-NAME FIELD-TYPE) ((ENDP SLOTS) (SETQ SLOT-DEFNS (NREVERSE SLOT-DEFNS))) (SETQ SLOT-NAME (FIRST SLOTS) FIELD-TYPE (FIRST FIELD-TYPES)) (PUSH (IL:BQUOTE ((IL:\\\, SLOT-NAME) (IL:\\\, (CDR (ASSOC SLOT-NAME RECORD-TAIL-INITS))) :TYPE (IL:\\\, (FIELD-TO-SLOT-TYPE FIELD-TYPE SLOT-NAME)))) SLOT-DEFNS)) (LET ((NAME-STRING (SYMBOL-NAME STRUCT-NAME))) (PROGN-IF-NEEDED (IL:BQUOTE ((EXPORT (QUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-P"))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT) (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME SLOT))))) SLOTS))))) (DEFSTRUCT (IL:\\\, STRUCT-NAME) (IL:\\\,@ SLOT-DEFNS)) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
+
+(DEFUN FIELD-TO-SLOT-TYPE (TYPE &OPTIONAL SLOT-NAME) (IF (NULL TYPE) T (CASE (FIRST TYPE) (INTEGER (QUOTE INTEGER)) ((IL:FIXP IL:SIGNEDWORD) (QUOTE FIXNUM)) ((IL:FLOATING IL:FLOATP) (QUOTE FLOAT)) (IL:FLAG (QUOTE (OR NIL T))) (IL:BITS (IF (<= (1- (EXPT 2 (SECOND TYPE))) MOST-POSITIVE-FIXNUM) (QUOTE FIXNUM) (QUOTE INTEGER))) (BYTE (QUOTE FIXNUM)) (IL:WORD (QUOTE FIXNUM)) ((IL:POINTER IL:XPOINTER IL:FULLPOINTER IL:FULLXPOINTER) T) (T (WARN "Unknown type spec ~:@(~a~)~:[~; for slot ~:*~:@(~a~)~]" (FIRST TYPE) SLOT-NAME) T))))
+
+(IL-DEFCONV /DECLAREDATATYPE (&REST ARGS) (WARN "/DECLAREDATATYPE ignored") NIL)
+
+(DEFUN FIND-RECORD-TYPE (FIELDNAME) (LET ((RECORD-TYPES NIL)) (MAPHASH (FUNCTION (LAMBDA (RECORD-NAME FIELDS) (WHEN (MEMBER FIELDNAME FIELDS :TEST (FUNCTION EQ)) (PUSH RECORD-NAME RECORD-TYPES)))) *RECORD-TYPES*) (CASE (LENGTH RECORD-TYPES) (0 (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELDNAME FIELDNAME) (QUOTE XXXXX)) (1 (CAR RECORD-TYPES)) (T (CERROR "use ~a" "~*multiple record types have a field named ~s: ~s" (CAR RECORD-TYPES) FIELDNAME RECORD-TYPES) (CAR RECORD-TYPES)))))
+
+(DEFUN FIND-RECORD-FIELDS (RECORD-TYPE) (MULTIPLE-VALUE-BIND (RECORD FOUND) (GETHASH RECORD-TYPE *RECORD-TYPES*) (IF FOUND RECORD (PROGN (WARN "no record type ~a, initializations may not be done" RECORD-TYPE) NIL))))
+
+(IL-DEFCONV |fetch| (FIELD-NAME OF &OPTIONAL X &AUX RECORD-TYPE) (DECLARE (SPECIAL IL:USERRECLST)) (WHEN (NOT (STRING-EQUAL OF "of")) (SETQ X OF)) (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/RECFIELDLOOK IL:USERRECLST FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X)))))
+
+(IL-DEFCONV |replace| (FIELD-NAME OF X WITH Y &AUX RECORD-TYPE) (COND ((NOT (STRING-EQUAL OF "OF")) (CERROR "Skip this form" "Missing |of| in |replace|") *CURRENT-FORM*) ((NOT (STRING-EQUAL WITH "WITH")) (CERROR "Skip this form" "Missing |with| in |replace|") *CURRENT-FORM*) (T (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/ACCESSDEF FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE (SETF ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X))) (IL:\\\, (CONVERT Y)))))))
+
+(IL-DEFCONV TYPE? (RECORD-NAME FORM) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-P"))) (IL:\\\, (CONVERT FORM)))))
+
+(IL-DEFCONV |create| (RECORD-NAME &REST ASSIGNMENTS) (|DO-create| RECORD-NAME ASSIGNMENTS))
+
+(DEFUN |DO-create| (RECORD-NAME ASSIGNMENTS) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (INITS NIL) (SMASHING NIL) (USING NIL) (VAR (MAKE-FAKE-SYMBOL (STRING (GENSYM "G"))))) (DO ((ASSIGNMENTS ASSIGNMENTS (REST ASSIGNMENTS))) ((ENDP ASSIGNMENTS) (SETQ INITS (REVERSE INITS))) (COND ((AND (CONSP (FIRST ASSIGNMENTS)) (STRING-EQUAL (CAAR ASSIGNMENTS) (QUOTE "*")))) ((AND (SYMBOLP (SECOND ASSIGNMENTS)) (STRING-EQUAL (SECOND ASSIGNMENTS) "_")) (PUSH (CONS (FIRST ASSIGNMENTS) (CONVERT (THIRD ASSIGNMENTS))) INITS) (SETQ ASSIGNMENTS (CDDR ASSIGNMENTS))) (T (CASE (FIRST ASSIGNMENTS) ((IL:USING IL:|using|) (SETQ USING (CONVERT (SECOND ASSIGNMENTS)))) ((IL:COPYING IL:|copying|) (WARN "COPYING assignment not supported")) ((IL:REUSING IL:|reusing|) (WARN "REUSING assignment not supported")) ((IL:SMASHING IL:|smashing|) (SETQ SMASHING (CONVERT (SECOND ASSIGNMENTS)))) (T (WARN "unknown assignment ~s" (FIRST ASSIGNMENTS)))) (POP ASSIGNMENTS)))) (COND (USING (IL:BQUOTE (LET (((IL:\\\, VAR) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, USING)))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR)))) (SMASHING (IF INITS (IL:BQUOTE (LET (((IL:\\\, VAR) (IL:\\\, SMASHING))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR))) SMASHING)) (T (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (IL:BQUOTE ((IL:\\\, (INTERN (STRING (CAR INIT)) (QUOTE KEYWORD))) (IL:\\\, (CDR INIT)))))) INITS))))))))
+
+(IL-COPYCONV |fetch| FETCH)
+
+(IL-COPYCONV |fetch| |ffetch|)
+
+(IL-COPYCONV |ffetch| FFETCH)
+
+(IL-COPYCONV |replace| REPLACE)
+
+(IL-COPYCONV |replace| |freplace|)
+
+(IL-COPYCONV |freplace| FREPLACE)
+
+(IL-COPYCONV TYPE? |type?|)
+
+(IL-COPYCONV |create| CREATE)
+
+(IL:PUTPROPS IL:IL-RECORD IL:MAKEFILE-ENVIRONMENT
 (:PACKAGE "IL-CONVERT" :READTABLE "XCL"))
+(IL:PUTPROPS IL:IL-RECORD IL:COPYRIGHT ("ENVOS Corporation" 1989))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

lispusers/MIGRATION/IL-STARTUP

@@ -0,0 +1,90 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE "IL-CONVERT") 
+*PACKAGE*) BASE 10)
+
(IL:FILECREATED "14-Sep-89 10:01:13" IL:|{DSK}/python2/aria/migration/interlisp/IL-STARTUP.;2|
 6548   
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS NOTE-EXPORTED-SYMBOL CONVERT)
+
+      IL:|previous| IL:|date:| " 7-Jul-89 16:55:06" IL:|{DSK}/users/eweaver/convert/IL-STARTUP.;17|
+)
+
+
+; Copyright (c) 1989 by ENVOS Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:IL-STARTUPCOMS)
+
+(IL:RPAQQ IL:IL-STARTUPCOMS
 ((IL:* IL:|;;;| "This should be loaded before any other files.") (EVAL-WHEN (LOAD COMPILE EVAL) (IL:VARIABLES *IL-PACKAGE*)) (IL:VARIABLES *IL-SIM-PACKAGE*) (IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ") (IL:STRUCTURES BQ MACRO-ARG) (IL:* IL:|;;;| "") (IL:VARIABLES *CURRENT-CONVERT-FORM* *CURRENT-CONVERT-FUNCTION* *GLOBALS* *LOCALS* *FUNCTION-CALLS* *CURRENT-FUNCTION-CALLS* *CURRENT-FREE-REFERENCES* *EXPORTED-IL-SYMBOLS*) (IL:P (EXPORT (QUOTE CONVERT))) (IL:FUNCTIONS CONVERT MAPCONVERT EXTERN NOTE-EXPORTED-SYMBOL) (IL:FUNCTIONS TRUE-LIST-P) (IL:* IL:\; "true if this is nil or a true list") (IL:* IL:|;;| "make a true list out of a pseudo-list  (make-true-list '(A B . C)) => (A B C)") (IL:FUNCTIONS MAKE-TRUE-LIST) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-STARTUP))
+)
+
+
+
+(IL:* IL:|;;;| "This should be loaded before any other files.")

+
+(EVAL-WHEN (LOAD COMPILE EVAL)
+
+(DEFVAR *IL-PACKAGE* (FIND-PACKAGE "INTERLISP"))
+)
+
+(DEFVAR *IL-SIM-PACKAGE* (MAKE-PACKAGE "IL-SIM" :USE NIL))
+
+
+
+(IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ")

+
+
+(DEFSTRUCT (BQ (:TYPE LIST) (:CONSTRUCTOR MAKE-BQ (ELEMENT))) (BQFLAG (QUOTE IL:BQUOTE)) ELEMENT)
+
+(DEFSTRUCT (MACRO-ARG (:TYPE LIST) (:CONSTRUCTOR MAKE-MACRO-ARG (&KEY ELEMENT APPEND-P (FLAG (IF APPEND-P (QUOTE IL:\\\,@) (QUOTE IL:\\\,)))))) FLAG ELEMENT)
+
+
+
+(IL:* IL:|;;;| "")

+
+
+(DEFVAR *CURRENT-CONVERT-FORM*)
+
+(DEFVAR *CURRENT-CONVERT-FUNCTION*)
+
+(DEFVAR *GLOBALS* NIL)
+
+(DEFVAR *LOCALS* NIL)
+
+(DEFVAR *FUNCTION-CALLS* NIL)
+
+(DEFVAR *CURRENT-FUNCTION-CALLS* NIL)
+
+(DEFVAR *CURRENT-FREE-REFERENCES* NIL)
+
+(DEFVAR *EXPORTED-IL-SYMBOLS* NIL)
+
+(EXPORT (QUOTE CONVERT))
+
+(DEFUN CONVERT (FORM &AUX FN VAR) (IL:BLOCK) (LET ((*CURRENT-EXPRESSION* FORM)) (COND (IL:* IL:|;;| "Forms in which the car is a symbol...") ((AND (CONSP FORM) (ATOM (FIRST FORM))) (COND ((NOT (TRUE-LIST-P FORM)) (LET ((TAIL (CDR (LAST FORM)))) (IL:* IL:|;;| "dotted lists ending in a macro arg are okay.") (IF (AND (SYMBOLP TAIL) (EQ (CDR (ASSOC TAIL *LOCALS*)) :MACRO-ARG)) (LET ((MARG (MAKE-MACRO-ARG :ELEMENT TAIL)) (VAL (COPY-LIST FORM))) (SETF (CDR (LAST VAL)) MARG) VAL) (PROGN (WARN "~s not a list, left as is" FORM) FORM)))) ((LET ((FOO (GET (CAR FORM) (QUOTE IL:CLISPWORD)))) (AND (CONSP FOO) (EQ (CAR FOO) (QUOTE IL:FORWORD)) (NOT (EQ (CAR FORM) (QUOTE DECLARE))))) (CONVERT-ITERATION-STATEMENT (CAR FORM) (CDR FORM))) ((SETQ FN (GET (FIRST FORM) (QUOTE CONVERT-FORM))) (SETQ *CURRENT-CONVERT-FORM* FORM *CURRENT-CONVERT-FUNCTION* FN) (APPLY FN (REST FORM))) ((OR (MACRO-FUNCTION (FIRST FORM)) (SPECIAL-FORM-P (FIRST FORM))) (IL:* IL:|;;| "Use CL code walker for this") (WALK-FORM-INTERNAL FORM)) ((EQ (CHAR (STRING (FIRST FORM)) 0) #\\) (WARN "Untranslatable function ~a" (STRING (FIRST FORM))) FORM) (T (IL:* IL:|;;| "(setq fn (first form) (extern (symbol-name (first form)) *il-package*))") (WHEN *CURRENT-FUNCTION-CALLS* (PUSHNEW FN *CURRENT-FUNCTION-CALLS*)) (NOTE-EXPORTED-SYMBOL (FIRST FORM)) (CONS (FIRST FORM) (MAPCAR (QUOTE CONVERT) (REST FORM)))))) (IL:* IL:|;;| "Forms in which the car is a Lambda...") ((AND (CONSP FORM) (IL:* IL:|;;| "But car is cons") (SYMBOLP (CAAR FORM)) (STRING-EQUAL (CAAR FORM) "LAMBDA")) (CONS (CONVERT (CAR FORM)) (MAPCONVERT (CDR FORM)))) (IL:* IL:|;;| "Other non-atomic forms...") ((CONSP FORM) (WARN "Unknown kind of form ~s, not converted." FORM) FORM) (IL:* IL:|;;| "Atomic forms...") ((NULL FORM) NIL) ((EQ FORM T) T) ((KEYWORDP FORM) FORM) ((SYMBOLP FORM) (IF (SETQ VAR (ASSOC FORM *LOCALS*)) (CASE (CDR VAR) (:LOCAL (CAR VAR)) (:MACRO-ARG (MAKE-MACRO-ARG :ELEMENT (CAR VAR))) (T (ERROR "unexpected value ~s in *LOCALS*" VAR))) (PROGN (NOTE-EXPORTED-SYMBOL FORM) (WHEN *CURRENT-FREE-REFERENCES* (PUSHNEW FORM *CURRENT-FREE-REFERENCES*)) FORM))) (T FORM))))
+
+(DEFUN MAPCONVERT (FORM-OR-FORMS) (IF (ATOM FORM-OR-FORMS) (CONVERT FORM-OR-FORMS) (DO* ((TAIL FORM-OR-FORMS (CDR TAIL)) (SUBFORM (IF (CONSP TAIL) (CAR TAIL) TAIL) (IF (CONSP TAIL) (CAR TAIL) TAIL)) RESULT) ((ATOM TAIL) (IF (NULL TAIL) (NREVERSE RESULT) (PROGN (SETF (CDR (LAST (SETQ RESULT (NREVERSE RESULT)))) (CONVERT TAIL)) RESULT))) (PUSH (CONVERT SUBFORM) RESULT))))
+
+(DEFUN EXTERN (STRING &OPTIONAL (PACKAGE *PACKAGE*)) (IL:* (LET ((SYM (INTERN STRING PACKAGE))) (EXPORT SYM PACKAGE) (IF (EQ PACKAGE *IL-PACKAGE*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*)) SYM)) (ERROR "Old leftover call to EXTERN!"))
+
+(DEFUN NOTE-EXPORTED-SYMBOL (SYM &AUX PKG PKGNM) "" (WHEN (NULL (SETQ PKG (SYMBOL-PACKAGE SYM))) (RETURN-FROM NOTE-EXPORTED-SYMBOL SYM)) (WHEN (AND (EQ PKG IL:*INTERLISP-PACKAGE*) (NOT (EQ (FIND-SYMBOL (SYMBOL-NAME SYM) IL:*LISP-PACKAGE*) SYM)) (OR *WARN-FOR-ALL-IL-SYMBOLS* (< (IL:\\LOLOC SYM) (IL:\\LOLOC *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS*)))) (LET ((*CURRENT-EXPRESSION* SYM)) (WARN "Use of IL symbol ~a" SYM))) (WHEN (OR (EQ PKG IL:*INTERLISP-PACKAGE*) (AND (NOT (OR (EQ PKG IL:*KEYWORD-PACKAGE*) (EQ PKG IL:*LISP-PACKAGE*))) (MULTIPLE-VALUE-BIND (IGNORE TYPE) (FIND-SYMBOL (SYMBOL-NAME SYM) PKG) (EQ TYPE :EXTERNAL)))) (IF (NULL *FILE-CONTEXT*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*) (PUSHNEW SYM (FILE-CONTEXT-EXPORTED-SYMS *FILE-CONTEXT*)))) SYM)
+
+(DEFUN TRUE-LIST-P (PSEUDO-LIST) (DO ((PL PSEUDO-LIST (CDR PL))) ((NULL PL) T) (IF (ATOM PL) (RETURN NIL))))
+
+
+
+(IL:* IL:\; "true if this is nil or a true list")

+
+
+
+
+(IL:* IL:|;;| "make a true list out of a pseudo-list  (make-true-list '(A B . C)) => (A B C)")

+
+
+(DEFUN MAKE-TRUE-LIST (PSEUDO-LIST) (COND ((TRUE-LIST-P PSEUDO-LIST) PSEUDO-LIST) (T (DO ((TRUE-LIST NIL)) ((ATOM PSEUDO-LIST) (NREVERSE (CONS PSEUDO-LIST TRUE-LIST))) (IF (ENDP PSEUDO-LIST) (RETURN (NREVERSE TRUE-LIST))) (PUSH (POP PSEUDO-LIST) TRUE-LIST)))))
+
+(IL:PUTPROPS IL:IL-STARTUP IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (IN-PACKAGE "IL-CONVERT") *PACKAGE*) :BASE 10)
+)
+
+(IL:PUTPROPS IL:IL-STARTUP IL:FILETYPE
 :COMPILE-FILE)
+(IL:PUTPROPS IL:IL-STARTUP IL:COPYRIGHT ("ENVOS Corporation" 1989))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

lispusers/MIGRATION/MIGRATION-TOOL

@@ -0,0 +1,25 @@
+(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")
+
(IL:FILECREATED "26-Jan-90 10:27:59" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;2|
 1091   
+
+      IL:|changes| IL:|to:|  (IL:FILES IL:IL-CONVERT)
+
+      IL:|previous| IL:|date:| "11-Aug-89 16:19:28" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;1|
+)
+
+
+; Copyright (c) 1989, 1990 by ENVOS Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:MIGRATION-TOOLCOMS)
+
+(IL:RPAQQ IL:MIGRATION-TOOLCOMS
 ((IL:PROP IL:MAKEFILE-ENVIRONMENT IL:MIGRATION-TOOL)
+                                     (IL:FILES IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD 
+                                            IL:TRANSLATOR-ASSISTANT)))
+
+(IL:PUTPROPS IL:MIGRATION-TOOL IL:MAKEFILE-ENVIRONMENT
 (:PACKAGE (XCL:DEFPACKAGE "IL-CONVERT")
+                                                                  :READTABLE "XCL"))
+
+(IL:FILESLOAD IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD IL:TRANSLATOR-ASSISTANT)
+(IL:PUTPROPS IL:MIGRATION-TOOL IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

lispusers/MIGRATION/MIGRATION-TOOL.LCOM

@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")

lispusers/MIGRATION/TABLEBROWSERDECLS

@@ -0,0 +1,35 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED "27-Jan-88 17:04:01" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;5
 5052   
+
+      changes to%:  (RECORDS TABLEBROWSER)
+
+      previous date%: "18-Oct-85 18:10:50" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;2)
+
+
+(* "
+Copyright (c) 1985, 1988 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS)
+
+(RPAQQ TABLEBROWSERDECLSCOMS
 ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN)))
+(DECLARE%: EVAL@COMPILE
+
+(DATATYPE TABLEBROWSER
 ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; "True if creator set explicit item height or baseline") (NIL 6 FLAG) (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; "Number of lines occupied by each item, normally 1 (dunno if any other values work)") (TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item.  If none selected, is > TB#ITEMS") (TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item.  If none selected, is 0") (TBITEMHEIGHT WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; "Pointer to the display window.  Need to snap this link when browser is closed") (TBLOCK POINTER) (* ; "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; "Window's extent, updated as items are added, deleted, or printfn prints farther to right") (TBUPDATEFROMHERE POINTER) (* ; "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; "Y position of the top of the first item") (TBTAILHINT POINTER) (* ; "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))
+)
+
+(DATATYPE TABLEITEM
 ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))
+)
+)
+(/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER))) (QUOTE 48))
+(/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)) (QUOTE ((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 (FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 0 POINTER) (TABLEITEM 2 (BITS . 15)) (TABLEITEM 3 (BITS . 15)))) (QUOTE 4))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ TB.LEFT.MARGIN
 8)
+
+(CONSTANTS TB.LEFT.MARGIN)
+)
+(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Xerox Corporation" 1985 1988))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

lispusers/MODERNIZE

@@ -1,92 +1,95 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
-
(FILECREATED " 8-Jul-2021 23:33:42" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;16
 23978  
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-      changes to%:  (FNS MODERNWINDOW)
+
(FILECREATED "16-Oct-2021 15:42:11" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;41
 30305  
 
-      previous date%: " 3-Jul-2021 10:32:03" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;15)
+      changes to%:  (FNS MODERNIZED.TB.BUTTONEVENTFN)
+
+      previous date%: "16-Oct-2021 15:29:38" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;40)
 
 
 (PRETTYCOMPRINT MODERNIZECOMS)
 
 (RPAQQ MODERNIZECOMS

        [
-        (* ;; "Externals")

+        (* ;; "Externals")

 
-        (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP)
+        (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP 
+                   \MODERNIZED.FREEMENU.BUTTONEVENTFN)
               (INITVARS (MODERN-WINDOW-MARGIN 25)))
         
-        (* ;; "Internals")

+        (* ;; "Internals")

 
         [COMS (FNS MODERNWINDOW.BUTTONEVENTFN NEARTOP NEARESTCORNER INCORNER.REGION)
               
-              (* ;; "Behavior for some known window creators")

+              (* ;; "Behavior for some known window creators")

 
               (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE MODERN-MENUBUTTONFN)
+              (FNS \MODERNIZED.FREEMENU.BUTTONEVENTFN MODERNIZED.TB.BUTTONEVENTFN)
               
-              (* ;; "Add some Meta commands")

+              (* ;; "Add some Meta commands")

 
-              (FNS TEDIT.MODERNIZE TEDIT.SELECTALL)
+              (FNS TEDIT.MODERNIZE \MODERNIZED.TEDIT.BUTTONEVENTFN TEDIT.SELECTALL)
               (DECLARE%: DONTEVAL@LOAD DOCOPY (P 
-                                                 (* ;; "Tedit")

+                                                 (* ;; "Tedit")

 
-                                                 (MODERNWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)
                                                  (TEDIT.MODERNIZE)
                                                  
-                                                 (* ;; "Inspector")

+                                                 (* ;; "Inspector")

 
                                                  (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER)
                                                  
 
-                                 (* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")

+                                 (* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")

 
                                                  (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN))
                                                  (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
                                                  
-                                                 (* ;; "Freemenu")

+                                                 (* ;; "File browser")

 
-                                                 (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN)
+                                                 (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN 
+                                                        '\MODERNIZED.FREEMENU.BUTTONEVENTFN)
                                                  
-                                                 (* ;; "SEDIT")

+                                                 (* ;; "SEDIT")

 
                                                  (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)
                                                  
-                                                 (* ;; "Debugger")

+                                                 (* ;; "Debugger")

 
                                                  (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT)
                                                  
-                                                 (* ;; "Snap")

+                                                 (* ;; "Snap")

 
                                                  (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW)
                                                  
-                                                 (* ;; "New execs")

+                                                 (* ;; "New execs")

 
                                                  (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC)
                                                  
-                                                 (* ;; "Existing exec of the load")

+                                                 (* ;; "Existing exec of the load")

 
                                                  (MODERNWINDOW (PROCESSPROP (TTY.PROCESS)
                                                                       'WINDOW))
                                                  
-                                                 (* ;; "Table browser (for filebrowser)")

+                                                 (* ;; "Table browser  and filebrowser)")

 
-                                                 (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN)
+                                                 (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN 
+                                                        'MODERNIZED.TB.BUTTONEVENTFN)
                                                  
-                                                 (* ;; "Grapher")

+                                                 (* ;; "Grapher")

 
                                                  (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE)
                                                  
-                                                 (* ;; "Sketch")

+                                                 (* ;; "Sketch")

 
                                                  (MODERNWINDOW.SETUP 'WB.BUTTON.HANDLER)
                                                  
-                                                 (* ;; "Promptwindow")

+                                                 (* ;; "Promptwindow")

 
                                                  (MODERNWINDOW PROMPTWINDOW T)
                                                  
-                                                 (* ;; 
-
                                               "Menus:  Move only and only with title clicks")

+                                                 (* ;; "Menus:  Move only with title clicks")

 
                                                  (MODERNWINDOW.SETUP 'MENUBUTTONFN 
                                                         'MODERN-MENUBUTTONFN]
@@ -191,6 +194,17 @@
                                   PKGNAME))
          (CL:WHEN (GETD RENAMEDORIG)
                 (MOVD RENAMEDORIG ORIGFN])
+
+(\MODERNIZED.FREEMENU.BUTTONEVENTFN

+  [LAMBDA (W STREAM)
                                    (* ; "Edited 13-Oct-2021 15:15 by rmk:")

+
+    (* ;; "If a free menu is attached to another window, we don't want the corners of the free menu that abut another window to be hot-spots for moving or reshaping.  In fact, if the menu window has a main window, use the main window's  region as the cornerregion")

+
+    (MODERNWINDOW.BUTTONEVENTFN
 W (FUNCTION MODERN-ORIG-\FM.BUTTONEVENTFN)
+           NIL NIL (WINDOWPROP (CENTRALWINDOW W)
+                          'REGION)
+           (WINDOWPROP (CENTRALWINDOW W)
+                  'TITLE])
 )
 
 (RPAQ? MODERN-WINDOW-MARGIN
 25)
@@ -202,39 +216,67 @@
 (DEFINEQ
 
 (MODERNWINDOW.BUTTONEVENTFN

-  [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION)
(* ; "Edited 24-Jun-2021 14:49 by rmk:")

-    (IF
 (AND (MOUSESTATE (ONLY LEFT))
-                 (EQ LASTKEYBOARD 0))
-        THEN
 (TOTOPW WINDOW)
-              (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION))
-                          (ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW]
+  [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE TITLEPROPORTION CORNERREGION TOPMARGIN)

+                                                            (* ; "Edited 16-Oct-2021 15:25 by rmk:")

 
-                   (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window.  The TOPMARGIN should be 0 in that case.")

+    (* ;; "WINDOW is the window  that received the click and that should be passed through to the original function, if we don't pick it off here.")

 
-                   (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")

+    (* ;; "However, that window may be an auxiliary window (an attached menu? or a lower split-pane in Tedit) whose region and title intuitively should not be used to control shaping and moving behavior.  That behavior is determined by the CORNERREGION and TITLED parameters.")

 
-                   (SETQ TOPMARGIN (IF
 (WINDOWPROP WINDOW 'TOPMARGIN)
-                                     ELSEIF
 (WINDOWPROP WINDOW 'TITLE)
-                                       THEN
 (FONTPROP WindowTitleDisplayStream 'HEIGHT)
-                                     ELSE
 MODERN-WINDOW-MARGIN))
-                   (SETQ CORNER (INCORNER.REGION
 MAINREGION TOPMARGIN))
-                   (IF
 CORNER
-                       THEN
 
+    (* ;; "If CORNERREGION is given, we know that there are two windows in play.  In that case also  TOPMARGIN  tells us the hotband at the top of the cornerregion where the move/shaping click is recognized, T to mean that it has an ordinary title bar. .")

 
-                             (* ;; 
-
       "The upper corners may be in the title bar, near the side, so test corners before titlebar.")

+    (* ;; "For windows without a top margin, the shape/move region is MODERN-WINDOW-MARGIN points below the top, in the clipping region of the window. ")

 
-                             (* ;; "We are in the corner of the main window, so we are reshaping.  But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")

+    (* ;; "Not sure about using MODERN-WINDOW-MARGIN for the top region of an untitle window.  Maybe it should be 2 times the border width in that case, and the MODERN-WINDOW-MARGIN separately defines the rectangle that constitutes a corner.")

 
-                             (* ;; "WINDOWREGION includes the attached windows")

+    (LET (CORNER ATTACHEDREGION)
+         (IF
 CORNERREGION
+             THEN
 
 
-                             (LET ((LEFT (FETCH
 LEFT OF
 ATTACHEDREGION))
-                                   (RIGHT (FETCH
 RIGHT OF
 ATTACHEDREGION))
-                                   (TOP (FETCH
 TOP OF
 ATTACHEDREGION))
-                                   (BOTTOM (FETCH
 BOTTOM OF
 ATTACHEDREGION))
+                   (* ;; "Caller tells us whether the corner window has a title.")

+
+                   (CL:UNLESS (FIXP TOPMARGIN)
+                       (SETQ TOPMARGIN (if
 TOPMARGIN
+                                           then
 (FONTPROP WindowTitleDisplayStream 'HEIGHT)
+                                         else
 MODERN-WINDOW-MARGIN)))
+           ELSE
 (SETQ CORNERREGION (WINDOWPROP WINDOW 'REGION)) 
+                                                             (* ; "WINDOW is the corner window")

+                 (SETQ TOPMARGIN (if
 (WINDOWPROP WINDOW 'TOPMARGIN)
+                                   elseif
 (WINDOWPROP WINDOW 'TITLE)
+                                     then
 (FONTPROP WindowTitleDisplayStream 'HEIGHT)
+                                   else
 MODERN-WINDOW-MARGIN)))
+         (if
 (AND (MOUSESTATE (ONLY LEFT))
+                      (EQ LASTKEYBOARD 0)
+                      (INSIDE? CORNERREGION LASTMOUSEX LASTMOUSEY))
+             then
 
+
+                   (* ;; "INSIDE? check because we may be called by a click in WINDOW that is outside the corner region, we just pass it through.")

+
+                   (TOTOPW WINDOW)
+                   (SETQ ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW))) 
+
+                   (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window.  The TOPMARGIN should be 0 in that case.")

+
+                   (* ;; "This is particularly the case of FILEBROWSER windows, where the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")

+
+                   (SETQ CORNER (INCORNER.REGION
 CORNERREGION TOPMARGIN))
+                   (if
 CORNER
+                       then
 
+
+                             (* ;; 
+
       "The upper corners may be in the title bar, near the side, so test corners before titlebar.")

+
+                             (* ;; "We are in the corner of the main window, so we are reshaping.  But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")

+
+                             (* ;; "WINDOWREGION includes the attached windows")

+
+                             (LET ((LEFT (fetch
 (REGION LEFT) of
 ATTACHEDREGION))
+                                   (RIGHT (fetch
 (REGION RIGHT) of
 ATTACHEDREGION))
+                                   (TOP (fetch
 (REGION TOP) of
 ATTACHEDREGION))
+                                   (BOTTOM (fetch
 (REGION BOTTOM) of
 ATTACHEDREGION))
                                    STARTINGREGION)
 
-                                 (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")

+                                 (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")

 
                                   (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
                                       [SETQ STARTINGREGION
@@ -253,35 +295,32 @@
                                                            (GETMOUSESTATE)
                                                            (LIST RIGHT BOTTOM LEFT TOP))
                                                   (SHOULDNT])
-                                  (SHAPEW (CL:IF (MEMB 'SHAPEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS))
-                                              (WINDOWPROP WINDOW 'MAINWINDOW)
-                                              WINDOW)
+                                  (SHAPEW (CENTRALWINDOW WINDOW)
                                          STARTINGREGION))
                              T
-                     ELSEIF
 (OR ANYWHERE (NEARTOP
 MAINREGION TOPMARGIN TITLEPROPORTION))
-                       THEN
 (NEARESTCORNER
 ATTACHEDREGION)
-                             (MOVEW (CL:IF (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS))
-                                        (WINDOWPROP WINDOW 'MAINWINDOW)
-                                        WINDOW))
+                     elseif
 (OR ANYWHERE (NEARTOP
 CORNERREGION TOPMARGIN TITLEPROPORTION))
+                       then
 (NEARESTCORNER
 ATTACHEDREGION)
+                             (MOVEW (CENTRALWINDOW WINDOW))
                              T
-                     ELSEIF
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 
+                     elseif
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 
                                                                            'PREMODERN-BUTTONEVENTFN]
-                       THEN
 (APPLY* ORIGFUNCTION WINDOW)))
-      ELSEIF
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN]
-        THEN
 (APPLY* ORIGFUNCTION WINDOW])
+                       then
 (APPLY* ORIGFUNCTION WINDOW))
+           elseif
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 
+                                                                 'PREMODERN-BUTTONEVENTFN]
+             then
 (APPLY* ORIGFUNCTION WINDOW])
 
 (NEARTOP

-  [LAMBDA (MAINREGION TOPMARGIN TITLEPROPORTION)
        (* ; "Edited 24-Jun-2021 14:51 by rmk:")

+  [LAMBDA (CORNERREGION TOPMARGIN TITLEPROPORTION)
      (* ; "Edited 13-Oct-2021 21:28 by rmk:")

 
-    (* ;; "True if the MOUSEY is near the top of MAINREGION.  That means in the title bar for titled windows, otherwise a short distance below the top of the window.  (Could be in the border?)")

+    (* ;; "True if the MOUSEY is near the top of CORNERREGION.  That means in the title bar for titled windows, otherwise a short distance below the top of the window.  (Could be in the border?)")

 
-    (* ;; "If TITLEPROPORTION is N, then the click must be within that proportion of the window-width from either edge. ")

+    (* ;; "If TITLEPROPORTION is N, then the click must be within that proportion of the window-width from either edge. ")

 
-    (AND (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH
 TOP OF
 MAINREGION)
+    (AND (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH
 TOP OF
 CORNERREGION)
                                       TOPMARGIN))
          (OR (NOT TITLEPROPORTION)
-             (LET ((WIDTH (FETCH
 WIDTH of
 MAINREGION))
-                   (LEFT (FETCH
 LEFT OF
 MAINREGION)))
+             (LET ((WIDTH (FETCH
 WIDTH of
 CORNERREGION))
+                   (LEFT (FETCH
 LEFT OF
 CORNERREGION)))
                   (OR (ILESSP LASTMOUSEX (IPLUS LEFT (TIMES WIDTH TITLEPROPORTION)))
                       (IGREATERP LASTMOUSEX (IPLUS LEFT (TIMES WIDTH (DIFFERENCE 1 TITLEPROPORTION])
 
@@ -303,25 +342,25 @@
                (FETCH
 TOP OF
 REGION))])
 
 (INCORNER.REGION

-  [LAMBDA (MAINREGION TOPMARGIN)
                        (* ; "Edited 22-Feb-2021 16:27 by rmk:")

+  [LAMBDA (CORNERREGION TOPMARGIN)
                      (* ; "Edited 13-Oct-2021 15:04 by rmk:")

 
-    (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.")

+    (* ;; "CORNERREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.")

 
-    (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ")

+    (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ")

 
-    (IF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 LEFT OF
 MAINREGION)))
+    (IF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 LEFT OF
 CORNERREGION)))
                   MODERN-WINDOW-MARGIN)
-        THEN
 (IF
 (NEARTOP
 MAINREGION TOPMARGIN)
+        THEN
 (IF
 (NEARTOP
 CORNERREGION TOPMARGIN)
                      THEN
 'LEFTTOP
                    ELSEIF
 (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH
 BOTTOM
-                                                                              OF
 MAINREGION)))
+                                                                              OF
 CORNERREGION)))
                      THEN
 'LEFTBOTTOM)
-      ELSEIF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 RIGHT OF
 MAINREGION)))
+      ELSEIF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 RIGHT OF
 CORNERREGION)))
                        MODERN-WINDOW-MARGIN)
-        THEN
 (IF
 (NEARTOP
 MAINREGION TOPMARGIN)
+        THEN
 (IF
 (NEARTOP
 CORNERREGION TOPMARGIN)
                      THEN
 'RIGHTTOP
                    ELSEIF
 (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH
 BOTTOM
-                                                                              OF
 MAINREGION)))
+                                                                              OF
 CORNERREGION)))
                      THEN
 'RIGHTBOTTOM])
 )
 
@@ -383,6 +422,44 @@
              THEN
 (MOVEW WINDOW)
            ELSE
 (MODERN-ORIG-MENUBUTTONFN WINDOW])
 )
+(DEFINEQ
+
+(\MODERNIZED.FREEMENU.BUTTONEVENTFN

+  [LAMBDA (W STREAM)
                                    (* ; "Edited 13-Oct-2021 15:15 by rmk:")

+
+    (* ;; "If a free menu is attached to another window, we don't want the corners of the free menu that abut another window to be hot-spots for moving or reshaping.  In fact, if the menu window has a main window, use the main window's  region as the cornerregion")

+
+    (MODERNWINDOW.BUTTONEVENTFN
 W (FUNCTION MODERN-ORIG-\FM.BUTTONEVENTFN)
+           NIL NIL (WINDOWPROP (CENTRALWINDOW W)
+                          'REGION)
+           (WINDOWPROP (CENTRALWINDOW W)
+                  'TITLE])
+
+(MODERNIZED.TB.BUTTONEVENTFN

+  [LAMBDA (W STREAM)
                                    (* ; "Edited 16-Oct-2021 15:40 by rmk:")

+
+    (* ;; "If a free menu is attached to another window, we don't want the corners of the free menu that abut another window to be hot-spots for moving or reshaping.  In fact, if the menu window has a main window, use the main window's  region as the cornerregion")

+
+    (LET ((CW (CENTRALWINDOW W))
+          CORNERREG TOPMARGIN)
+         (CL:WHEN (WINDOWPROP CW 'FILEBROWSER)
+             [SETQ CORNERREG (UNIONREGIONS (WINDOWPROP (FB.GETWINDOW CW 'HEADING)
+                                                  'REGION)
+                                    (WINDOWPROP (FB.GETWINDOW CW 'COUNTER)
+                                           'REGION)
+                                    (WINDOWPROP (FB.GETWINDOW CW 'BROWSER)
+                                           'REGION]
+             [SETQ TOPMARGIN (IPLUS (FETCH
 (REGION HEIGHT) OF
 (WINDOWPROP (FB.GETWINDOW
+                                                                                   CW
+                                                                                   'HEADING)
+                                                                             'REGION))
+                                    (FETCH
 (REGION HEIGHT) OF
 (WINDOWPROP (FB.GETWINDOW
+                                                                                   CW
+                                                                                   'COUNTER)
+                                                                             'REGION])
+         (MODERNWINDOW.BUTTONEVENTFN
 W (FUNCTION MODERN-ORIG-TB.BUTTONEVENTFN)
+                NIL NIL CORNERREG TOPMARGIN])
+)
 
 
 
@@ -391,10 +468,12 @@
 (DEFINEQ
 
 (TEDIT.MODERNIZE

-  [LAMBDA NIL
                                           (* ; "Edited 24-Jun-2021 20:54 by rmk:")

+  [LAMBDA NIL
                                           (* ; "Edited 11-Oct-2021 15:02 by rmk:")

+    (MODERNWINDOW.SETUP
 (FUNCTION \TEDIT.BUTTONEVENTFN)
+           (FUNCTION \MODERNIZED.TEDIT.BUTTONEVENTFN))
     (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
 
-        (* ;; "All")

+        (* ;; "All")

 
         (TEDIT.SETFUNCTION (CHARCODE "Meta,a")
                (FUNCTION TEDIT.SELECTALL)
@@ -403,7 +482,7 @@
                (FUNCTION TEDIT.SELECTALL)
                TEDIT.READTABLE)
 
-        (* ;; "Quit")

+        (* ;; "Quit")

 
         (TEDIT.SETFUNCTION (CHARCODE "Meta,q")
                (FUNCTION TEDIT.QUIT)
@@ -412,6 +491,21 @@
                (FUNCTION TEDIT.QUIT)
                TEDIT.READTABLE))])
 
+(\MODERNIZED.TEDIT.BUTTONEVENTFN

+  [LAMBDA (W STREAM)
                                    (* ; "Edited 13-Oct-2021 21:43 by rmk:")

+
+    (* ;; "If a TEDIT window has been split, we have to make sure that movement happens only for clicks at the top of the main window and at the bottom of the bottom-most split window.  Clicks near the split lines must be ignored.  Essentially, the %"region%" of the Tedit window is the union of the regions of all of its split-panes.")

+
+    (* ;; "We pass the pain that received the click, because that's what the original \TEDIT.BUTTONEVENTFN needs to see, if we decide not to shape or move.")

+
+    (MODERNWINDOW.BUTTONEVENTFN
 W (FUNCTION MODERN-ORIG-\TEDIT.BUTTONEVENTFN)
+           NIL NIL [APPLY (FUNCTION UNIONREGIONS)
+                          (bind
 PANE _ (CENTRALWINDOW W) collect
 (WINDOWPROP PANE
+                                                                                'REGION)
+                             repeatwhile
 (SETQ PANE (WINDOWPROP PANE 'TEDIT-NEXT-PANE-DOWN]
+           (WINDOWPROP (CENTRALWINDOW W)
+                  'TITLE])
+
 (TEDIT.SELECTALL

   [LAMBDA (STREAM TEXTOBJ SEL)
                          (* ; "Edited  3-May-2020 17:29 by rmk:")

     (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS]
@@ -422,91 +516,89 @@
 (DECLARE%: DONTEVAL@LOAD DOCOPY 
 
 
-(* ;; "Tedit")

+(* ;; "Tedit")

 
 
-(MODERNWINDOW.SETUP
 '\TEDIT.BUTTONEVENTFN)
-
 (TEDIT.MODERNIZE
)
 
 
-(* ;; "Inspector")

+(* ;; "Inspector")

 
 
 (MODERNWINDOW.SETUP
 '\ITEM.WINDOW.BUTTON.HANDLER)
 
 
-(* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")

+(* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")

 
 
-                                                             (* (MODERNWINDOW.SETUP
-
                                                           (QUOTE ONEDINSPECT.BUTTONEVENTFN)))

+                                                             (* (MODERNWINDOW.SETUP
+
                                                           (QUOTE ONEDINSPECT.BUTTONEVENTFN)))

 
 (MODERNWINDOW.SETUP
 'ICMLARRAY.TITLECOMMANDFN)
 
 
-(* ;; "Freemenu")

+(* ;; "File browser")

 
 
-(MODERNWINDOW.SETUP
 '\FM.BUTTONEVENTFN)
+(MODERNWINDOW.SETUP
 '\FM.BUTTONEVENTFN '\MODERNIZED.FREEMENU.BUTTONEVENTFN)
 
 
-(* ;; "SEDIT")

+(* ;; "SEDIT")

 
 
 (MODERNWINDOW.SETUP
 'SEDIT::BUTTONEVENTFN)
 
 
-(* ;; "Debugger")

+(* ;; "Debugger")

 
 
 (MODERNWINDOW.SETUP
 'DBG::DEBUGGER-BUTTON-EVENT)
 
 
-(* ;; "Snap")

+(* ;; "Snap")

 
 
 (MODERNWINDOW.SETUP
 'SNAPW 'MODERN-SNAPW)
 
 
-(* ;; "New execs")

+(* ;; "New execs")

 
 
 (MODERNWINDOW.SETUP
 'ADD-EXEC 'MODERN-ADD-EXEC)
 
 
-(* ;; "Existing exec of the load")

+(* ;; "Existing exec of the load")

 
 
 (MODERNWINDOW
 (PROCESSPROP (TTY.PROCESS)
                          'WINDOW))
 
 
-(* ;; "Table browser (for filebrowser)")

+(* ;; "Table browser  and filebrowser)")

 
 
-(MODERNWINDOW.SETUP
 'TB.BUTTONEVENTFN)
+(MODERNWINDOW.SETUP
 'TB.BUTTONEVENTFN 'MODERNIZED.TB.BUTTONEVENTFN)
 
 
-(* ;; "Grapher")

+(* ;; "Grapher")

 
 
 (MODERNWINDOW.SETUP
 'APPLYTOSELECTEDNODE)
 
 
-(* ;; "Sketch")

+(* ;; "Sketch")

 
 
 (MODERNWINDOW.SETUP
 'WB.BUTTON.HANDLER)
 
 
-(* ;; "Promptwindow")

+(* ;; "Promptwindow")

 
 
 (MODERNWINDOW
 PROMPTWINDOW T)
 
 
-(* ;; "Menus:  Move only and only with title clicks")

+(* ;; "Menus:  Move only with title clicks")

 
 
 (MODERNWINDOW.SETUP
 'MENUBUTTONFN 'MODERN-MENUBUTTONFN)
@@ -520,10 +612,12 @@
 (ADDTOVAR LAMA
 MODERN-ADD-EXEC)
 )
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (4933 10561 (MODERNWINDOW 4943 . 6398) (MODERNWINDOW.SETUP 6400 . 9349) (UNMODERNWINDOW 
-9351 . 9745) (MODERNWINDOW.UNSETUP 9747 . 10559)) (10626 18766 (MODERNWINDOW.BUTTONEVENTFN 10636 . 
-15663) (NEARTOP 15665 . 16585) (NEARESTCORNER 16587 . 17466) (INCORNER.REGION 17468 . 18764)) (18824 
-21146 (MODERN-ADD-EXEC 18834 . 19265) (MODERN-SNAPW 19267 . 19810) (TOTOPW.MODERNIZE 19812 . 20240) (
-MODERN-MENUBUTTONFN 20242 . 21144)) (21187 22227 (TEDIT.MODERNIZE 21197 . 21896) (TEDIT.SELECTALL 
-21898 . 22225)))))
+  (FILEMAP (NIL (5135 11412 (MODERNWINDOW 5145 . 6600) (MODERNWINDOW.SETUP 6602 . 9551) (UNMODERNWINDOW 
+9553 . 9947) (MODERNWINDOW.UNSETUP 9949 . 10761) (\MODERNIZED.FREEMENU.BUTTONEVENTFN 10763 . 11410)) (
+11477 21412 (MODERNWINDOW.BUTTONEVENTFN 11487 . 18287) (NEARTOP 18289 . 19217) (NEARESTCORNER 19219 . 
+20098) (INCORNER.REGION 20100 . 21410)) (21470 23792 (MODERN-ADD-EXEC 21480 . 21911) (MODERN-SNAPW 
+21913 . 22456) (TOTOPW.MODERNIZE 22458 . 22886) (MODERN-MENUBUTTONFN 22888 . 23790)) (23793 26222 (
+\MODERNIZED.FREEMENU.BUTTONEVENTFN 23803 . 24450) (MODERNIZED.TB.BUTTONEVENTFN 24452 . 26220)) (26263 
+28542 (TEDIT.MODERNIZE 26273 . 27087) (\MODERNIZED.TEDIT.BUTTONEVENTFN 27089 . 28211) (TEDIT.SELECTALL
+ 28213 . 28540)))))
 STOP

lispusers/MODERNIZE.TXT

@@ -30,7 +30,7 @@ When the package is loaded, this behavior is installed for the following kinds o
 
 The function MODERNWINDOW.SETUP establishes the new behavior for classes of windows:
 
-(MODERNWINDOW.SETUP ORIGFN MODERNWINDOWFN ANYWHERE)
+(MODERNWINDOW.SETUP ORIGFN MODERNWINDOWFN ANYWHERE TITLEPROPORTION)
 
 ORIGFN is either the name of the BUTTONEVENTFN for a class of windows (e.g. \TEDIT.BUTTONEVENTFN for Tedit windows) or it is a function that creates windows of a particulate kind (e.g. SNAPW or ADD-EXEC).
 
@@ -60,7 +60,7 @@ Provided these capabilities are already loaded, the following window classes are
 
 If it is not known or it is inconvenient to systematically upgrade a button function or a window-creation function, the new behavior can be provided after a particular window has been created, by invoking
 
-(MODERNWINDOW WINDOW ANYWHERE)
+(MODERNWINDOW WINDOW ANYWHERE TITLEPROPORTION)
 
 This saves the windows existing BUTTONEVENTFN as a window property PREMODERN-BUTTONEVENTFN, and installs a simple stub function in its place.
 
@@ -70,7 +70,9 @@ If things go awry:
 
 (UNMODERNWINDOW WINDOW) restores a modernized window (via MACWINDOW) to its original state.
 
-Known issue:  Clicking at the bottom-right corner of Tedit windows sometimes doesn't catch the new behavior--there seems to be a conflict with Tedit's window-splitting conventions. Clicking a little further into the window seems more reliable.
+Known issues:  
+
+Clicking at the bottom of an EXEC window running TTYIN is effective only when the input line is empty.
 
 
 

lispusers/PLAINTEXTSTREAM

@@ -1,282 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-
(FILECREATED "15-Jan-98 09:49:00" {DSK}<project>medley2.0>lispusers>PLAINTEXTSTREAM.;48
 16624  
-
-      changes to%:  (FNS WRITEPLAINTEXTPAGE PLAINTEXTOUTCHARFN OPENPLAINTEXTSTREAM CLEARPLAINTEXTPAGE
-                         MAKEPLAINTEXTPAGE)
-                    (MACROS PLAINTEXTPARAM)
-                    (VARS PLAINTEXTSTREAMCOMS)
-                    (RECORDS PLAINTEXTIMAGEDATA)
-
-      previous date%: "11-Jan-98 23:04:10" {DSK}<project>medley2.0>lispusers>PLAINTEXTSTREAM.;29)
-
-
-(* ; "
-Copyright (c) 1998 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT PLAINTEXTSTREAMCOMS)
-
-(RPAQQ PLAINTEXTSTREAMCOMS

-       [(ADDVARS (DEFAULTFILETYPELIST (PLAINTEXT . TEXT)
-                        (PT . TEXT)))
-        (FNS OPENPLAINTEXTSTREAM PLAINTEXTOUTCHARFN PLAINTEXT.TEDIT PLAINTEXT.TEXT)
-        (FNS WRITEPLAINTEXTPAGE)
-        (MACROS PLAINTEXTPARAM)
-        (RECORDS PLAINTEXTIMAGEDATA)
-        [ADDVARS [PRINTFILETYPES (PLAINTEXT (EXTENSION (PT PLAINTEXT]
-               (IMAGESTREAMTYPES (PLAINTEXT (OPENSTREAM OPENPLAINTEXTSTREAM)
-                                        (FONTCREATE \CREATEDISPLAYFONT)
-                                        (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)
-                                        (CREATECHARSET \CREATECHARSET.DISPLAY]
-        (DECLARE%: EVAL@COMPILE DONTCOPY (P [OR (RECLOOK 'STREAM)
-                                                (EVAL (SYSRECLOOK1 'STREAM]
-                                            (OR (RECLOOK 'IMAGEOPS)
-                                                (EVAL (SYSRECLOOK1 'IMAGEOPS])
-
-(ADDTOVAR DEFAULTFILETYPELIST
 (PLAINTEXT . TEXT)
-                                  (PT . TEXT))
-(DEFINEQ
-
-(OPENPLAINTEXTSTREAM

-  [LAMBDA (FILE OPTIONS)
                                 (* ; "Edited 15-Jan-98 00:04 by rmk:")

-
-    (* ;; "Assert that scale is one, so that display fonts etc. can be used.")

-
-    (LET [(STREAM (OPENSTREAM FILE 'OUTPUT NIL '((SEQUENTIAL T]
-         (REPLACE
 (STREAM OUTCHARFN) OF
 STREAM WITH
 (FUNCTION PLAINTEXTOUTCHARFN))
-         [REPLACE
 (STREAM IMAGEDATA) OF
 STREAM
-            WITH
 (CREATE
 PLAINTEXTIMAGEDATA
-                            PTPAGE _ (CL:MAKE-ARRAY (ADD1 (TIMES 72 11))
-                                            :INITIAL-ELEMENT NIL)
-                            PTXPOSITION _ 0
-                            PTYPOSITION _ (TIMES 72 11)
-                            PTRIGHTMARGIN _ (FIX (TIMES 8.5 72))
-                            PTLEFTMARGIN _ 0
-                            PTCLIPPINGREGION _ (CREATE
 REGION
-                                                      LEFT _ 0
-                                                      BOTTOM _ 0
-                                                      WIDTH _ (FIX (TIMES 8.5 72))
-                                                      HEIGHT _ (TIMES 72 11]
-         [REPLACE
 (STREAM IMAGEOPS) OF
 STREAM
-            WITH
 (CREATE
 IMAGEOPS USING
 (FETCH
 (STREAM IMAGEOPS) OF
 STREAM)
-                                                IMAGETYPE _ 'PLAINTEXT IMFONT _
-                                                [FUNCTION (LAMBDA (STREAM FONT)
-                                                            (CL:WHEN FONT
-                                                                [PLAINTEXTPARAM
-                                                                 PTLINEFEED
-                                                                 (IMINUS (FONTPROP FONT 'HEIGHT])
-                                                            (PLAINTEXTPARAM PTFONT FONT]
-                                                IMCLIPPINGREGION _
-                                                [FUNCTION (LAMBDA (STREAM REGION)
-                                                            (CL:WHEN (AND REGION
-                                                                          (NOT (TYPE?
 REGION 
-                                                                                      REGION)))
-                                                                   (\ILLEGAL.ARG REGION))
-                                                            (PLAINTEXTPARAM PTCLIPPINGREGION REGION]
-                                                IMXPOSITION _ [FUNCTION (LAMBDA (STREAM POS)
-                                                                          (PLAINTEXTPARAM PTXPOSITION
-                                                                                 POS T]
-                                                IMYPOSITION _ [FUNCTION (LAMBDA (STREAM POS)
-                                                                          (PLAINTEXTPARAM PTYPOSITION
-                                                                                 POS T]
-                                                IMMOVETO _ [FUNCTION (LAMBDA (STREAM X Y)
-                                                                       (PLAINTEXTPARAM PTXPOSITION X
-                                                                              T)
-                                                                       (PLAINTEXTPARAM PTYPOSITION Y
-                                                                              T]
-                                                IMLEFTMARGIN _ [FUNCTION (LAMBDA (STREAM M)
-                                                                           (PLAINTEXTPARAM 
-                                                                                  PTLEFTMARGIN M T]
-                                                IMRIGHTMARGIN _ [FUNCTION (LAMBDA (STREAM M)
-                                                                            (PLAINTEXTPARAM 
-                                                                                   PTRIGHTMARGIN M T]
-                                                IMLINEFEED _ [FUNCTION (LAMBDA (STREAM DY)
-                                                                         (PLAINTEXTPARAM PTLINEFEED 
-                                                                                DY T]
-                                                IMSPACEFACTOR _ [FUNCTION (LAMBDA NIL 1]
-                                                IMFONTCREATE _ 'DISPLAY IMSTRINGWIDTH _
-                                                [FUNCTION (LAMBDA (STREAM STR RDTBL)
-                                                            (STRINGWIDTH STR
-                                                                   (FETCH
 PTFONT
-                                                                      OF
 (FETCH
 (STREAM
-                                                                                         IMAGEDATA)
-                                                                                OF
 STREAM))
-                                                                   RDTBL RDTBL]
-                                                IMCHARWIDTH _ [FUNCTION (LAMBDA (STREAM CHARCODE)
-                                                                          (CHARWIDTH
-                                                                           CHARCODE
-                                                                           (FETCH
 PTFONT
-                                                                              OF

-                                                                              (FETCH
 (STREAM
-                                                                                          IMAGEDATA)
-                                                                                 OF
 STREAM]
-                                                IMCLOSEFN _ (FUNCTION WRITEPLAINTEXTPAGE)
-                                                IMCHARSET _ [FUNCTION (LAMBDA (STREAM CHARSET)
-
-                                 (* ;; "If we had another illegal character set value, then we could simply fix it so that the character set didn't match anything, which would cause the character set shift to be put out on the next character")

-
-                                                                        (COND
-                                                                           ((\IOMODEP STREAM
-                                                                                   'OUTPUT T)
-                                                                            (\BOUT STREAM 
-                                                                                   NSCHARSETSHIFT)
-                                                                            (COND
-                                                                               ((EQ CHARSET T)
-                                                                                (\BOUT STREAM 
-                                                                                       NSCHARSETSHIFT
-                                                                                       )
-                                                                                (\BOUT STREAM 0))
-                                                                               (T (\BOUT STREAM 
-                                                                                         CHARSET]
-                                                IMDRAWPOLYGON _ (FUNCTION NILL)
-                                                IMDRAWPOINT _ (FUNCTION NILL)
-                                                IMSCALE _ (FUNCTION (LAMBDA NIL 1]
-         (DSPFONT '(GACHA 10)
-                STREAM)
-         STREAM])
-
-(PLAINTEXTOUTCHARFN

-  [LAMBDA (STREAM CHARCODE)
                              (* ; "Edited 15-Jan-98 00:06 by rmk:")

-
-    (* ;; "Put character data in PAGE entry indexed by current yposition")

-
-    (LET ((IMDATA (FETCH
 IMAGEDATA OF
 STREAM)))
-         (SELCHARQ CHARCODE
-              (CR 
-                  (* ;; "Set parameters but don't output--that means we can do lots of moving around, up and down, and still come out OK.")

-
-                  (REPLACE
 PTXPOSITION OF
 IMDATA WITH
 0)
-                  (ADD
 (FETCH
 PTYPOSITION OF
 IMDATA)
-                         (FETCH
 PTLINEFEED OF
 IMDATA)))
-              (FORM (WRITEPLAINTEXTPAGE
 STREAM)
-                    (BOUT STREAM (CHARCODE FORM))
-                    (REPLACE
 PTXPOSITION OF
 IMDATA WITH
 0)
-                    (REPLACE
 PTYPOSITION OF
 IMDATA WITH
 (TIMES 72 11)))
-              (LF (ADD
 (FETCH
 PTYPOSITION OF
 IMDATA)
-                         (FETCH
 PTLINEFEED OF
 IMDATA)))
-              (CL:PUSH [LIST (FETCH
 PTXPOSITION OF
 IMDATA)
-                             CHARCODE
-                             (ADD
 (FETCH
 PTXPOSITION OF
 IMDATA)
-                                    (CHARWIDTH CHARCODE (FETCH
 PTFONT OF
 IMDATA]
-                     (CL:SVREF (FETCH
 PTPAGE OF
 IMDATA)
-                            (FETCH
 PTYPOSITION OF
 IMDATA])
-
-(PLAINTEXT.TEDIT

-  [LAMBDA (FILE PTFILE)
                                  (* ; "Edited  8-Jan-98 06:17 by rmk:")

-                                                             (* ; "Edited 18-Sep-91 18:16 by jds")

-
-    (* ;; "Make a plaintext file from a TEdit document.  If FILE is a string, make it into a symbol for the file-name.  If it's a STREAM, use that stream.")

-
-    [COND
-       ((STRINGP FILE)
-        (SETQ FILE (MKATOM FILE]
-    (SETQ FILE (OPENTEXTSTREAM FILE))
-    (TEDIT.FORMAT.HARDCOPY FILE PTFILE T NIL NIL NIL 'PLAINTEXT)
-    PTFILE])
-
-(PLAINTEXT.TEXT

-  [LAMBDA (FILE PTFILE FONTS HEADING TABS)
               (* ; "Edited  8-Jan-98 06:20 by rmk:")

-
-    (* ;; 
-
"The effect of this should be to throw away font change characters and coerce characters to ISO8859")

-
-    (TEXTTOIMAGEFILE FILE PTFILE 'PLAINTEXT FONTS HEADING TABS])
-)
-(DEFINEQ
-
-(WRITEPLAINTEXTPAGE

-  [LAMBDA (STREAM)
                                       (* ; "Edited 15-Jan-98 09:48 by rmk:")

-    (LET [(PAGE (FETCH
 PTPAGE OF
 (FETCH
 IMAGEDATA OF
 STREAM]
-
-         (* ;; 
-
   "Have to run through y-positions indexed backwards, since have to print higher positions first.")

-
-         (FOR
 YPOS LINE LASTYPOS DIFF (DLF _ (FONTPROP DEFAULTFONT 'HEIGHT))
-                (DSP _ (CHARWIDTH (CHARCODE SPACE)
-                              DEFAULTFONT)) FROM
 (SUB1 (CL:ARRAY-DIMENSION PAGE 0)) TO
 0
-            BY
 -1 FIRST
 (SETQ LASTYPOS YPOS) WHEN
 (SETQ LINE (CL:SVREF PAGE YPOS))
-            DO
 (SETQ DIFF (- LASTYPOS YPOS))
-                  (CL:WHEN (IGREATERP DIFF DLF)              (* ; "Distance is more than a line")

-
-                      (* ;; 
-
                    "Start at 2 because one was already put out at the end of the previous line")

-
-                      (FOR
 I FROM
 2 TO
 (IQUOTIENT DIFF DLF)
-                         DO
 (BOUT STREAM (CHARCODE CR))))
-                  (SORT LINE T)                              (* ; "To print from left to right")

-                  (FOR
 C (LASTX _ 0) IN
 LINE
-                     DO
 (SETQ DIFF (- (POP
 C)
-                                          LASTX))
-                           (CL:WHEN (IGREATERP DIFF DSP)     (* ; "Distance is more than a space")

-                               (FOR
 I FROM
 1 TO
 (IQUOTIENT DIFF DLF)
-                                  DO
 (BOUT STREAM (CHARCODE SPACE))))
-                           [IF
 (ILEQ (CAR C)
-                                         127)
-                               THEN
 (BOUT STREAM (CAR C))
-                             ELSE
 
-
-                                   (* ;; "Should coerce to ISO8859.  If get something below 256, use it.  Otherwise, try to print charactername")

-
-                                   (LET (STRING)
-                                        (SETQ STRING (SELCHARQ (CAR C)
-                                                          (phi "phi")
-                                                          (MEMBEROF "memb")
-                                                          (UC-SIGMA "Sigma")
-                                                          (46,123 "Pi")
-                                                          (357,147 "o")
-                                                          NIL))
-                                        (IF
 STRING
-                                            THEN
 (BOUT STREAM (CHARCODE \))
-                                                  (FOR
 I C FROM
 1
-                                                     WHILE
 (SETQ C (NTHCHARCODE STRING I))
-                                                     DO
 (BOUT STREAM C))
-                                                  (BOUT STREAM (CHARCODE \))
-                                          ELSE
 (BOUT STREAM (CHARCODE ~]
-                           (SETQ LASTX (CADR C)))
-                  (\FILEOUTCHARFN STREAM (CHARCODE CR))
-                  (SETQ LASTYPOS YPOS) 
-
-                  (* ;; "Now clear the entry")

-
-                  (CL:SETF (CL:SVREF PAGE YPOS)
-                         NIL])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS PLAINTEXTPARAM  MACRO

-   [(PNAME PVAL NUMBERPFLAG)
-    (PROG1 (FETCH
 PNAME OF
 (FETCH
 (STREAM IMAGEDATA) OF
 STREAM))
-        [LET ((PV PVAL))
-             (CL:WHEN PV
-                 (REPLACE
 PNAME OF
 (FETCH
 (STREAM IMAGEDATA) OF
 STREAM)
-                    WITH
 (COND
-                                ('NUMBERPFLAG (OR (NUMBERP PV)
-                                                  (\ILLEGAL.ARG PV)))
-                                (T PV))))])])
-)
-(DECLARE%: EVAL@COMPILE
-
-(RECORD PLAINTEXTIMAGEDATA
 (PTPAGE PTXPOSITION PTYPOSITION PTFONT PTLINEFEED PTRIGHTMARGIN 
-                                      PTLEFTMARGIN PTCLIPPINGREGION))
-)
-
-(ADDTOVAR PRINTFILETYPES
 (PLAINTEXT (EXTENSION (PT PLAINTEXT))))
-
-(ADDTOVAR IMAGESTREAMTYPES
 (PLAINTEXT (OPENSTREAM OPENPLAINTEXTSTREAM)
-                                      (FONTCREATE \CREATEDISPLAYFONT)
-                                      (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)
-                                      (CREATECHARSET \CREATECHARSET.DISPLAY)))
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-
-[OR (RECLOOK 'STREAM)
-    (EVAL (SYSRECLOOK1 'STREAM]
-
-[OR (RECLOOK 'IMAGEOPS)
-    (EVAL (SYSRECLOOK1 'IMAGEOPS]
-)
-(PUTPROPS PLAINTEXTSTREAM COPYRIGHT ("Xerox Corporation" 1998))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1746 11976 (OPENPLAINTEXTSTREAM 1756 . 9644) (PLAINTEXTOUTCHARFN 9646 . 11087) (
-PLAINTEXT.TEDIT 11089 . 11661) (PLAINTEXT.TEXT 11663 . 11974)) (11977 15294 (WRITEPLAINTEXTPAGE 11987
- . 15292)))))
-STOP

lispusers/PRETTYFILEINDEX

@@ -1,11 +1,10 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
-
(FILECREATED " 9-Jul-2021 21:55:15" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;5
 93788  
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-      changes to%:  (FNS PRETTYFILEINDEX PFI.PRINT.FILECREATED)
+
(FILECREATED "30-Nov-2021 22:12:37" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;2
 94399  
 
-      previous date%: " 9-Jul-2021 08:04:40" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>PRETTYFILEINDEX.;4)
+      :CHANGES-TO (FNS PFI.PRINT.FILECREATED)
+
+      :PREVIOUS-DATE " 9-Jul-2021 21:55:15" {DSK}<home>larry>medley>lispusers>PRETTYFILEINDEX.;1)
 
 
 (* ; "
@@ -16,7 +15,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
 
 (RPAQQ PRETTYFILEINDEXCOMS

        [(COMS 
-              (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")

+              (* ;; "Variation on SINGLEFILEINDEX that prettyprints straight to the image stream.")

 
               (FNS PFI.NEW.LISTFILES1 PFI.ENQUEUE \PFI.DO.HARDCOPY MAYBE.PRETTYFILEINDEX)
               (FNS PRETTYFILEINDEX PFI.MAKE.LPT.STREAM PFI.SETUP.TRANSLATIONS PFI.OUTCHARFN 
@@ -25,25 +24,25 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
               (FNS PFI.PROCESS.FILE PFI.PASS.COMMENT PFI.HANDLE.EXPR PFI.DEFAULT.HANDLER 
                    PFI.PRETTYPRINT PFI.LINES.REMAINING PFI.MAYBE.NEW.PAGE PFI.ESTIMATE.SIZE 
                    PFI.ESTIMATE.SIZE1))
-        (COMS                                                (* ; "Expression handlers")

+        (COMS                                                (* ; "Expression handlers")

               (FNS PFI.HANDLE.RPAQQ PFI.HANDLE.DECLARE PFI.HANDLE.EVAL-WHEN PFI.HANDLE.DEFDEFINER 
                    PFI.HANDLE.DEFINEQ PFI.PRINT.LAMBDA PFI.PRINT.LAMBDA.BODY PFI.HANDLE.PUTDEF 
                    PFI.HANDLE.PUTPROPS PFI.HANDLE./DECLAREDATATYPE PFI.HANDLE.* PFI.PRINT.COMMENTS 
                    PFI.HANDLE.FILEMAP PFI.HANDLE.PACKAGE))
-        (COMS                                                (* ; "Previewers")

+        (COMS                                                (* ; "Previewers")

               (FNS PFI.PREVIEW.DECLARE PFI.PREVIEW.DEFINEQ))
-        (COMS                                                (* ; "Printing the index")

+        (COMS                                                (* ; "Printing the index")

               (FNS PFI.PRINT.INDEX PFI.CONDENSE.INDEX PFI.SORT.INDICES PFI.COMPUTE.INDEX.SHAPE 
                    PFI.PRINT.INDICES PFI.CENTER.PRINT PFI.INDEX.BREAK PFI.LOOKUP.NAME)
               (FNS PFI.ADD.TO.INDEX PFI.VARNAME PFI.CONSTANTNAMES))
-        (COMS                                                (* ; "Combined listings")

+        (COMS                                                (* ; "Combined listings")

               (FNS MULTIFILEINDEX MULTIFILEINDEX1 PFI.PRINT.MULTI.INDEX PFI.CHOOSE.BEST 
                    PFI.MERGE.INDICES))
-        (COMS                                                (* ; 
-
                                                          "Hooks for seeing files pretty elsewhere")

+        (COMS                                                (* ; 
+
                                                          "Hooks for seeing files pretty elsewhere")

               (FNS PFI.MAYBE.SEE.PRETTY PFI.MAYBE.PP.DEFINITION)
               (INITVARS (*PRINT-PRETTY-FROM-FILES* T)))
-        (COMS                                                (* ; "Bitmap hack")

+        (COMS                                                (* ; "Bitmap hack")

               (FNS PFI.PRINT.BITMAP)
               (INITVARS (*PRINT-PRETTY-BITMAPS* T)))
         (INITVARS [*PFI-PRINTOPTIONS* '(REGION (72 54 504 702]
@@ -57,8 +56,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                                                          then *INTERLISP-PACKAGE* else 
                                                          *KEYWORD-PACKAGE*)))
                                          
-                                         (* ;; 
-
                                  "Properties of definers changed between Lyric and Medley (yech).")

+                                         (* ;; 
+
                                  "Properties of definers changed between Lyric and Medley (yech).")

 
                                          (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
                                                 (FUNCTION CL:INTERN]
@@ -66,7 +65,7 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                (\PFI.PROCESSLOCK (CREATE.MONITORLOCK "PRETTYFILEINDEX"))
                (\PFI.PROCESS))
         (COMS 
-              (* ;; "These are just in case our afternewpagefn escapes our dynamic context.  *PFI-TITLE* being NIL means we're outside prettyfileindex")

+              (* ;; "These are just in case our afternewpagefn escapes our dynamic context.  *PFI-TITLE* being NIL means we're outside prettyfileindex")

 
               (INITVARS (*PFI-TITLE*)
                      (*PFI-PAGE-COUNT* 0)))
@@ -102,8 +101,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                (*PFI-PROPERTIES* (COPYRIGHT)
                       (READVICE ADVICE))
                (*PFI-FILTERS* (VARIABLES . CONSTANTS)))
-        (COMS                                                (* ; 
-
                                        "Prettyprint augmentation to mimic system makefile dumping")

+        (COMS                                                (* ; 
+
                                        "Prettyprint augmentation to mimic system makefile dumping")

               (FNS PUTPROPS.PRETTYPRINT RPAQX.PRETTYPRINT COURIERPROGRAM.PRETTYPRINT 
                    MAYBE.PRETTYPRINT.BOLD)
               (ALISTS (PRETTYPRINTMACROS RPAQ RPAQQ RPAQ? ADDTOVAR PUTPROPS COURIERPROGRAM)))
@@ -119,8 +118,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                (GLOBALVARS \PFI.PROCESS.COMMANDS \PFI.PROCESSLOCK \PFI.PROCESS NOTLISTEDFILES 
                       MACROPROPS CLISPRECORDTYPES PROMPTWINDOW *PFI-DEFINER-PROPS* 
                       *COMMON-LISP-READ-ENVIRONMENT*))
-        [DECLARE%: EVAL@COMPILE DOCOPY                       (* ; 
-
                                                           "Public variables to declare special")

+        [DECLARE%: EVAL@COMPILE DOCOPY                       (* ; 
+
                                                           "Public variables to declare special")

                (P (CL:PROCLAIM '(CL:SPECIAL *PFI-TYPES* *PFI-HANDLERS* *PFI-PREVIEWERS* 
                                        *PFI-DONT-SPAWN* *PFI-PROPERTIES* *PFI-FILTERS* 
                                        *PRINT-PRETTY-FROM-FILES* *PRINT-PRETTY-BITMAPS* 
@@ -130,24 +129,24 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                (P (OR (GETD 'CODEWRAPPER.PRETTYPRINT)
                       (FILESLOAD (SYSLOAD)
                              DEFINERPRINT))
-                                                             (* ; 
-
                                                 "Get prettyprinter fixes if running in old sysout")

+                                                             (* ; 
+
                                                 "Get prettyprinter fixes if running in old sysout")

                   (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
                                 S)
-                                                             (* ; 
-
       "Look for LISTFILES1.  These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")

+                                                             (* ; 
+
       "Look for LISTFILES1.  These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")

                                LP
                                (COND [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
                                            (GETD S))
                                       (RETURN (PROG1 S
                                                   (COND ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE"
                                                                         ))
-                                                             (* ; "Also fix SEE")

+                                                             (* ; "Also fix SEE")

                                                          (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
                                      ((SETQ SYMS (CDR SYMS))
                                       (GO LP))
-                                     (T                      (* ; 
-
                                                           "Neither one loaded, take original")

+                                     (T                      (* ; 
+
                                                           "Neither one loaded, take original")

                                         (RETURN 'LISTFILES1]
                          'PFI.ORIGINAL.LISTFILES1 NIL T)
                   (MOVD 'PFI.NEW.LISTFILES1 'LISTFILES1 NIL T)
@@ -459,12 +458,17 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
 (DEFINEQ
 
 (PFI.PRINT.FILECREATED

-  [LAMBDA (EXPR ENV)
                                    (* ; "Edited  9-Jul-2021 07:59 by rmk:")

+  [LAMBDA (EXPR ENV)                                         (* ; 
+
                                                           "Edited 30-Nov-2021 22:08 by larry")

+                                                             (* ; 
+
                                                           "Edited 30-Nov-2021 21:40 by larry")

+                                                             (* ; 
+
                                                           "Edited  9-Jul-2021 07:59 by rmk:")

 
-    (* ;; "Display the FILECREATED expression and environment prettily")

+    (* ;; "Display the FILECREATED expression and environment prettily")

 
-    (* ;; 
-
  "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")

+    (* ;; 
+
  "Form is (FILECREATED date filename filemaploc changes to: changes previous date: date filename)")

 
     (pop
 EXPR)
     (CHANGEFONT ITALICFONT)
@@ -477,34 +481,41 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                               STRWIDTHS]
           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
-                 TABSTOP)                                    (* ; "File created:")

+                 TABSTOP)                                    (* ; "File created:")

           (PRINTOUT NIL (pop
 EXPR)
                  "  " .FONT LAMBDAFONT (pop
 EXPR)
-                 T T)                                        (* ; "date and file name")

+                 T T)                                        (* ; "date and file name")

           (if
 (OR (NULL (CAR EXPR))
                       (FIXP (CAR EXPR)))
-              then
                                       (* ; "Skip over filemaploc")

+              then
                                       (* ; "Skip over filemaploc")

                     (pop
 EXPR))
-          (if
 (EQ (CAR EXPR)
-                      'changes)
-              then
                                       (* ; "handle %"Changes to:%"")

+          (if
 (SELECTQ (CAR EXPR)
+                      (changes (SETQ EXPR (CDR EXPR))
+                               T)
+                      (:CHANGES-TO T)
+                      NIL)
+              then
                                       (* ; "handle %"Changes to:%"")

                     (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                            (pop
 STRWIDTHS)
                            TABSTOP)
-                    (SETQ EXPR (CDDR EXPR))
+                    (SETQ EXPR (CDR EXPR))
                     (PRINTDEF (while
 (LISTP (CAR EXPR)) collect
 (pop
 EXPR))
                            T NIL T)
                     (TERPRI)
                     (TERPRI)
             else
 (pop
 STRINGS)
                   (pop
 STRWIDTHS))
-          (if
 (EQ (CAR EXPR)
-                      'previous)
-              then
                                       (* ; "Handle %"Previous date:%"")

+          (if
 (SELECTQ (CAR EXPR)
+                      (previous (SETQ EXPR (CDR EXPR))
+                                T)
+                      (:PREVIOUS-DATE 
+                           T)
+                      NIL)
+              then
                                       (* ; "Handle %"Previous date:%"")

                     (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                            (pop
 STRWIDTHS)
                            TABSTOP)
-                    (SETQ EXPR (CDDR EXPR))
+                    (SETQ EXPR (CDR EXPR))
                     (PRINTOUT NIL (pop
 EXPR)
                            "  "
                            (pop
 EXPR)
@@ -512,25 +523,25 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
             else
 (pop
 STRINGS)
                   (pop
 STRWIDTHS))
 
-          (* ;; "Show environment")

+          (* ;; "Show environment")

 
           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
-                 TABSTOP)                                    (* ; "Read table")

+                 TABSTOP)                                    (* ; "Read table")

           (PFI.PRINT.ENVIRONMENT
 ENV :READTABLE)
           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
-                 TABSTOP)                                    (* ; "Package")

+                 TABSTOP)                                    (* ; "Package")

           (PFI.PRINT.ENVIRONMENT
 ENV :PACKAGE)
           (if
 (NEQ *PRINT-BASE* 10)
               then
 (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                               (pop
 STRWIDTHS)
                               TABSTOP)
                     (PFI.PRINT.ENVIRONMENT
 ENV :BASE)
-            ELSE
 (pop
 STRINGS))
+            else
 (pop
 STRINGS))
           (PFI.PRINT.TO.TAB
 (pop
 STRINGS)
                  (pop
 STRWIDTHS)
-                 TABSTOP)                                    (* ; "Format")

+                 TABSTOP)                                    (* ; "Format")

           (PFI.PRINT.ENVIRONMENT
 ENV :FORMAT])
 
 (PFI.PRINT.TO.TAB

@@ -819,8 +830,8 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
                                                     then *INTERLISP-PACKAGE* else *KEYWORD-PACKAGE*))
                                      )
                                     
-                                    (* ;; 
-
                                  "Properties of definers changed between Lyric and Medley (yech).")

+                                    (* ;; 
+
                                  "Properties of definers changed between Lyric and Medley (yech).")

 
                                     (MAPCAR '("DEFINER-FOR" "DEFINED-BY" "DEFINITION-NAME")
                                            (FUNCTION CL:INTERN))))
@@ -948,24 +959,24 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
     (FILESLOAD (SYSLOAD)
            DEFINERPRINT))
 
-                                                             (* ; 
-
                                                 "Get prettyprinter fixes if running in old sysout")

+                                                             (* ; 
+
                                                 "Get prettyprinter fixes if running in old sysout")

 
 (MOVD? [PROG ((SYMS '("OLDLISTFILES1" "LISTFILES1-ORIGINAL"))
-              S)                                             (* ; 
-
       "Look for LISTFILES1.  These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")

+              S)                                             (* ; 
+
       "Look for LISTFILES1.  These two names are where SINGLEFILEINDEX and PP-CODE-FILE stash it.")

          LP  (COND
                 [(AND (SETQ S (CL:FIND-SYMBOL (CAR SYMS)))
                       (GETD S))
                  (RETURN (PROG1 S
                              (COND
                                 ((SETQ S (CL:FIND-SYMBOL "MAYBE-PP-CODE-FILE"))
-                                                             (* ; "Also fix SEE")

+                                                             (* ; "Also fix SEE")

                                  (MOVD 'PFI.MAYBE.SEE.PRETTY S NIL T))))]
                 ((SETQ SYMS (CDR SYMS))
                  (GO LP))
-                (T                                           (* ; 
-
                                                           "Neither one loaded, take original")

+                (T                                           (* ; 
+
                                                           "Neither one loaded, take original")

                    (RETURN 'LISTFILES1]
        'PFI.ORIGINAL.LISTFILES1 NIL T)
 
@@ -983,28 +994,28 @@ Copyright (c) 1988, 1992-1993, 1999, 2021 by Xerox Corporation.
 )
 (PUTPROPS PRETTYFILEINDEX COPYRIGHT ("Xerox Corporation" 1988 1992 1993 1999 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (10148 12383 (PFI.NEW.LISTFILES1 10158 . 10652) (PFI.ENQUEUE 10654 . 11278) (
-\PFI.DO.HARDCOPY 11280 . 11866) (MAYBE.PRETTYFILEINDEX 11868 . 12381)) (12384 35298 (PRETTYFILEINDEX 
-12394 . 26826) (PFI.MAKE.LPT.STREAM 26828 . 29879) (PFI.SETUP.TRANSLATIONS 29881 . 31395) (
-PFI.OUTCHARFN 31397 . 33371) (PFI.COLLECT.DEFINERS 33373 . 34185) (PFI.AFTER.NEW.PAGE 34187 . 35296)) 
-(35299 40558 (PFI.PRINT.FILECREATED 35309 . 38825) (PFI.PRINT.TO.TAB 38827 . 39192) (
-PFI.PRINT.ENVIRONMENT 39194 . 40556)) (40559 47743 (PFI.PROCESS.FILE 40569 . 41799) (PFI.PASS.COMMENT 
-41801 . 42771) (PFI.HANDLE.EXPR 42773 . 43440) (PFI.DEFAULT.HANDLER 43442 . 45495) (PFI.PRETTYPRINT 
-45497 . 45832) (PFI.LINES.REMAINING 45834 . 46161) (PFI.MAYBE.NEW.PAGE 46163 . 46666) (
-PFI.ESTIMATE.SIZE 46668 . 47199) (PFI.ESTIMATE.SIZE1 47201 . 47741)) (47780 57267 (PFI.HANDLE.RPAQQ 
-47790 . 49198) (PFI.HANDLE.DECLARE 49200 . 50139) (PFI.HANDLE.EVAL-WHEN 50141 . 50624) (
-PFI.HANDLE.DEFDEFINER 50626 . 51916) (PFI.HANDLE.DEFINEQ 51918 . 52162) (PFI.PRINT.LAMBDA 52164 . 
-52502) (PFI.PRINT.LAMBDA.BODY 52504 . 52839) (PFI.HANDLE.PUTDEF 52841 . 53338) (PFI.HANDLE.PUTPROPS 
-53340 . 53955) (PFI.HANDLE./DECLAREDATATYPE 53957 . 54504) (PFI.HANDLE.* 54506 . 55768) (
-PFI.PRINT.COMMENTS 55770 . 56670) (PFI.HANDLE.FILEMAP 56672 . 56960) (PFI.HANDLE.PACKAGE 56962 . 57265
-)) (57295 58287 (PFI.PREVIEW.DECLARE 57305 . 57967) (PFI.PREVIEW.DEFINEQ 57969 . 58285)) (58323 69311 
-(PFI.PRINT.INDEX 58333 . 59184) (PFI.CONDENSE.INDEX 59186 . 60993) (PFI.SORT.INDICES 60995 . 62134) (
-PFI.COMPUTE.INDEX.SHAPE 62136 . 63600) (PFI.PRINT.INDICES 63602 . 68144) (PFI.CENTER.PRINT 68146 . 
-68716) (PFI.INDEX.BREAK 68718 . 69176) (PFI.LOOKUP.NAME 69178 . 69309)) (69312 70543 (PFI.ADD.TO.INDEX
- 69322 . 69832) (PFI.VARNAME 69834 . 70244) (PFI.CONSTANTNAMES 70246 . 70541)) (70578 78891 (
-MULTIFILEINDEX 70588 . 71384) (MULTIFILEINDEX1 71386 . 72842) (PFI.PRINT.MULTI.INDEX 72844 . 77947) (
-PFI.CHOOSE.BEST 77949 . 78176) (PFI.MERGE.INDICES 78178 . 78889)) (78948 80566 (PFI.MAYBE.SEE.PRETTY 
-78958 . 79888) (PFI.MAYBE.PP.DEFINITION 79890 . 80564)) (80636 84471 (PFI.PRINT.BITMAP 80646 . 84469))
- (87316 90430 (PUTPROPS.PRETTYPRINT 87326 . 88737) (RPAQX.PRETTYPRINT 88739 . 89464) (
-COURIERPROGRAM.PRETTYPRINT 89466 . 90166) (MAYBE.PRETTYPRINT.BOLD 90168 . 90428)))))
+  (FILEMAP (NIL (10070 12305 (PFI.NEW.LISTFILES1 10080 . 10574) (PFI.ENQUEUE 10576 . 11200) (
+\PFI.DO.HARDCOPY 11202 . 11788) (MAYBE.PRETTYFILEINDEX 11790 . 12303)) (12306 35220 (PRETTYFILEINDEX 
+12316 . 26748) (PFI.MAKE.LPT.STREAM 26750 . 29801) (PFI.SETUP.TRANSLATIONS 29803 . 31317) (
+PFI.OUTCHARFN 31319 . 33293) (PFI.COLLECT.DEFINERS 33295 . 34107) (PFI.AFTER.NEW.PAGE 34109 . 35218)) 
+(35221 41169 (PFI.PRINT.FILECREATED 35231 . 39436) (PFI.PRINT.TO.TAB 39438 . 39803) (
+PFI.PRINT.ENVIRONMENT 39805 . 41167)) (41170 48354 (PFI.PROCESS.FILE 41180 . 42410) (PFI.PASS.COMMENT 
+42412 . 43382) (PFI.HANDLE.EXPR 43384 . 44051) (PFI.DEFAULT.HANDLER 44053 . 46106) (PFI.PRETTYPRINT 
+46108 . 46443) (PFI.LINES.REMAINING 46445 . 46772) (PFI.MAYBE.NEW.PAGE 46774 . 47277) (
+PFI.ESTIMATE.SIZE 47279 . 47810) (PFI.ESTIMATE.SIZE1 47812 . 48352)) (48391 57878 (PFI.HANDLE.RPAQQ 
+48401 . 49809) (PFI.HANDLE.DECLARE 49811 . 50750) (PFI.HANDLE.EVAL-WHEN 50752 . 51235) (
+PFI.HANDLE.DEFDEFINER 51237 . 52527) (PFI.HANDLE.DEFINEQ 52529 . 52773) (PFI.PRINT.LAMBDA 52775 . 
+53113) (PFI.PRINT.LAMBDA.BODY 53115 . 53450) (PFI.HANDLE.PUTDEF 53452 . 53949) (PFI.HANDLE.PUTPROPS 
+53951 . 54566) (PFI.HANDLE./DECLAREDATATYPE 54568 . 55115) (PFI.HANDLE.* 55117 . 56379) (
+PFI.PRINT.COMMENTS 56381 . 57281) (PFI.HANDLE.FILEMAP 57283 . 57571) (PFI.HANDLE.PACKAGE 57573 . 57876
+)) (57906 58898 (PFI.PREVIEW.DECLARE 57916 . 58578) (PFI.PREVIEW.DEFINEQ 58580 . 58896)) (58934 69922 
+(PFI.PRINT.INDEX 58944 . 59795) (PFI.CONDENSE.INDEX 59797 . 61604) (PFI.SORT.INDICES 61606 . 62745) (
+PFI.COMPUTE.INDEX.SHAPE 62747 . 64211) (PFI.PRINT.INDICES 64213 . 68755) (PFI.CENTER.PRINT 68757 . 
+69327) (PFI.INDEX.BREAK 69329 . 69787) (PFI.LOOKUP.NAME 69789 . 69920)) (69923 71154 (PFI.ADD.TO.INDEX
+ 69933 . 70443) (PFI.VARNAME 70445 . 70855) (PFI.CONSTANTNAMES 70857 . 71152)) (71189 79502 (
+MULTIFILEINDEX 71199 . 71995) (MULTIFILEINDEX1 71997 . 73453) (PFI.PRINT.MULTI.INDEX 73455 . 78558) (
+PFI.CHOOSE.BEST 78560 . 78787) (PFI.MERGE.INDICES 78789 . 79500)) (79559 81177 (PFI.MAYBE.SEE.PRETTY 
+79569 . 80499) (PFI.MAYBE.PP.DEFINITION 80501 . 81175)) (81247 85082 (PFI.PRINT.BITMAP 81257 . 85080))
+ (87927 91041 (PUTPROPS.PRETTYPRINT 87937 . 89348) (RPAQX.PRETTYPRINT 89350 . 90075) (
+COURIERPROGRAM.PRETTYPRINT 90077 . 90777) (MAYBE.PRETTYPRINT.BOLD 90779 . 91039)))))
 STOP

lispusers/STREAMDECLS

@@ -1,220 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-
(FILECREATED "10-Sep-87 12:12:37" {DSK}<OST>STREAMDECLS.\;1
 10202  
-
-      |changes| |to:|  (VARS STREAMDECLSCOMS)
-                       (RECORDS STREAM))
-
-
-(PRETTYCOMPRINT STREAMDECLSCOMS)
-
-(RPAQQ STREAMDECLSCOMS
 ((RECORDS STREAM)))
-(DECLARE\: EVAL@COMPILE
-
-(DATATYPE STREAM
 
-          (
-          
-          (* |;;| "First 8 words are fixed for BIN, BOUT opcodes.  Used to require length of whole datatype be multiple of 4, but Dolphin dead now.")

-
-           (COFFSET WORD)                                    (* \; 
-
                                                             "Offset in CPPTR of next bin or bout")

-
-           (CBUFSIZE WORD)                                   (* \; 
-
                                                             "Offset past last byte in that buffer")

-
-           (BINABLE FLAG)                                    (* \; "BIN punts unless this bit on")

-
-           (BOUTABLE FLAG)                                   (* \; "BOUT punts unless this bit on")

-
-           (EXTENDABLE FLAG)                                 (* \; 
-
                        "BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512")

-
-           (CBUFDIRTY FLAG)                                  (* \; 
-
                                                        "true if BOUT has sullied the current buffer")

-
-           (PEEKEDCHARP FLAG)                                (* \; 
-
                                   "if true, PEEKEDCHAR contains value of recent call to unread-char")

-
-           (ACCESSBITS BITS 3)                               (* \; 
-
                                         "What kind of access file is open for (read, write, append)")

-
-           (CBUFPTR POINTER)                                 (* \; "Pointer to current buffer")

-
-           (BYTESIZE BYTE)                                   (* \; 
-
                                                             "Byte size of stream, always 8 for now")

-
-           (CHARSET BYTE)                                    (* \; "the current character set for this stream.  If 255, stream is not runcoded, so read-char consumes two bytes every time")

-
-           (PEEKEDCHAR WORD)                                 (* \; "value of unread-char call")

-
-           (CHARPOSITION WORD)                               (* \; "Used by POSITION etc.")

-
-           (CBUFMAXSIZE WORD)                                (* \; 
-
                               "on output, the size of the physical buffer--can't extend beyond this")

-          
-          (* |;;| "-------- Above fields (8 words) potentially known to microcode.  --------")

-
-           (NONDEFAULTDATEFLG FLAG)
-           (REVALIDATEFLG FLAG)
-           (MULTIBUFFERHINT FLAG)                            (* \; 
-
                              "True if stream likes to read and write more than one buffer at a time")

-
-           (USERCLOSEABLE FLAG)                              (* \; 
-
                                             "Can be closed by CLOSEF;  NIL for terminal, dribble...")

-
-           (USERVISIBLE FLAG)                                (* \; 
-
                                                    "Listed by OPENP;  NIL for terminal, dribble ...")

-
-           (EOLCONVENTION BITS 2)                            (* \; "End-of-line convention")

-
-           (NIL FLAG)
-           (FULLFILENAME POINTER)                            (* \; 
-
                                                             "Name by which file is known to user")

-
-           (DEVICE POINTER)                                  (* \; "FDEV of this guy")

-
-           (VALIDATION POINTER)                              (* \; 
-
            "A number somehow identifying file, used to determine if file has changed in our absence")

-
-           (CPAGE POINTER)                                   (* \; 
-
                        "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams")

-
-           (EPAGE POINTER)
-           (EOFFSET WORD)                                    (* \; "Page, byte offset of eof")

-
-           (LINELENGTH WORD)                                 (* \; 
-
                                                     "LINELENGTH of stream, or -1 for no line length")

-          
-          (* |;;| "----Following are device-specific fields----")

-
-           (F1 POINTER)
-           (F2 POINTER)
-           (F3 POINTER)
-           (F4 POINTER)
-           (F5 POINTER)
-           (FW6 WORD)
-           (FW7 WORD)
-           (FW8 WORD)
-           (FW9 WORD)
-           (F10 POINTER)
-          
-          (* |;;| "----Following only filled in for open streams----")

-
-           (STRMBINFN POINTER)                               (* \; 
-
                                                         "Either the BIN fn from the FDEV, or a trap")

-
-           (STRMBOUTFN POINTER)                              (* \; 
-
                                                         "Either the BIN fn from the FDEV, or a trap")

-
-           (OUTCHARFN POINTER)
-           (ENDOFSTREAMOP POINTER)
-           (OTHERPROPS POINTER)
-           (IMAGEOPS POINTER)                                (* \; "Image operations vector")

-
-           (IMAGEDATA POINTER)                               (* \; 
-
                                         "Image instance variables--format depends on IMAGEOPS value")

-
-           (BUFFS POINTER)                                   (* \; "Buffer chain for pmapped streams")

-
-           (MAXBUFFERS WORD)
-           (NIL WORD)
-           (EXTRASTREAMOP POINTER)                           (* \; 
-
                                                      "For use of applications programs, not devices")

-
-           )
-          (BLOCKRECORD STREAM ((NIL 2 WORD)
-                               (UCODEFLAGS BITS 5)
-          
-          (* |;;| "respecification of access bits:")

-
-                               (RANDOMWRITEABLE FLAG)        (* \; 
-
                                                     "File open for output (access = OUTPUT or BOTH)")

-
-                               (APPENDABLE FLAG)             (* \; 
-
                                                    "File open for append (OUTPUT or APPEND or BOTH)")

-
-                               (READABLE FLAG)               (* \; 
-
                                                             "File open for read (READ or BOTH)")

-
-                               (NIL POINTER)))
-          (ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS)
-                             (FULLNAME (OR (|fetch|
 (STREAM FULLFILENAME) |of|
 DATUM)
-                                           DATUM))
-                             (NAMEDP (AND (|fetch|
 (STREAM FULLFILENAME) |of|
 DATUM)
-                                          T))))
-          (SYNONYM CBUFPTR (CPPTR))
-          USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ |NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL 
-          BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE
 (GLOBALVARS 
-                                                                          \\STREAM.DEFAULT.MAXBUFFERS
-                                                                           ))
-                                                       \\STREAM.DEFAULT.MAXBUFFERS)
-          CHARPOSITION _ 0 LINELENGTH _ (LET NIL (DECLARE
 (GLOBALVARS FILELINELENGTH))
-                                             FILELINELENGTH)
-          OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN)
-          ENDOFSTREAMOP _ (FUNCTION \\EOSERROR)
-          IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE)
-                                                      (D CR.EOLC)
-                                                      (VAX LF.EOLC)
-                                                      (JERICHO CRLF.EOLC)
-                                                      CR.EOLC)
-          STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN)
-          STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN))
-)
-(/DECLAREDATATYPE 'STREAM
-       '(WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 3)
-              POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG FLAG (BITS 2)
-              FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER 
-              POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-              POINTER POINTER WORD WORD POINTER)
-       '((STREAM 0 (BITS . 15))
-         (STREAM 1 (BITS . 15))
-         (STREAM 2 (FLAGBITS . 0))
-         (STREAM 2 (FLAGBITS . 16))
-         (STREAM 2 (FLAGBITS . 32))
-         (STREAM 2 (FLAGBITS . 48))
-         (STREAM 2 (FLAGBITS . 64))
-         (STREAM 2 (BITS . 82))
-         (STREAM 2 POINTER)
-         (STREAM 4 (BITS . 7))
-         (STREAM 4 (BITS . 135))
-         (STREAM 5 (BITS . 15))
-         (STREAM 6 (BITS . 15))
-         (STREAM 7 (BITS . 15))
-         (STREAM 8 (FLAGBITS . 0))
-         (STREAM 8 (FLAGBITS . 16))
-         (STREAM 8 (FLAGBITS . 32))
-         (STREAM 8 (FLAGBITS . 48))
-         (STREAM 8 (FLAGBITS . 64))
-         (STREAM 8 (BITS . 81))
-         (STREAM 8 (FLAGBITS . 112))
-         (STREAM 8 POINTER)
-         (STREAM 10 POINTER)
-         (STREAM 12 POINTER)
-         (STREAM 14 POINTER)
-         (STREAM 16 POINTER)
-         (STREAM 18 (BITS . 15))
-         (STREAM 19 (BITS . 15))
-         (STREAM 20 POINTER)
-         (STREAM 22 POINTER)
-         (STREAM 24 POINTER)
-         (STREAM 26 POINTER)
-         (STREAM 28 POINTER)
-         (STREAM 30 (BITS . 15))
-         (STREAM 31 (BITS . 15))
-         (STREAM 32 (BITS . 15))
-         (STREAM 33 (BITS . 15))
-         (STREAM 34 POINTER)
-         (STREAM 36 POINTER)
-         (STREAM 38 POINTER)
-         (STREAM 40 POINTER)
-         (STREAM 42 POINTER)
-         (STREAM 44 POINTER)
-         (STREAM 46 POINTER)
-         (STREAM 48 POINTER)
-         (STREAM 50 POINTER)
-         (STREAM 52 (BITS . 15))
-         (STREAM 53 (BITS . 15))
-         (STREAM 54 POINTER))
-       '56)
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL)))
-STOP

lispusers/TEDIT-PF-SEE

@@ -0,0 +1,152 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+
(FILECREATED "16-Oct-2021 19:23:40" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TEDIT-PF-SEE.;32
 7178   
+
+      changes to%:  (FNS CLOSE-TYPED-WINDOW)
+
+      previous date%: "12-Oct-2021 22:31:01" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>TEDIT-PF-SEE.;31)
+
+
+(PRETTYCOMPRINT TEDIT-PF-SEECOMS)
+
+(RPAQQ TEDIT-PF-SEECOMS

+       [(FNS SEE-TEDIT PF-TEDIT)
+        (COMS (FNS GET-TYPED-WINDOW CLOSE-TYPED-WINDOW)
+              (INITVARS (TYPED-WINDOWS)))
+        (COMMANDS ts tpf)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA])
+(DEFINEQ
+
+(SEE-TEDIT

+  [LAMBDA (FILE WINDOW FORMAT)
                          (* ; "Edited 11-Oct-2021 08:51 by rmk:")

+    (SETQ FILE (OR (FINDFILE-WITH-EXTENSIONS FILE NIL '(NIL TEDIT TED TXT TEXT TEX))
+                   (ERROR "FILE NOT FOUND" FILE)))
+    (TEDIT-SEE FILE (GET-TYPED-WINDOW
 (OR WINDOW 'SEE-TEDIT)
+                           (CONCAT "SEE window for " FILE))
+           FORMAT)
+    FILE])
+
+(PF-TEDIT

+  [LAMBDA (FN IFILES)
                                   (* ; "Edited 12-Oct-2021 15:22 by rmk:")

+
+    (* ;; "PF* to a read-only TEDIT window.  First argument is the function name, second if given is the input file.")

+
+    (CL:WHEN (LISTP FN)
+        (SETQ FN (CAR FN)))
+    (IF
 FN
+        THEN
                                             (* ; "FN name specified; use it.")

+              (SETQ LASTWORD FN)
+      ELSE
                                               (* ; "Not specified, use LASTWORD")

+            (SETQ FN LASTWORD))
+    (IF
 [OR IFILES (SETQ IFILES (APPEND (WHEREIS FN 'FNS T)
+                                           (WHEREIS FN 'FUNCTIONS T]
+        THEN
                                             (* ; "skip compiled files")

+              (FOR
 IFILE LOC TSTREAM ENV INSIDE
 IFILES
+                 UNLESS
 (MEMB (FILENAMEFIELD IFILE 'EXTENSION)
+                                  *COMPILED-EXTENSIONS*)
+                 DO
 (SETQ LOC (FINDFNDEF FN IFILE))
+                       (IF
 (LISTP LOC)
+                           THEN
 [CL:WITH-OPEN-FILE (ISTREAM (POP
 LOC)
+                                                              :DIRECTION :INPUT)
+                                           (SETQ ENV (LISPSOURCEFILEP ISTREAM))
+                                           (SETFILEINFO ISTREAM 'FORMAT ENV)
+                                           (SETQ TSTREAM (OPENTEXTSTREAM))
+                                           (DSPFONT DEFAULTFONT TSTREAM)
+                                           (PRINT-READER-ENVIRONMENT ENV TSTREAM)
+                                           (PFCOPYBYTES ISTREAM TSTREAM (POP
 LOC)
+                                                  (POP
 LOC))
+                                           (TERPRI TSTREAM)
+                                           (SETQ TSTREAM (TEDIT TSTREAM (GET-TYPED-WINDOW

+                                                                         'PF-TEDIT
+                                                                         (CONCAT FN "  from "
+                                                                                (FULLNAME ISTREAM)))
+                                                                NIL
+                                                                '(READONLY T]
+                         ELSEIF
 (EQ LOC 'FILE.NOT.FOUND)
+                           THEN
 (printout T "file " IFILE " not found." T)
+                         ELSE
 (printout T FN " not found on " LOC "." T)))
+      ELSE
 (PRINTOUT T FN " has no function definition" T])
+)
+(DEFINEQ
+
+(GET-TYPED-WINDOW

+  [LAMBDA (WINDOWTYPE TITLE NOOPENFLG)
                  (* ; "Edited 11-Oct-2021 10:06 by rmk:")

+
+    (* ;; "WINDOWTYPE=T means always create a new window.  If a WINDOW, then reuse it.")

+
+    (* ;; "Otherwise, create a window of type WINDOWTYPE, using a previously specified region if one is available.")

+
+    (LET (WINDOW REGION WLIST)
+         [IF
 (OR (EQ WINDOWTYPE T)
+                     (SETQ WINDOW (WINDOWP WINDOWTYPE)))
+             THEN
 (SETQ WINDOWTYPE NIL)
+           ELSE
 [SETQ WLIST (OR (ASSOC WINDOWTYPE TYPED-WINDOWS)
+                                    (CAR (PUSH
 TYPED-WINDOWS (CONS WINDOWTYPE]
+                 (SETQ REGION (FIND
 X IN
 (CDR WLIST) SUCHTHAT
 (TYPE?
 REGION X]
+         (CL:UNLESS WINDOW
+
+             (* ;; "Make sure we have a titlebar and promptwindow")

+
+             (SETQ WINDOW (CREATEW REGION "" NIL NOOPENFLG))
+             (GETPROMPTWINDOW WINDOW)
+
+             (* ;; 
+
        "Replace the region on WLIST with the window, so we can maintan a likely preference order.")

+
+             (IF
 REGION
+                 THEN
 (DSUBST WINDOW REGION WLIST)
+               ELSE
 (NCONC1 WLIST WINDOW)))
+         (CL:WHEN TITLE
+             (WINDOWPROP WINDOW 'TITLE TITLE))
+         (CL:WHEN WINDOWTYPE
+             (WINDOWPROP WINDOW 'WINDOWTYPE WINDOWTYPE)
+             (WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION CLOSE-TYPED-WINDOW)))
+         WINDOW])
+
+(CLOSE-TYPED-WINDOW

+  [LAMBDA (WINDOW ALL)
                                  (* ; "Edited 16-Oct-2021 19:23 by rmk:")

+
+    (* ;; "Puts the region of WINDOW back on the region list for its type, for later reuse.  If ALL, closes all windows of the type of WINDOW (and recursively puts their regions also on the list).")

+
+    (CL:WHEN (OPENWP WINDOW)
+        [LET [(WINDOWTYPE (WINDOWPROP WINDOW 'WINDOWTYPE]
+             (CL:WHEN WINDOWTYPE
+                 (IF
 ALL
+                     THEN
 (FOR
 W IN
 (OPENWINDOWS) WHEN
 (EQ WINDOWTYPE
+                                                                           (WINDOWPROP W 'WINDOWTYPE)
+                                                                           )
+                                 UNLESS
 (EQ W WINDOW) DO
 (CLOSEW W))
+                   ELSE
 
+
+                         (* ;; "This may no longer be needed, now that TEDIT removes the process for READONLY windows just as for ordinary edit windows.")

+
+                         (AND NIL (CL:WHEN (TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS))
+                                                             (* ; 
+
                                            "Otherwise, the window pops up if you don't click away")

+                                      (TTY.PROCESS T)))
+                         (DSUBST (WINDOWPROP WINDOW 'REGION)
+                                WINDOW TYPED-WINDOWS)))])
+    WINDOW])
+)
+
+(RPAQ? TYPED-WINDOWS
 )
+
+(DEFCOMMAND ts (FILE WINDOW FORMAT) (SEE-TEDIT
 FILE WINDOW FORMAT))
+
+(DEFCOMMAND tpf (FN IFILES) (PF-TEDIT
 FN IFILES))
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 )
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (843 3913 (SEE-TEDIT 853 . 1263) (PF-TEDIT 1265 . 3911)) (3914 6866 (GET-TYPED-WINDOW 
+3924 . 5397) (CLOSE-TYPED-WINDOW 5399 . 6864)))))
+STOP

lispusers/THINFILES

@@ -1,11 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "18-Aug-2021 20:46:55" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>THINFILES.;5
 8653   
 
-      changes to%:  (FNS FB.THINCOMMAND)
+
(FILECREATED " 9-Oct-2021 00:35:17" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>THINFILES.;11
 8621   
 
-      previous date%: " 8-Aug-2021 15:05:08" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>THINFILES.;4)
+      changes to%:  (FNS FB.THINP)
+
+      previous date%: " 7-Oct-2021 12:40:24" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>THINFILES.;8)
 
 
 (* ; "
@@ -14,16 +15,16 @@ Copyright (c) 1987-1989, 1992, 2021 by Xerox Corporation.
 
 (PRETTYCOMPRINT THINFILESCOMS)
 
-(RPAQQ THINFILESCOMS
 [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
-                                                                  FILEBROWSER))
-                          (FNS FB.THINCOMMAND FB.THINP)
-                          (INITVARS [THINEXTENSIONS (UNION *COMPILED-EXTENSIONS*
-                                                           '(SYSOUT DCOM DATABASE LCOM DFASL MCOM 
-                                                                   MFASL DRIBBLE]
-                                 (THINNAMES NIL))
-                          (APPENDVARS (FB.MENU.ITEMS (Thin FB.THINCOMMAND 
+(RPAQQ THINFILESCOMS

+       [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                FILEBROWSER))
+        (FNS FB.THINCOMMAND FB.THINP)
+        (INITVARS [THINEXTENSIONS (UNION *COMPILED-EXTENSIONS*
+                                         '(SYSOUT DCOM DATABASE LCOM DFASL MCOM MFASL DRIBBLE]
+               (THINNAMES NIL))
+        (APPENDVARS (FB.MENU.ITEMS (Thin FB.THINCOMMAND 
                      "Delvers non-source files and removes all but the last source file of each day."
-                                                           ])
+                                         ])
 (DECLARE%: EVAL@COMPILE DONTCOPY 
 
 (FILESLOAD (LOADCOMP)
@@ -116,29 +117,33 @@ Copyright (c) 1987-1989, 1992, 2021 by Xerox Corporation.
          (FB.PROMPTWPRINT FBROWSER T "Done, " NDELETED " files marked for deletion."])
 
 (FB.THINP

-  [LAMBDA (FILENAME AGE DELTATIMESTAMP OLDESTVERSION? ONEDAY)

-                                                            (* ; "Edited  8-Aug-2021 15:05 by rmk:")

+  [LAMBDA (FILENAME AGE DELTATIMESTAMP OLDESTVERSION? ONEDAY)

+                                                            (* ; "Edited  9-Oct-2021 00:35 by rmk:")

+    (SETQ FILENAME (U-CASE FILENAME))
     (COND
-       ((FMEMB (U-CASE (FILENAMEFIELD FILENAME 'EXTENSION))
-               THINEXTENSIONS)                               (* ; 
-
                                   "always delver files that can be reconstructed from the source.")

-        T)
-       ((AND THINNAMES (EQMEMB (U-CASE (FILENAMEFIELD FILENAME 'NAME))
-                              THINNAMES))
-        T)
-       (OLDESTVERSION?                                       (* ; 
-
                                                 "don't delete the oldest version of source files.")

+       [(OR (EQMEMB (FILENAMEFIELD FILENAME 'EXTENSION)
+                   THINEXTENSIONS)
+            (FIND
 TN (FN _ (FILENAMEFIELD FILENAME 'NAME))
+                   (FE _ (FILENAMEFIELD FILENAME 'EXTENSION)) INSIDE
 THINNAMES
+               SUCHTHAT
 
+
+                     (* ;; "Separate extractions because period for null extension is confusing")

+
+                     (AND (EQ FN (FILENAMEFIELD TN 'NAME))
+                          (EQ FE (FILENAMEFIELD TN 'EXTENSION]
+       (OLDESTVERSION?                                       (* ; 
+
                                                 "don't delete the oldest version of source files.")

               NIL)
-       ((ILESSP AGE ONEDAY)                                  (* ; 
-
                                                   "don't delete anything written within 24 hours.")

+       ((ILESSP AGE ONEDAY)                                  (* ; 
+
                                                   "don't delete anything written within 24 hours.")

         NIL)
        ((ILESSP (ITIMES DELTATIMESTAMP 3)
-               ONEDAY)                                       (* ; 
-
         "delete anything that occurs on the same day as something else (except for the first day)")

+               ONEDAY)                                       (* ; 
+
         "delete anything that occurs on the same day as something else (except for the first day)")

         T)
        ((ILESSP DELTATIMESTAMP (IQUOTIENT AGE 30))
 
-        (* ;; "after one month, delete things that are within a day of each other, after two months, within two days, etc.")

+        (* ;; "after one month, delete things that are within a day of each other, after two months, within two days, etc.")

 
         T])
 )
@@ -153,5 +158,5 @@ Copyright (c) 1987-1989, 1992, 2021 by Xerox Corporation.
                                      ))
 (PUTPROPS THINFILES COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1992 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1297 8184 (FB.THINCOMMAND 1307 . 6808) (FB.THINP 6810 . 8182)))))
+  (FILEMAP (NIL (1106 8152 (FB.THINCOMMAND 1116 . 6617) (FB.THINP 6619 . 8150)))))
 STOP

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

lispusers/TMAX-DATE

@@ -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

lispusers/WHEELSCROLL

@@ -1,11 +1,12 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-
(FILECREATED "11-Jun-2021 12:50:16" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;18
 10803  
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-      changes to%:  (FNS ENABLEWHEELSCROLL)
+
(FILECREATED "29-Nov-2021 22:06:33" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>WHEELSCROLL.;21
 11690  
 
-      previous date%: "11-Jun-2021 11:11:10" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;14)
+      changes to%:  (FNS INSTALL-WHEELSCROLL)
+
+      previous date%: "29-Nov-2021 21:58:55" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>WHEELSCROLL.;20)
 
 
 (PRETTYCOMPRINT WHEELSCROLLCOMS)
@@ -14,20 +15,21 @@
        [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL 
              LISPINTERRUPTS.WHEELSCROLL)
         
-        (* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")

+        (* ;; "These are the highest meta-ctrl characters, they will be unaffected by teh state of ctrl and meta mode keys")

 
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (UP 156)
-                                                (DOWN 157)
-                                                (LEFT 158)
-                                                (RIGHT 159)))
+        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\WSUP 156)
+                                                (\WSDOWN 157)
+                                                (\WSLEFT 158)
+                                                (\WSRIGHT 159)))
         (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
         
-        (* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")

+        (* ;; "To restore the keyactions for PAD..., if the keyaction table has been reinitialized")

 
         [ADDVARS (AFTERSYSOUTFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T)))
                (AFTERMAKESYSFORMS (AND WHEELSCROLLENABLED (ENABLEWHEELSCROLL T]
         (INITVARS (WHEELSCROLLENABLED NIL)
                (WHEELSCROLLDELTA 20)
+               (HWHEELSCROLLDELTA NIL)
                (WHEELSCROLLSETTLETIME 50)
                (\WHEELSCROLLINPROGRESS NIL))
         (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL)
@@ -35,65 +37,69 @@
 (DEFINEQ
 
 (ENABLEWHEELSCROLL

-  [LAMBDA (ON
 EXCLUDEHORIZONTAL)
                    (* ; "Edited 11-Jun-2021 12:50 by rmk:")


-                                                            (* ; "Edited 28-May-2021 11:46 by rmk:")

+  [LAMBDA (ON
 EXCLUDEHORIZONTAL)                         (* ; 
+
                                                           "Edited 23-Oct-2021 16:31 by larry")

+                                                             (* ; 
+
                                                           "Edited 11-Jun-2021 12:50 by rmk:")

+                                                             (* ; 
+
                                                           "Edited 28-May-2021 11:46 by rmk:")

 
-    (* ;; "So we can toggle this scrolling.")

+    (* ;; "So we can toggle this scrolling.")

 
-    (IF
 ON
-        THEN
 (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
+    (if
 ON
+        then
 (CL:UNLESS (EQP (GETD 'LISPINTERRUPTS)
                                  (GETD 'LISPINTERRUPTS.WHEELSCROLL))
                      (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
-                                                             (* ; "In case of LOADFROM?")

+                                                             (* ; "In case of LOADFROM?")

                          (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
                          (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS))) 
 
-              (* ;; "In some situations these other keyactions seem to be installed, hit them all.")

+              (* ;; "In some situations these other keyactions seem to be installed, hit them all.")

 
-              [FOR
 KAT IN
 (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
-                 DO
 ((FOR
 K IN
 [IF
 EXCLUDEHORIZONTAL
-                                               THEN
 `((PAD1 ,UP)
-                                                          (PAD2 ,DOWN)
-                                                          (PAD4 IGNORE)
-                                                          (PAD5 IGNORE))
-                                             ELSE
 `((PAD1 ,UP)
-                                                        (PAD2 ,DOWN)
-                                                        (PAD4 ,LEFT)
-                                                        (PAD5 ,RIGHT]
-                            DO
 (KEYACTION (CAR K)
-                                          (CONS (CL:IF (EQ (CADR K)
-                                                           'IGNORE)
-                                                    'IGNORE
-                                                    `(,(CADR K)
-                                                      ,(CADR K)))
-                                                `IGNORE)
-                                          KAT]
-              (FOR
 I IN
 WHEELSCROLLINTERRUPTS
-                 DO
 (INTERRUPTCHAR (CAR I)
+              (for
 KAT in
 (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
+                 do
 (for
 K in
 [if
 EXCLUDEHORIZONTAL
+                                              then
 `((PAD1 ,\WSUP)
+                                                         (PAD2 ,\WSDOWN)
+                                                         (PAD4 IGNORE)
+                                                         (PAD5 IGNORE))
+                                            else
 `((PAD1 ,\WSUP)
+                                                       (PAD2 ,\WSDOWN)
+                                                       (PAD4 ,\WSLEFT)
+                                                       (PAD5 ,\WSRIGHT]
+                           do
 (KEYACTION (CAR K)
+                                         (CONS (CL:IF (EQ (CADR K)
+                                                          'IGNORE)
+                                                   'IGNORE
+                                                   `(,(CADR K)
+                                                     ,(CADR K)))
+                                               `IGNORE)
+                                         KAT)))
+              (for
 I in
 WHEELSCROLLINTERRUPTS
+                 do
 (INTERRUPTCHAR (CAR I)
                                (CADR I)
                                (CADDR I))
                        (CL:WHEN (BOUNDP 'TEDIT.READTABLE)
 
-                           (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")

+                           (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")

 
                            (TEDIT.SETFUNCTION (CAR I)
                                   `[LAMBDA NIL
                                      ,(CADR I]
                                   TEDIT.READTABLE)))
               (SETQ WHEELSCROLLENABLED T)
-      ELSE
 (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
+      else
 (CL:WHEN (EQP (GETD 'LISPINTERRUPTS.WHEELSCROLL)
                              (GETD 'LISPINTERRUPTS))
                    (MOVD 'LISPINTERRUPTS.WSORIG 'LISPINTERRUPTS))
-            (FOR
 I IN
 WHEELSCROLLINTERRUPTS DO
 (INTERRUPTCHAR (CAR I)
+            (for
 I in
 WHEELSCROLLINTERRUPTS do
 (INTERRUPTCHAR (CAR I)
                                                                   NIL)
                                                           (CL:WHEN (BOUNDP 'TEDIT.READTABLE)
 
-                                                (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")

+                                                (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")

 
                                                               (TEDIT.SETFUNCTION (CAR I)
                                                                      NIL TEDIT.READTABLE)))
-            (FOR
 KAT IN
 (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
-               DO
 (KEYACTION 'PAD1 '(IGNORE . IGNORE)
+            (for
 KAT in
 (LIST \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION)
+               do
 (KEYACTION 'PAD1 '(IGNORE . IGNORE)
                              KAT)
                      (KEYACTION 'PAD2 '(IGNORE . IGNORE)
                             KAT)
@@ -104,41 +110,42 @@
             (SETQ WHEELSCROLLENABLED NIL])
 
 (WHEELSCROLL

-  [LAMBDA (DIRECTION DELTA)
                             (* ; "Edited 21-Feb-2021 09:38 by rmk:")

+  [LAMBDA (DIRECTION DELTA)                                  (* ; 
+
                                                           "Edited 21-Feb-2021 09:38 by rmk:")

 
-    (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button.  And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button.  We don't yet have a good solution to this problem.  (This is not an issue with a trackpad)")

+    (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button.  And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button.  We don't yet have a good solution to this problem.  (This is not an issue with a trackpad)")

 
-    (* ;; "")

+    (* ;; "")

 
-    (CL:WHEN (MOUSESTATE UP)                                 (* ; 
-
                                                           "Ignore interrupt if a button is down")

+    (CL:WHEN (MOUSESTATE UP)                                 (* ; 
+
                                                           "Ignore interrupt if a button is down")

         [LET ((W (WHICHW)))
 
-         (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within 
-
       the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))

+         (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within 
+
       the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))

 
              (CL:WHEN W
 
-                 (* ;; "We scroll only if the window has a scrollfn.  Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL.  Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")

+                 (* ;; "We scroll only if the window has a scrollfn.  Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL.  Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")

 
-                 (IF
 (WINDOWPROP W 'SCROLLFN)
-                     THEN
 [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
+                 (if
 (WINDOWPROP W 'SCROLLFN)
+                     then
 [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
                                      (CL:IF (EQ DIRECTION 'VERTICAL)
                                          `(WHEELSCROLL.DOIT
 ,(KWOTE W)
                                                  0
                                                  ,DELTA)
                                          `(WHEELSCROLL.DOIT
 ,(KWOTE W)
                                                  ,DELTA 0))]
-                   ELSEIF
 (EQ DIRECTION 'VERTICAL)
-                     THEN
 
+                   elseif
 (EQ DIRECTION 'VERTICAL)
+                     then
 
 
-                           (* ;; "We are in a pop-up scrollbar.  This moves the cursor there, the user has to click to scroll the main window.")

+                           (* ;; "We are in a pop-up scrollbar.  This moves the cursor there, the user has to click to scroll the main window.")

 
                            (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
                                (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
                                (GETMOUSESTATE))
-                   ELSEIF
 (EQ DIRECTION 'HORIZONTAL)
-                     THEN
 (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
+                   elseif
 (EQ DIRECTION 'HORIZONTAL)
+                     then
 (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
                                   (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
                                          LASTMOUSEY)
                                   (GETMOUSESTATE))))])])
@@ -156,18 +163,22 @@
         (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))])
 
 (INSTALL-WHEELSCROLL

-  [LAMBDA NIL
                                           (* ; "Edited 28-May-2021 11:46 by rmk:")


-                                                            (* ; "Edited 17-Feb-2021 11:53 by rmk:")

+  [LAMBDA NIL
                                               (* ; "Edited 29-Nov-2021 21:56 by rmk:")


+                                                            (* ; "Edited 28-May-2021 11:46 by rmk:")


+                                                            (* ; "Edited 17-Feb-2021 11:53 by rmk:")

 
-    (* ;; "We want the UP, DOWN...constants to be compiled awsy")

+    (* ;; "We want the UP, DOWN...constants to be compiled awsy")

 
-    (SETQ WHEELSCROLLINTERRUPTS `((,UP (WHEELSCROLL
 'VERTICAL WHEELSCROLLDELTA)
-                                       T)
-                                  (,DOWN (WHEELSCROLL
 'VERTICAL (IMINUS WHEELSCROLLDELTA))
+    (SETQ WHEELSCROLLINTERRUPTS `((,\WSUP (WHEELSCROLL
 'VERTICAL WHEELSCROLLDELTA)
                                          T)
-                                  (,LEFT (WHEELSCROLL
 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
-                                                T))
-                                  (,RIGHT (WHEELSCROLL
 'HORIZONTAL WHEELSCROLLDELTA T])
+                                  (,\WSDOWN (WHEELSCROLL
 'VERTICAL (IMINUS WHEELSCROLLDELTA))
+                                         T)
+                                  (,\WSLEFT (WHEELSCROLL
 'HORIZONTAL (IMINUS (OR HWHEELSCROLLDELTA 
+                                                                                 WHEELSCROLLDELTA))
+                                                   T))
+                                  (,\WSRIGHT (WHEELSCROLL
 'HORIZONTAL (OR HWHEELSCROLLDELTA 
+                                                                          WHEELSCROLLDELTA)
+                                                    WHEELSCROLLDELTA T])
 
 (LISPINTERRUPTS.WHEELSCROLL

   [LAMBDA NIL
                                           (* ; "Edited 17-Feb-2021 11:09 by rmk:")

@@ -186,19 +197,19 @@
 (DECLARE%: EVAL@COMPILE DONTCOPY 
 (DECLARE%: EVAL@COMPILE 
 
-(RPAQQ UP
 156)
+(RPAQQ \WSUP
 156)
 
-(RPAQQ DOWN
 157)
+(RPAQQ \WSDOWN
 157)
 
-(RPAQQ LEFT
 158)
+(RPAQQ \WSLEFT
 158)
 
-(RPAQQ RIGHT
 159)
+(RPAQQ \WSRIGHT
 159)
 
 
-(CONSTANTS (UP 156)
-       (DOWN 157)
-       (LEFT 158)
-       (RIGHT 159))
+(CONSTANTS (\WSUP 156)
+       (\WSDOWN 157)
+       (\WSLEFT 158)
+       (\WSRIGHT 159))
 )
 )
 (DECLARE%: DOEVAL@COMPILE DONTCOPY
@@ -219,6 +230,8 @@
 
 (RPAQ? WHEELSCROLLDELTA
 20)
 
+(RPAQ? HWHEELSCROLLDELTA
 NIL)
+
 (RPAQ? WHEELSCROLLSETTLETIME
 50)
 
 (RPAQ? \WHEELSCROLLINPROGRESS
 NIL)
@@ -229,6 +242,6 @@
 (ENABLEWHEELSCROLL
 T)
 )
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1575 9814 (ENABLEWHEELSCROLL 1585 . 5542) (WHEELSCROLL 5544 . 8080) (WHEELSCROLL.DOIT 
-8082 . 8718) (INSTALL-WHEELSCROLL 8720 . 9535) (LISPINTERRUPTS.WHEELSCROLL 9537 . 9812)))))
+  (FILEMAP (NIL (1636 10642 (ENABLEWHEELSCROLL 1646 . 5903) (WHEELSCROLL 5905 . 8506) (WHEELSCROLL.DOIT 
+8508 . 9144) (INSTALL-WHEELSCROLL 9146 . 10363) (LISPINTERRUPTS.WHEELSCROLL 10365 . 10640)))))
 STOP

lispusers/WHEELSCROLL.TXT

@@ -2,7 +2,7 @@ lispusers/WHEELSCROLL
 
 Written by Ron Kaplan,  February 2021.
 
-This small file adds the ability to scroll (scrollable) windows by rotating the wheel on a wheel mouse or by moving fingers on a track pad.
+This small file adds the ability to scroll (scrollable) windows by rotating the wheel on a wheel mouse or by moving (2?) fingers on a track pad.
 
 The capability is enabled when WHEELSCROLL.LCOM is loaded.
 
@@ -13,11 +13,16 @@ It is toggled on and off by
 The scrolling speed is controlled by the variable
 
 WHEELSCROLLDELTA (initially 20)
-	The number of points to scroll for each click of the wheel.  Higher values give faster scrolling.  A negative value reverses the scrolling direction.
+	The number of points to scroll for each click of the wheel.  Higher values give faster scrolling.  A negative value reverses the scrolling direction.  
+
+HWHEELSCROLLDELTA (initial NIL)
+	If non-NIL, then this is the delta used for horizontal scrolling.
 
 Implementation:
 
-Lisp receives a key transition on PAD1 or PAD2 for vertical scrolling when the wheel rotates and no other keys are down.  (ENABLEWHEELSCROLL T) modifies the keyaction table that maps these to characters 520 and 521, and those characters are defined as interrupts that invoke the scrolling action.  (ENABLEWHEELSCROLL NIL) causes PAD1 and PAD2 to be ignored.
+Lisp receives a key transition on PAD1 or PAD2 for vertical scrolling when the wheel rotates and no other keys are down.  (ENABLEWHEELSCROLL T) modifies the keyaction table so that it maps these transitions to characters 156 and 157. Those characters are defined as interrupts that invoke the vertical scrolling action.  For horizontal scrolling sideways pushes of a wheel (if it has that) produce transitions on PAD4 and PAD5, which map to interrupt-characters 158 and 159. (156-159 are the highest  right-panel characters of character-set 0 that correspond to left-panel control characters, so typically have no other conflicting meaning.)
+
+(ENABLEWHEELSCROLL NIL) causes PAD1, PAD2, PAD4, and PAD5 to be ignored.
 
 Current negative features:
 
@@ -25,4 +30,4 @@ Current negative features:
 
 We need to develop a strategy, either in Lisp, Maiko, or X, to discriminate intended middle-button pushes from intended scrolling.  This is not an issue for track-pad scrolling.
 
-2. When the wheel is rotated over a window that partially occludes a Tedit window with a caret blinking in its unoccluded region, both the target window and the Tedit window may scroll.
+2. When the wheel is rotated over a window that partially occludes a Tedit window with a caret blinking in its unoccluded region, both the target window and the partially obscured Tedit window may scroll.

lispusers/comparetext

@@ -1,78 +1,74 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-
(FILECREATED "23-Dec-98 17:05:12" {DSK}<project>medley3.5>lispusers>comparetext.;3
 39844  
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-      changes to%:  (FNS IMCOMPARE.HASH IMCOMPARE.COLLECT.HASH.CHUNKS)
-                    (VARS COMPARETEXTCOMS)
+
(FILECREATED "22-Dec-2021 10:37:46" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;20
 39405  
 
-      previous date%: "18-Nov-93 14:43:00" {DSK}<project>medley3.5>lispusers>comparetext.;1)
+      :CHANGES-TO (FNS IMCOMPARE.COLLECT.HASH.CHUNKS COMPARETEXT)
+                  (RECORDS IMCOMPARE.CHUNK)
+
+      :PREVIOUS-DATE "19-Dec-2021 12:45:35" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>comparetext.;19)
 
 
 (* ; "
-Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation.  All rights reserved.
+Copyright (c) 1984-1985, 1993, 1998 by Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT COMPARETEXTCOMS)
 
 (RPAQQ COMPARETEXTCOMS

-       ((DECLARE%: EVAL@COMPILE (FILES (LOADCOMP)
-                                       GRAPHER))
-        (FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS 
+       ((FNS COMPARETEXT IMCOMPARE.BOXNODE IMCOMPARE.CHUNKS IMCOMPARE.COLLECT.HASH.CHUNKS 
              IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH IMCOMPARE.FIND.TEDIT.TEXT.OBJECT IMCOMPARE.HASH
              IMCOMPARE.LEFTBUTTONFN IMCOMPARE.LENGTHEN.ATOM IMCOMPARE.MERGE.CONNECTED.CHUNKS 
              IMCOMPARE.MERGE.UNCONNECTED.CHUNKS IMCOMPARE.MIDDLEBUTTONFN IMCOMPARE.SHOW.DIST 
              IMCOMPARE.UPDATE.SYMBOL.TABLE)
         (P (MOVD 'COMPARETEXT 'IMCOMPARE))
-        (VARS (IMCOMPARE.LAST.NODE NIL)
-              (IMCOMPARE.LAST.GRAPH.WINDOW NIL)
-              (IMCOMPARE.HASH.TYPE.MENU NIL))
+        (INITVARS (IMCOMPARE.LAST.NODE NIL)
+               (IMCOMPARE.LAST.GRAPH.WINDOW NIL))
         (RECORDS IMCOMPARE.CHUNK IMCOMPARE.SYMB)
-        (FILES GRAPHER)))
-(DECLARE%: EVAL@COMPILE 
-
-(FILESLOAD (LOADCOMP)
-       GRAPHER)
-)
+        (FILES (SYSLOAD)
+               GRAPHER)
+        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                GRAPHER))))
 (DEFINEQ
 
 (COMPARETEXT

-  [LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION)

+  [LAMBDA (NEWFILENAME OLDFILENAME HASH.TYPE GRAPH.REGION FILELABELS)
+                                                             (* ; "Edited 22-Dec-2021 10:35 by rmk")

+                                                             (* ; "Edited 15-Dec-2021 16:23 by rmk")

+                                                             (* ; "Edited 13-Dec-2021 12:21 by rmk")

+                                                             (* ; "Edited  8-Nov-2021 08:44 by rmk:")

                                                              (* mjs " 8-Jan-84 21:06")

 
-         (* Compares the two files, and produces a graph showing their corresponding 
-
       chunks. The courseness of the "chunking" is determined by HASH.TYPE, which may 
-
       be PARA, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
-
       The file difference graph is displayed at GRAPHREGION.
-
       If GRAPH.REGION = NIL, the user is asked to specify a region.
-
       If GRAPH.REGION = T, a standard region is used.)

+    (* ;; "Compares the two files, and produces a graph showing their corresponding chunks.  The courseness of the 'chunking' is determined by HASH.TYPE, which may be PARA, LINE, or WORD.  HASH.TYPE = NIL defaults to PARA.  The file difference graph is displayed at GRAPHREGION.  If GRAPH.REGION = NIL, the user is asked to specify a region.  If GRAPH.REGION = T, a standard region is used.")

 
-    (PROG ((NEWFILE (FINDFILE NEWFILENAME T))
-           (OLDFILE (FINDFILE OLDFILENAME T)))
-          (if
 (AND OLDFILE NEWFILE)
-              then
                                       (* compare the two "chunks" 
-
                                                           consisting of the entire text of the 
-
                                                           two files)

-                    (IMCOMPARE.CHUNKS
 (create
 IMCOMPARE.CHUNK
-                                                 FILENAME _ NEWFILE
-                                                 FILEPTR _ 0
-                                                 CHUNKLENGTH _ (GETFILEINFO NEWFILE 'LENGTH))
-                           (create
 IMCOMPARE.CHUNK
-                                  FILENAME _ OLDFILE
-                                  FILEPTR _ 0
-                                  CHUNKLENGTH _ (GETFILEINFO OLDFILE 'LENGTH))
-                           HASH.TYPE
-                           (if
 (EQ GRAPH.REGION T)
-                               then
 (create
 REGION
-                                               LEFT _ 25
-                                               BOTTOM _ 25
-                                               WIDTH _ 500
-                                               HEIGHT _ 150)
-                             elseif
 GRAPH.REGION
-                             else
 (CLRPROMPT)
-                                   (printout PROMPTWINDOW 
-                                          "Please specify a window for the file difference graph" T)
-                                   (GETREGION)))
-            else
 (printout T "Can't find both files: " NEWFILENAME " & " OLDFILENAME 
-                            " --- IMCOMPARE aborted" T])
+    (SELECTQ HASH.TYPE
+        ((PARA LINE WORD))
+        (NIL (SETQ HASH.TYPE 'PARA))
+        (ERROR (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)))
+    (LET ((NEWFILE (FINDFILE NEWFILENAME T))
+          (OLDFILE (FINDFILE OLDFILENAME T)))
+         (CL:UNLESS (AND OLDFILE NEWFILE)
+             (ERROR "Can't find both files" (LIST NEWFILENAME OLDFILENAME)))
+         (IMCOMPARE.CHUNKS
 (create
 IMCOMPARE.CHUNK
+                                  FILENAME _ NEWFILE
+                                  FILEPTR _ 0)
+                (create
 IMCOMPARE.CHUNK
+                       FILENAME _ OLDFILE
+                       FILEPTR _ 0)
+                HASH.TYPE
+                (if
 (EQ GRAPH.REGION T)
+                    then
 (create
 REGION
+                                LEFT _ 25
+                                BOTTOM _ 25
+                                WIDTH _ 500
+                                HEIGHT _ 150)
+                  elseif
 GRAPH.REGION
+                  else
 (CLRPROMPT)
+                       (printout PROMPTWINDOW "Please specify a window for the file difference graph"
+                              T)
+                       (GETREGION))
+                FILELABELS])
 
 (IMCOMPARE.BOXNODE

   [LAMBDA (NODE WINDOW)
                                  (* rmk%: "14-Dec-84 13:40")

@@ -86,401 +82,345 @@ Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation.  All rights reserved.
               (SETQ IMCOMPARE.LAST.GRAPH.WINDOW WINDOW])
 
 (IMCOMPARE.CHUNKS

-  [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION)

+  [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION FILELABELS)
+                                                             (* ; "Edited 18-Dec-2021 13:21 by rmk")

+                                                             (* ; "Edited 15-Dec-2021 16:28 by rmk")

+                                                             (* ; "Edited 13-Dec-2021 12:32 by rmk")

                                                              (* rmk%: " 8-Sep-84 00:06")

 
-         (* this is the main text-comparison function.
-
       It compares the text in the two chunks <which may be small pieces of files, or 
-
       entire files> and produces a graph showing how the sub-chunks of the two main 
-
       chunks are related. The two main chunks may be in the same file, and the file 
-
       may actually be an open Tedit textstream.
-
       The main chunks are broken down according to HASH.TYPE, which may be PARA 
-
       <chunk by paragraph>, LINE, or WORD. HASH.TYPE = NIL defaults to PARA.
-
       The file difference graph is displayed at GRAPH.REGION.)

+    (* ;; "This is the main text-comparison function.  It compares the text in the two chunks <which may be small pieces of files, or entire files> and produces a graph showing how the sub-chunks of the two main chunks are related.  The two main chunks may be in the same file, and the file may actually be an open Tedit textstream.  The main chunks are broken down according to HASH.TYPE, which may be PARA <chunk by paragraph>, LINE, WORD,  or  PARA.  The file difference graph is displayed at GRAPH.REGION.")

 
-         (* this text comparison algorithm is originally from the article 
-
       "A Technique for Isolating Differences Between Files" by Paul Heckel, in CACM, 
-
       V21, %#4, April 1978 --- major difference is that I use lists instead of arrays)

+    (* ;; "This text comparison algorithm is originally from the article 'A Technique for Isolating Differences Between Files' by Paul Heckel, in CACM, V21, #4, April 1978 --- major difference is that I use lists instead of arrays")

 
-    (PROG ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
-           NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST)
+    (* ;; "")

 
-         (* * collect lists of chunks from each of the main chunks, dividing them 
-
       according to HASH.TYPE)

+    (* ;; "Collect lists of chunks from each of the main chunks, dividing them according to HASH.TYPE.  We start with whole-file chunks to provide the interface that the")

 
-          (SETQ NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS
 NEWFILE.SPEC.CHUNK HASH.TYPE))
-          (SETQ OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS
 OLDFILE.SPEC.CHUNK HASH.TYPE))
+    (LET ((CHUNK.SYMBOL.TABLE (HASHARRAY 500))
+          (NEWFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS
 NEWFILE.SPEC.CHUNK HASH.TYPE))
+          (OLDFILE.CHUNK.LIST (IMCOMPARE.COLLECT.HASH.CHUNKS
 OLDFILE.SPEC.CHUNK HASH.TYPE)))
 
-         (* * update the chunk symbol table. For each hash value, this table records the 
-
       number of "new" chunks with that hash value, the number of "old" chunks with 
-
       that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD chunk 
-
       itself>.)

+         (* ;; "Update the chunk symbol table.  For each hash value, this table records the number of 'new' chunks with that hash value, the number of 'old' chunks with that value, and a pointer to the place in OLD.CHUNK.LIST <not to an OLD c hunk itself>.")

 
-          (IMCOMPARE.UPDATE.SYMBOL.TABLE
 NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
-          (IMCOMPARE.UPDATE.SYMBOL.TABLE
 OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
+         (IMCOMPARE.UPDATE.SYMBOL.TABLE
 NEWFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE NIL)
+         (IMCOMPARE.UPDATE.SYMBOL.TABLE
 OLDFILE.CHUNK.LIST CHUNK.SYMBOL.TABLE T)
 
-         (* * For every new chunk whose hash value matches EXACTLY ONE old chunk's 
-
       value, "connect" it to the old chunk by setting the new chunk's OTHERCHUNK 
-
       field to point to the appropriate place in the old chunk list <not the old 
-
       chunk directly>. Also, make sure that OTHERCHUNK of the matching old chunk is 
-
       non-NIL, so that unconnected old chunks will be merged correctly.)

+         (* ;; "For every new chunk whose hash value matches EXACTLY ONE old chunk's value, 'connect' it to the old chunk by setting the new chunk's OTHERCHUNK field to point to the appropriate place in the old chunk list <not the old chunk directly>.  Also, make sure that OTHERCHUNK of the matching old chunk is non-NIL, so that unconnected old chunks will be merged correctly.")

 
-          (for
 NEW.CHUNK in
 NEWFILE.CHUNK.LIST bind
 SYMB
-             do
 (SETQ SYMB (GETHASH (fetch
 (IMCOMPARE.CHUNK HASHVALUE) of
 NEW.CHUNK)
-                                      CHUNK.SYMBOL.TABLE))
-                   (if
 (AND (EQ 1 (fetch
 (IMCOMPARE.SYMB NEWCOUNT) of
 SYMB))
-                                (EQ 1 (fetch
 (IMCOMPARE.SYMB OLDCOUNT) of
 SYMB)))
-                       then
 (replace
 (IMCOMPARE.CHUNK OTHERCHUNK) of
 NEW.CHUNK
-                                   with
 (fetch
 (IMCOMPARE.SYMB OLDPTR) of
 SYMB))
-                             (replace
 (IMCOMPARE.CHUNK OTHERCHUNK)
-                                of
 (CAR (fetch
 (IMCOMPARE.SYMB OLDPTR) of
 SYMB))
-                                with
 T)))
+         (for
 NEW.CHUNK in
 NEWFILE.CHUNK.LIST bind
 SYMB
+            do
 (SETQ SYMB (GETHASH (fetch
 (IMCOMPARE.CHUNK HASHVALUE) of
 NEW.CHUNK)
+                                 CHUNK.SYMBOL.TABLE))
+               (if
 (AND (EQ 1 (fetch
 (IMCOMPARE.SYMB NEWCOUNT) of
 SYMB))
+                        (EQ 1 (fetch
 (IMCOMPARE.SYMB OLDCOUNT) of
 SYMB)))
+                   then
 (replace
 (IMCOMPARE.CHUNK OTHERCHUNK) of
 NEW.CHUNK with
 (fetch
 (
+                                                                                       IMCOMPARE.SYMB
+                                                                                        OLDPTR)
+                                                                                   of
 SYMB))
+                        (replace
 (IMCOMPARE.CHUNK OTHERCHUNK) of
 (CAR (fetch
 (IMCOMPARE.SYMB OLDPTR)
+                                                                         of
 SYMB)) with
 T)))
 
-         (* * merge connected chunks forward)

+         (* ;; "Merge connected chunks forward")

 
-          (IMCOMPARE.MERGE.CONNECTED.CHUNKS
 NEWFILE.CHUNK.LIST NIL)
+         (IMCOMPARE.MERGE.CONNECTED.CHUNKS
 NEWFILE.CHUNK.LIST NIL)
 
-         (* * merge connected chunks backwards)

+         (* ;; "Merge connected chunks backwards")

 
-          (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
-          (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
-          (IMCOMPARE.MERGE.CONNECTED.CHUNKS
 NEWFILE.CHUNK.LIST T)
-          (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
-          (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
+         (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
+         (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
+         (IMCOMPARE.MERGE.CONNECTED.CHUNKS
 NEWFILE.CHUNK.LIST T)
+         (SETQ NEWFILE.CHUNK.LIST (DREVERSE NEWFILE.CHUNK.LIST))
+         (SETQ OLDFILE.CHUNK.LIST (DREVERSE OLDFILE.CHUNK.LIST))
 
-         (* * merge unconnected chunks)

+         (* ;; "Merge unconnected chunks")

 
-          (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
 NEWFILE.CHUNK.LIST)
-          (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
 OLDFILE.CHUNK.LIST)
+         (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
 NEWFILE.CHUNK.LIST)
+         (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS
 OLDFILE.CHUNK.LIST)
 
-         (* * now, the file comparison is complete.
-
       Format and display the file difference graph)

+         (* ;; "The file comparison is complete.  Format and display the file difference graph")

 
-          (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
 NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK 
-                 HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST])
+         (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH
 NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE 
+                GRAPH.REGION NEWFILE.CHUNK.LIST OLDFILE.CHUNK.LIST FILELABELS])
 
 (IMCOMPARE.COLLECT.HASH.CHUNKS

-  [LAMBDA (CHUNK HASH.TYPE)
                              (* ; "Edited 23-Dec-98 16:54 by rmk:")

-                                                             (* mjs " 8-Jan-84 20:57")

+  [LAMBDA (CHUNK HASH.TYPE)                                  (* ; "Edited 22-Dec-2021 10:37 by rmk")

+                                                             (* ; "Edited 13-Dec-2021 16:32 by rmk")

+                                                             (* ; "Edited 23-Dec-98 16:54 by rmk:")

+                                                             (* mjs " 8-Jan-84 20:57")

 
-         (* * returns a list of the chunks in CHUNK as hashed of type HASH.TYPE)

+(* ;;; "Returns a list of the chunks inside CHUNK as hashed of type HASH.TYPE.  Presumably CHUNK is is higher on the ranking PARA > LINE >.  WORD.  The initial CHUNK covers the whole file, middle-mouse refinement-chunks cover only subsections.")

 
-    (LET (STREAM END.OF.CHUNK.PTR CHUNK.LIST)
-         [SETQ STREAM (OPENSTREAM (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 CHUNK)
-                             'INPUT
-                             'OLD
-                             '((TYPE TEXT]
-         (SETFILEPTR STREAM (fetch
 (IMCOMPARE.CHUNK FILEPTR) of
 CHUNK))
-         (SETQ END.OF.CHUNK.PTR (IPLUS (fetch
 (IMCOMPARE.CHUNK FILEPTR) of
 CHUNK)
-                                       (fetch
 (IMCOMPARE.CHUNK CHUNKLENGTH) of
 CHUNK)))
-         (SETQ CHUNK.LIST (until
 (IGEQ (GETFILEPTR STREAM)
-                                           END.OF.CHUNK.PTR) collect
 (IMCOMPARE.HASH
 STREAM 
-                                                                                END.OF.CHUNK.PTR 
-                                                                                HASH.TYPE)))
-         (CLOSEF STREAM)
-         CHUNK.LIST])
+    (* ;; "It is overkill to open raw text streams as TEDIT stream.  So we open, test for TEDIT and if so, close and reoopen.  TEDIT may not yet honor external formats other than XCCS for rawtext files.")

+
+    (BIND
 (FILENAME _ (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 CHUNK))
+          STREAM ENDPOS FIRST
 (SETQ STREAM (OPENSTREAM FILENAME 'INPUT 'OLD))
+                              (CL:WHEN (\TEDIT.FORMATTEDP1 STREAM)
+                                  (CLOSEF STREAM)            (* ; 
+
                                               "The OBJECTCHAR is produced in place of image objects")

+                                  [SETQ STREAM (OPENTEXTSTREAM FILENAME NIL NIL NIL
+                                                      `(OBJECTBYTE ,(CHARCODE NULL])
+                              (SETFILEINFO STREAM 'EOL 'ANY)
+                              (CL:UNLESS (fetch
 (IMCOMPARE.CHUNK CHUNKLENGTH) of
 CHUNK)
+
+                                  (* ;; 
+
                         "For TEDIT files, the character length isn't known until after text-opening")

+
+                                  (REPLACE
 (IMCOMPARE.CHUNK CHUNKLENGTH) of
 CHUNK
+                                     WITH
 (GETFILEINFO STREAM 'LENGTH)))
+                              (SETFILEPTR STREAM (fetch
 (IMCOMPARE.CHUNK FILEPTR) of
 CHUNK))
+                              (SETQ ENDPOS (IPLUS (fetch
 (IMCOMPARE.CHUNK FILEPTR) of
 CHUNK)
+                                                  (fetch
 (IMCOMPARE.CHUNK CHUNKLENGTH) of
 CHUNK)))
+       WHILE
 (SETQ CHUNK (IMCOMPARE.HASH
 STREAM HASH.TYPE ENDPOS))
+       COLLECT
 (REPLACE
 FILENAME OF
 CHUNK WITH
 FILENAME)
+             CHUNK FINALLY
 (CLOSEF STREAM])
 
 (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH

   [LAMBDA (NEWFILE.SPEC.CHUNK OLDFILE.SPEC.CHUNK HASH.TYPE GRAPH.REGION NEWFILE.CHUNK.LIST 
-                 OLDFILE.CHUNK.LIST)
                     (* mjs "11-Jul-85 09:10")

+                 OLDFILE.CHUNK.LIST FILELABELS)              (* ; "Edited 18-Dec-2021 13:16 by rmk")

+                                                             (* ; "Edited 16-Dec-2021 10:48 by rmk")

+                                                             (* ; "Edited 13-Dec-2021 12:19 by rmk")

+                                                             (* mjs "11-Jul-85 09:10")

 
-         (* * format and display the graph)

+(* ;;; "format and display the graph")

 
-    (PROG ((NEWFILENAME (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 NEWFILE.SPEC.CHUNK))
-           (OLDFILENAME (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 OLDFILE.SPEC.CHUNK))
-           (OLD.CHUNK.NODE.FROM.NODES NIL)
-           (BORDERSIZE 1)
-           GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD 
-           YCOORD.INCREMENT DIFF.GRAPH)
+    (LET ((NEWFILENAME (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 NEWFILE.SPEC.CHUNK))
+          (OLDFILENAME (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 OLDFILE.SPEC.CHUNK))
+          NEWFILELABEL OLDFILELABEL (OLD.CHUNK.NODE.FROM.NODES NIL)
+          (BORDERSIZE 1)
+          GRAPH.WINDOW NEW.CHUNK.NODES OLD.CHUNK.NODES OLD.CHUNK.XCOORD NEW.CHUNK.XCOORD 
+          YCOORD.INCREMENT DIFF.GRAPH)
 
-         (* * set up GRAPH.WINDOW. This is done first so you can get the width and 
-
       height of strings to be printed in the window.)

+(* ;;; "set up GRAPH.WINDOW.  This is done first so you can get the width and height of strings to be printed in the window.")

 
-          [SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
-                                                          (SELECTQ HASH.TYPE
-                                                              ((PARA NIL) 
-                                                                   "Paragraph")
-                                                              (LINE "Line")
-                                                              (WORD "Word")
-                                                              (SHOULDNT]
-          (WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
-          [WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
-                                                           (if
 (EQ WINDOW 
-                                                                       IMCOMPARE.LAST.GRAPH.WINDOW)
-                                                               then
 (SETQ 
-                                                                         IMCOMPARE.LAST.GRAPH.WINDOW
-                                                                         NIL)
-                                                                     (SETQ IMCOMPARE.LAST.NODE NIL]
-          (SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILENAME GRAPH.WINDOW)
-                                        2))
-          [SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
-                                                                          (IQUOTIENT (STRINGWIDTH
-                                                                                      OLDFILENAME 
-                                                                                      GRAPH.WINDOW)
-                                                                                 2)
-                                                                          20]
-          [SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
-                                                (fetch
 (REGION HEIGHT) of
 (STRINGREGION
-                                                                                   NEWFILENAME 
-                                                                                   GRAPH.WINDOW]
+         (SETQ NEWFILELABEL (OR (CAR (LISTP FILELABELS))
+                                NEWFILENAME))
+         (SETQ OLDFILELABEL (OR (CADR (LISTP FILELABELS))
+                                OLDFILENAME))
+         [SETQ GRAPH.WINDOW (CREATEW GRAPH.REGION (CONCAT "Text File Differences, hashed by "
+                                                         (SELECTQ HASH.TYPE
+                                                             ((PARA NIL) 
+                                                                  "Paragraph")
+                                                             (LINE "Line")
+                                                             (WORD "Word")
+                                                             (SHOULDNT]
+         (WINDOWPROP GRAPH.WINDOW 'IMPARE.HASH.TYPE HASH.TYPE)
+         [WINDOWADDPROP GRAPH.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
+                                                          (if
 (EQ WINDOW IMCOMPARE.LAST.GRAPH.WINDOW)
+                                                              then
 (SETQ IMCOMPARE.LAST.GRAPH.WINDOW
+                                                                    NIL)
+                                                                   (SETQ IMCOMPARE.LAST.NODE NIL]
+         (SETQ NEW.CHUNK.XCOORD (IQUOTIENT (STRINGWIDTH NEWFILELABEL GRAPH.WINDOW)
+                                       2))
+         [SETQ OLD.CHUNK.XCOORD (IPLUS NEW.CHUNK.XCOORD (IMAX 100 (IPLUS NEW.CHUNK.XCOORD
+                                                                         (IQUOTIENT (STRINGWIDTH
+                                                                                     OLDFILELABEL 
+                                                                                     GRAPH.WINDOW)
+                                                                                2)
+                                                                         20]
+         [SETQ YCOORD.INCREMENT (IMINUS (IPLUS 2 (ITIMES 2 BORDERSIZE)
+                                               (fetch
 (REGION HEIGHT) of
 (STRINGREGION NEWFILELABEL 
+                                                                                GRAPH.WINDOW]
 
-         (* * collect new-chunk graph nodes, while accumulating 
-
       OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks)

+(* ;;; "collect new-chunk graph nodes, while accumulating OLD.CHUNK.NODE.FROM.NODES, assoc list from old-chunks to new-chunks")

 
-          (SETQ NEW.CHUNK.NODES (for
 NEW.CHUNK in
 NEWFILE.CHUNK.LIST as
 Y from
 
-                                                                                     YCOORD.INCREMENT
-                                   by
 YCOORD.INCREMENT bind
 CORRESPONDING.OLD.CHUNK
-                                   collect
 (SETQ CORRESPONDING.OLD.CHUNK
-                                                (CAR (fetch
 (IMCOMPARE.CHUNK OTHERCHUNK)
-                                                        of
 NEW.CHUNK)))
-                                         (if
 CORRESPONDING.OLD.CHUNK
-                                             then
 (SETQ OLD.CHUNK.NODE.FROM.NODES
-                                                       (CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
-                                                             OLD.CHUNK.NODE.FROM.NODES))) 
-                                                             (* Start out with 2 point white 
-
                                                           border, so we can invert it)

-                                         (NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM

-                                                                (PACK* (fetch
 (IMCOMPARE.CHUNK
-                                                                                   FILEPTR)
-                                                                          of
 NEW.CHUNK)
-                                                                       ":"
-                                                                       (fetch
 (IMCOMPARE.CHUNK
-                                                                                   CHUNKLENGTH)
-                                                                          of
 NEW.CHUNK))
-                                                                12)
-                                                (create
 POSITION
-                                                       XCOORD _ NEW.CHUNK.XCOORD
-                                                       YCOORD _ Y)
-                                                (if
 CORRESPONDING.OLD.CHUNK
-                                                    then
 (LIST CORRESPONDING.OLD.CHUNK)
-                                                  else
 NIL)
-                                                NIL DEFAULTFONT -2)))
-          (SETQ OLD.CHUNK.NODES (for
 OLD.CHUNK in
 OLDFILE.CHUNK.LIST as
 Y from
 
-                                                                                     YCOORD.INCREMENT
-                                   by
 YCOORD.INCREMENT bind
 CORRESPONDING.NEW.CHUNK
-                                   collect
 (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK 
+         (SETQ NEW.CHUNK.NODES (for
 NEW.CHUNK in
 NEWFILE.CHUNK.LIST as
 Y from
 YCOORD.INCREMENT
+                                  by
 YCOORD.INCREMENT bind
 CORRESPONDING.OLD.CHUNK
+                                  collect
 (SETQ CORRESPONDING.OLD.CHUNK (CAR (fetch
 (IMCOMPARE.CHUNK
+                                                                                     OTHERCHUNK)
+                                                                                of
 NEW.CHUNK)))
+                                        (if
 CORRESPONDING.OLD.CHUNK
+                                            then
 (SETQ OLD.CHUNK.NODE.FROM.NODES
+                                                  (CONS (CONS CORRESPONDING.OLD.CHUNK NEW.CHUNK)
+                                                        OLD.CHUNK.NODE.FROM.NODES))) 
+                                                             (* ; 
+
                                           "Start out with 2 point white border, so we can invert it")

+                                        (NODECREATE NEW.CHUNK (IMCOMPARE.LENGTHEN.ATOM

+                                                               (PACK* (fetch
 (IMCOMPARE.CHUNK FILEPTR
+                                                                                    ) of
 NEW.CHUNK)
+                                                                      ":"
+                                                                      (fetch
 (IMCOMPARE.CHUNK 
+                                                                                    CHUNKLENGTH)
+                                                                         of
 NEW.CHUNK))
+                                                               12)
+                                               (create
 POSITION
+                                                      XCOORD _ NEW.CHUNK.XCOORD
+                                                      YCOORD _ Y)
+                                               (if
 CORRESPONDING.OLD.CHUNK
+                                                   then
 (LIST CORRESPONDING.OLD.CHUNK)
+                                                 else
 NIL)
+                                               NIL DEFAULTFONT -2)))
+         (SETQ OLD.CHUNK.NODES (for
 OLD.CHUNK in
 OLDFILE.CHUNK.LIST as
 Y from
 YCOORD.INCREMENT
+                                  by
 YCOORD.INCREMENT bind
 CORRESPONDING.NEW.CHUNK
+                                  collect
 (SETQ CORRESPONDING.NEW.CHUNK (CDR (ASSOC OLD.CHUNK 
                                                                             OLD.CHUNK.NODE.FROM.NODES
-                                                                                         )))
-                                         (NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM

-                                                                (PACK* (fetch
 (IMCOMPARE.CHUNK
-                                                                                   FILEPTR)
-                                                                          of
 OLD.CHUNK)
-                                                                       ":"
-                                                                       (fetch
 (IMCOMPARE.CHUNK
-                                                                                   CHUNKLENGTH)
-                                                                          of
 OLD.CHUNK))
-                                                                12 "-")
-                                                (create
 POSITION
-                                                       XCOORD _ OLD.CHUNK.XCOORD
-                                                       YCOORD _ Y)
-                                                NIL
-                                                (if
 CORRESPONDING.NEW.CHUNK
-                                                    then
 (LIST CORRESPONDING.NEW.CHUNK)
-                                                  else
 NIL)
-                                                DEFAULTFONT -2)))
-          (SETQ DIFF.GRAPH (create
 GRAPH
-                                  DIRECTEDFLG _ T
-                                  SIDESFLG _ T
-                                  GRAPHNODES _
-                                  (NCONC (LIST (NODECREATE NEWFILE.SPEC.CHUNK NEWFILENAME
-                                                      (create
 POSITION
-                                                             XCOORD _ NEW.CHUNK.XCOORD
-                                                             YCOORD _ 0)
-                                                      NIL NIL DEFAULTFONT -2))
-                                         NEW.CHUNK.NODES
-                                         (LIST (NODECREATE OLDFILE.SPEC.CHUNK OLDFILENAME
-                                                      (create
 POSITION
-                                                             XCOORD _ OLD.CHUNK.XCOORD
-                                                             YCOORD _ 0)
-                                                      NIL NIL DEFAULTFONT -2))
-                                         OLD.CHUNK.NODES)))
-          (SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
-                 (FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
-                 T NIL])
+                                                                                    )))
+                                        (NODECREATE OLD.CHUNK (IMCOMPARE.LENGTHEN.ATOM

+                                                               (PACK* (fetch
 (IMCOMPARE.CHUNK FILEPTR
+                                                                                    ) of
 OLD.CHUNK)
+                                                                      ":"
+                                                                      (fetch
 (IMCOMPARE.CHUNK 
+                                                                                    CHUNKLENGTH)
+                                                                         of
 OLD.CHUNK))
+                                                               12 "-")
+                                               (create
 POSITION
+                                                      XCOORD _ OLD.CHUNK.XCOORD
+                                                      YCOORD _ Y)
+                                               NIL
+                                               (if
 CORRESPONDING.NEW.CHUNK
+                                                   then
 (LIST CORRESPONDING.NEW.CHUNK)
+                                                 else
 NIL)
+                                               DEFAULTFONT -2)))
+         (SETQ DIFF.GRAPH (create
 GRAPH
+                                 DIRECTEDFLG _ T
+                                 SIDESFLG _ T
+                                 GRAPHNODES _
+                                 (NCONC (LIST (NODECREATE NEWFILENAME NEWFILELABEL
+                                                     (create
 POSITION
+                                                            XCOORD _ NEW.CHUNK.XCOORD
+                                                            YCOORD _ 0)
+                                                     NIL NIL DEFAULTFONT -2))
+                                        NEW.CHUNK.NODES
+                                        (LIST (NODECREATE OLDFILENAME OLDFILELABEL
+                                                     (create
 POSITION
+                                                            XCOORD _ OLD.CHUNK.XCOORD
+                                                            YCOORD _ 0)
+                                                     NIL NIL DEFAULTFONT -2))
+                                        OLD.CHUNK.NODES)))
+         (GRAPHERPROP DIFF.GRAPH 'FILELABELS (LIST NEWFILELABEL OLDFILELABEL))
+                                                             (* ; 
+
                                                    "So Middle mouse graphs can get the right labels")

+         (GRAPHERPROP DIFF.GRAPH 'HASH.TYPE HASH.TYPE)
+         (SHOWGRAPH DIFF.GRAPH GRAPH.WINDOW (FUNCTION IMCOMPARE.LEFTBUTTONFN)
+                (FUNCTION IMCOMPARE.MIDDLEBUTTONFN)
+                T NIL])
 
 (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT

-  [LAMBDA (FILE)
                                         (* mjs " 2-Jan-84 16:19")

+  [LAMBDA (FILE)                                             (* ; "Edited 16-Dec-2021 08:40 by rmk")

+                                                             (* mjs " 2-Jan-84 16:19")

 
-         (* returns the Tedit text object of the first Tedit window which is currently 
-
       looking at FILE, if there is one. Returns NIL if none is found.)

+    (* ;; "returns the Tedit text object of the first Tedit window which is currently looking at FILE, if there is one.  Returns NIL if none is found.")

 
-    (PROG ((TEDIT.TEXT.OBJECT NIL))
-          (for
 X in
 (OPENWINDOWS) bind
 POSS.TOBJ POSS.FILENAME
-             when
 (SETQ POSS.TOBJ (WINDOWPROP X 'TEXTOBJ)) repeatuntil
 TEDIT.TEXT.OBJECT
-             do
 (SETQ POSS.FILENAME (FULLNAME (fetch
 (TEXTOBJ TXTFILE) of
 POSS.TOBJ)))
-                   (if
 (EQ FILE POSS.FILENAME)
-                       then
 (SETQ TEDIT.TEXT.OBJECT POSS.TOBJ)))
-          (RETURN TEDIT.TEXT.OBJECT])
+    (for
 W in
 (OPENWINDOWS) bind
 POSS.TOBJ when
 [AND (SETQ POSS.TOBJ (WINDOWPROP W 'TEXTOBJ))
+                                                     (EQ FILE (FULLNAME (fetch
 (TEXTOBJ TXTFILE)
+                                                                           of
 POSS.TOBJ]
+       unless
 (TEDIT.STREAMCHANGEDP POSS.TOBJ) do
 (RETURN POSS.TOBJ])
 
 (IMCOMPARE.HASH

-  [LAMBDA (STREAM EOF.PTR HASH.TYPE)
                     (* ; "Edited 23-Dec-98 16:58 by rmk:")

+  [LAMBDA (STREAM HASH.TYPE ENDPOS)                          (* ; "Edited 19-Dec-2021 09:07 by rmk")

+                                                             (* ; "Edited 15-Dec-2021 15:58 by rmk")

+                                                             (* ; "Edited 13-Dec-2021 16:35 by rmk")

+                                                             (* ; "Edited 23-Dec-98 16:58 by rmk:")

 
-         (* reads caracters from STREAM and creates a hash value for the "next" "chunk" 
-
       A chunk is a paragraph ending in two consecutive CRs <HASH.TYPE = NIL or PARA>, 
-
       a line ending in a CR <HASH.TYPE = LINE>, or a word ending in any white space 
-
       character space <HASH.TYPE = WORD>. In computing the hash value, white space is 
-
       ignored. IMCOMPARE.HASH automatically stops before reading char number EOF.PTR 
-
       Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the 
-
       beginning of the chunk, the length of the chunk, and the fullname of the stream)

+    (* ;; "IMCOMPARE.HASH automatically stops before reading char number EOF.PTR.")

 
-         (* Note%: Most of the time in COMPARETEXT is spent reading in and hashing 
-
       chunks, so this function was optimizes for speed, at the expense of length)

+    (* ;; "Returns an IMCOMPARE.CHUNK containing the hash value, the file pointer of the beginning of the chunk, the length of the chunk, and the fullname of the stream")

 
-    (PROG ((BEGIN.FILE.PTR (GETFILEPTR STREAM))
-           (EOLC (GETFILEINFO STREAM 'EOL))
-           (HASHNUM 0)
-           FILE.PTR C)
-          (SETQ FILE.PTR BEGIN.FILE.PTR)
-          (SELECTQ HASH.TYPE
-              ((NIL PARA) 
+    (* ;; "Note: Most of the time in COMPARETEXT is spent reading in and hashing chunks, so this function was optimizes for speed, at the expense of length")

 
-         (* Paragraph chunks end with two consecutive EOL's.
-
       In order to detect this without slowing down the gobbling of normal chars, 
-
       LAST.EOL.POS is set to the filepos of the last EOL detected.
-
       This is only checked when another EOL comes along.)

+    (LET ((STARTPOS (GETFILEPTR STREAM))
+          (HASHNUM 0)
+          C NBYTES)
+         (DECLARE
 (SPECVARS NBYTES))
+         (SETQ NBYTES (IDIFFERENCE ENDPOS STARTPOS))         (* ; 
+
                                            "\INCCODE counts down. We reach NBYTES only on the chunk")

 
-                   (PROG ((LAST.EOL.POS -5))
-                     loop
-                         (if
 (IGEQ FILE.PTR EOF.PTR)
-                             then
 (GO return))
-                         (SETQ FILE.PTR (ADD1 FILE.PTR))
-                         (SELCHARQ (SETQ C (BIN STREAM))
-                              (CR 
+         (* ;; "Don't hash on white space")

 
-         (* If this is the second consecutive CR, this is the end of the chunk.
-
       Otherwise, reset LAST.EOL.POS)

-
-                                  (SELECTQ EOLC
-                                      (CR (if
 (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
-                                              then
 (GO endchunk)
-                                            else
 (SETQ LAST.EOL.POS (GETFILEPTR STREAM))))
-                                      (CRLF (if
 (IGEQ FILE.PTR EOF.PTR)
-                                                then
 (GO return))
-                                            (SELCHARQ (\PEEKBIN STREAM T)
-                                                 (LF (SETQ FILE.PTR (ADD1 FILE.PTR))
-                                                     (BIN STREAM)
-                                                     (if
 (IEQP LAST.EOL.POS (IDIFFERENCE
-                                                                                 (GETFILEPTR STREAM)
-                                                                                 2))
-                                                         then
 (GO endchunk)
-                                                       else
 (SETQ LAST.EOL.POS (GETFILEPTR STREAM
-                                                                                          ))))
-                                                 NIL))
-                                      NIL))
-                              (LF [COND
-                                     ((EQ EOLC 'LF)
-                                      (if
 (IEQP LAST.EOL.POS (SUB1 (GETFILEPTR STREAM)))
-                                          then
 (GO endchunk)
-                                        else
 (SETQ LAST.EOL.POS (GETFILEPTR STREAM])
-                              ((SPACE TAB))
-                              (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
-                                                           1 16)
-                                                      1 16)
-                                                 1 16)))
-                         (GO loop)))
-              (LINE                                          (* Line chunks end on a single CR.)

-                    (PROG NIL
-                      loop
-                          (if
 (IGEQ FILE.PTR EOF.PTR)
-                              then
 (GO return))
-                          (SETQ FILE.PTR (ADD1 FILE.PTR))
-                          (SELCHARQ (SETQ C (BIN STREAM))
-                               (CR (SELECTQ EOLC
-                                       (CR (GO endchunk))
-                                       (LF)
-                                       (CRLF (if
 (IGEQ FILE.PTR EOF.PTR)
-                                                 then
 (GO return))
-                                             (SELCHARQ (\PEEKBIN STREAM T)
-                                                  (LF (SETQ FILE.PTR (ADD1 FILE.PTR))
-                                                      (BIN STREAM)
-                                                      (GO endchunk))
-                                                  NIL))
-                                       (SHOULDNT)))
-                               (LF (AND (EQ EOLC 'LF)
-                                        (GO endchunk)))
-                               ((SPACE TAB))
-                               (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
-                                                            1 16)
-                                                       1 16)
-                                                  1 16)))
-                          (GO loop)))
-              (WORD                                          (* word chunks end on any white 
-
                                                           space)

-                    (PROG NIL
-                      loop
-                          (if
 (IGEQ FILE.PTR EOF.PTR)
-                              then
 (GO return))
-                          (SETQ FILE.PTR (ADD1 FILE.PTR))
-                          (SELCHARQ (SETQ C (BIN STREAM))
-                               ((CR SPACE TAB LF) 
-                                    (GO endchunk))
-                               (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
-                                                            1 16)
-                                                       1 16)
-                                                  1 16)))
-                          (GO loop)))
-              (HELP (CONCAT "Unrecognize HASHTYPE " HASH.TYPE)
-                    "
-   Should be PARA, LINE, or WORD"))
-      endchunk
-                                                             (* flush all white space before next 
-
                                                           chunk)

-          (if
 (IGEQ FILE.PTR EOF.PTR)
-              then
 (GO return))
-          (SETQ FILE.PTR (ADD1 FILE.PTR))
-          (SELCHARQ (BIN STREAM)
-               ((CR SPACE TAB LF) 
-                    (GO endchunk))
-               (PROGN (SETQ FILE.PTR (SUB1 FILE.PTR))
-                      (SETFILEPTR STREAM FILE.PTR)))
-      return
-          (RETURN (create
 IMCOMPARE.CHUNK
-                         HASHVALUE _ HASHNUM
-                         FILEPTR _ BEGIN.FILE.PTR
-                         CHUNKLENGTH _ (IDIFFERENCE FILE.PTR BEGIN.FILE.PTR)
-                         FILENAME _ (FULLNAME STREAM])
+         (CL:WHEN (IGREATERP NBYTES 0)
+             (SELECTQ HASH.TYPE
+                 (PARA                                       (* ; 
+
                                                   "Paragraph chunks end with two consecutive EOL's.")

+                       (BIND
 EOLSEEN WHILE
 (IGREATERP NBYTES 0)
+                          DO
 (SELCHARQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
+                                  (EOL (CL:WHEN EOLSEEN (RETURN))
+                                       (SETQ EOLSEEN T)      (* ; "Skip the NIL SETQ below")

+                                       (GO $$ITERATE))
+                                  ((SPACE TAB))
+                                  (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
+                                                               1 16)
+                                                          1 16)
+                                                     1 16)))
+                             (SETQ EOLSEEN NIL)))
+                 (LINE                                       (* ; "Line chunks end on EOL.")

+                       [WHILE
 (IGREATERP NBYTES 0)
+                          DO
 (SELCHARQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
+                                  (EOL (RETURN))
+                                  ((SPACE TAB))
+                                  (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
+                                                               1 16)
+                                                          1 16)
+                                                     1 16])
+                 (WORD                                       (* ; 
+
                                                             "word chunks end on any white space")

+                       [WHILE
 (IGREATERP NBYTES 0)
+                          DO
 (SELECTQ (SETQ C (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES))
+                                 ((SPACE EOL TAB) 
+                                      (RETURN))
+                                 (SETQ HASHNUM (ROT (ROT (ROT (LOGXOR HASHNUM C)
+                                                              1 16)
+                                                         1 16)
+                                                    1 16])
+                 (SHOULDNT))                                 (* ; 
+
                                                            "flush all white space before next chunk")

+             (WHILE
 (IGREATERP NBYTES 0) DO
 (SELCHARQ (\INCCODE.EOLC STREAM NIL 'NBYTES NBYTES)
+                                                 ((EOL SPACE TAB))
+                                                 (RETURN)))
+             (CREATE
 IMCOMPARE.CHUNK
+                    HASHVALUE _ HASHNUM
+                    FILEPTR _ STARTPOS
+                    CHUNKLENGTH _ (IDIFFERENCE (GETFILEPTR STREAM)
+                                         STARTPOS)))])
 
 (IMCOMPARE.LEFTBUTTONFN

-  [LAMBDA (GNODE WINDOW)
                                 (* mjs " 2-Apr-85 14:21")

+  [LAMBDA (GNODE WINDOW)                                     (* ; "Edited 18-Dec-2021 13:02 by rmk")

+                                                             (* mjs " 2-Apr-85 14:21")

     (if
 GNODE
-        then
 (IMCOMPARE.BOXNODE
 GNODE WINDOW)
-              (PROG ((NODEID (fetch
 (GRAPHNODE NODEID) of
 GNODE))
-                     (FILEPTR 1)
-                     (CHUNKLENGTH 0)
-                     (TEDIT.TEXT.OBJECT NIL)
-                     FILE)
-                    (SETQ FILE (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 NODEID))
-                    (SETQ FILEPTR (fetch
 (IMCOMPARE.CHUNK FILEPTR) of
 NODEID))
-                    (SETQ CHUNKLENGTH (fetch
 (IMCOMPARE.CHUNK CHUNKLENGTH) of
 NODEID))
-                    (SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT
 FILE))
-                    (if
 TEDIT.TEXT.OBJECT
-                        then
 (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR 25))
-                                        0
-                                        'LEFT)
-                              (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
-                              (TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH 'LEFT)
-                              (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
-                              (TTY.PROCESS (WINDOWPROP (CAR (fetch
 (TEXTOBJ \WINDOW) of

-                                                                                         
-                                                                                    TEDIT.TEXT.OBJECT
-                                                                   ))
-                                                  'PROCESS))
-                      else
 (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH])
+        then
 (LET ((NODEID (fetch
 (GRAPHNODE NODEID) of
 GNODE)))
+                  (IF
 (FIXP (CAR NODEID))
+                      THEN
 (IMCOMPARE.BOXNODE
 GNODE WINDOW)
+                           [LET ((FILEPTR 1)
+                                 (CHUNKLENGTH 0)
+                                 (TEDIT.TEXT.OBJECT NIL)
+                                 FILE)
+                                (SETQ FILE (fetch
 (IMCOMPARE.CHUNK FILENAME) of
 NODEID))
+                                (SETQ FILEPTR (fetch
 (IMCOMPARE.CHUNK FILEPTR) of
 NODEID))
+                                (SETQ CHUNKLENGTH (fetch
 (IMCOMPARE.CHUNK CHUNKLENGTH) of
 NODEID))
+                                (SETQ TEDIT.TEXT.OBJECT (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT
 FILE))
+                                (if
 TEDIT.TEXT.OBJECT
+                                    then
 (TEDIT.SETSEL TEDIT.TEXT.OBJECT (IMAX 1 (IDIFFERENCE FILEPTR
+                                                                                        25))
+                                                0
+                                                'LEFT)
+                                         (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
+                                         (TEDIT.SETSEL TEDIT.TEXT.OBJECT FILEPTR CHUNKLENGTH
+                                                'LEFT)
+                                         (TEDIT.NORMALIZECARET TEDIT.TEXT.OBJECT)
+                                         (TTY.PROCESS (WINDOWPROP (CAR (fetch
 (TEXTOBJ \WINDOW)
+                                                                          of
 TEDIT.TEXT.OBJECT))
+                                                             'PROCESS))
+                                  else
 (TEDIT FILE NIL NIL (LIST 'SEL (LIST FILEPTR CHUNKLENGTH]
+                    ELSEIF
 (AND (LITATOM NODEID)
+                                (INFILEP NODEID))
+                      THEN
 
+                           (* ;; 
+
                           "A file name as a column header, do TEDIT on the whole file, no selection")

+
+                           (TEDIT-SEE NODEID)
+                    ELSE
 (SHOULDNT])
 
 (IMCOMPARE.LENGTHEN.ATOM

-  [LAMBDA (X MIN.LENGTH EXTENDER)
                        (* mjs "30-Dec-83 15:11")

+  [LAMBDA (X MIN.LENGTH EXTENDER)                            (* ; "Edited 13-Dec-2021 21:18 by rmk")

+                                                             (* mjs "30-Dec-83 15:11")

 
-         (* makes sure that the atom X is at least MIN.LENGTH characters long, by 
-
       concatinating the first character of EXTENDER
-
       (or space, if not given) to the front)

+    (* ;; "makes sure that the atom X is at least MIN.LENGTH characters long, by concatenating the first character of EXTENDER (or space, if not given) to the front")

 
-    (PROG ((C (CHCON X)))
-          (SETQ EXTENDER (if
 EXTENDER
-                             then
 (CHCON1 EXTENDER)
-                           else
 (CHARCODE SPACE)))
-          (while
 (ILESSP (LENGTH C)
-                            MIN.LENGTH) do
 (SETQ C (CONS EXTENDER C)))
-          (RETURN (PACKC C])
+    (IF
 (ILESSP (NCHARS X)
+               MIN.LENGTH)
+        THEN
 (PACK* (ALLOCSTRING (IDIFFERENCE MIN.LENGTH (NCHARS X))
+                           (CL:IF EXTENDER
+                               (NTHCHAR EXTENDER 1)
+                               " "))
+                    X)
+      ELSE
 X])
 
 (IMCOMPARE.MERGE.CONNECTED.CHUNKS

   [LAMBDA (NEW.CHUNK.LIST BACKWARDS.FLG)
                 (* mjs " 6-Jan-84 10:35")

@@ -551,45 +491,44 @@ Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation.  All rights reserved.
                                                       (RPLACD CHUNK.LST (CDDR CHUNK.LST])
 
 (IMCOMPARE.MIDDLEBUTTONFN

-  [LAMBDA (GNODE WINDOW)
                                 (* mjs " 6-Jan-84 11:37")

+  [LAMBDA (GNODE WINDOW)
 
-         (* This function is called if the MIDDLE mouse button is pressed over a graph 
-
       node. The selected node is IMCOMPARE-ed with the last node selected <which is 
-
       boxed>. The type of hashing used <PARA, LINE, or WORD> is selected from a 
-
       pop-up menu. If none of the hashing types is selected, the current node is 
-
       boxed. The pop-up menu is always located a little above the current cursor 
-
       position, so a quick double-MIDDLE-click is an easy way to change the current 
-
       boxed node.)

+    (* ;; "Edited 16-Dec-2021 10:55 by rmk: Remove previous HASH.TYPE from the middle mouse menu")

+                                                             (* ; "Edited 16-Dec-2021 10:51 by rmk")

+                                                             (* mjs " 6-Jan-84 11:37")

+
+    (* ;; "This function is called if the MIDDLE mouse button is pressed over a graph node.  The selected node is IMCOMPARE-ed with the last node selected <which is boxed>.  The type of hashing used <PARA, LINE, or WORD> is selected from a pop-up menu.  If none of the hashing types is selected, the current node is boxed.  The pop-up menu is always located a little above the current cursor position, so a quick double-MIDDLE-click is an easy way to change the current boxed node.")

 
     (if
 GNODE
         then
 (PROG (INNER.HASH.TYPE)
-                       (CLRPROMPT)
-                       (printout PROMPTWINDOW "Please select the type of hashing you wish." T)
-                       [SETQ INNER.HASH.TYPE
-                        (MENU (if
 (type?
 MENU IMCOMPARE.HASH.TYPE.MENU)
-                                  then
 IMCOMPARE.HASH.TYPE.MENU
-                                else
 (SETQ IMCOMPARE.HASH.TYPE.MENU
-                                          (create
 MENU
-                                                 ITEMS _ '(PARA LINE WORD)
-                                                 MENUOFFSET _
-                                                 (create
 POSITION
-                                                        XCOORD _ 20
-                                                        YCOORD _ -20]
-                       (if
 (NULL INNER.HASH.TYPE)
-                           then
                          (* if no hash type is selected, just 
-
                                                           box the current node and return)

-                                 (IMCOMPARE.BOXNODE
 GNODE WINDOW)
-                                 (RETURN))
-                       (if
 (NULL IMCOMPARE.LAST.NODE)
-                           then
 (CLRPROMPT)
-                                 (PRIN1 "You must select another graph node first." PROMPTWINDOW)
-                                 (RETURN))
-                       (printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
-                       (IMCOMPARE.CHUNKS
 (fetch
 (GRAPHNODE NODEID) of
 IMCOMPARE.LAST.NODE
-                                                    )
-                              (fetch
 (GRAPHNODE NODEID) of
 GNODE)
-                              INNER.HASH.TYPE
-                              (WINDOWPROP WINDOW 'REGION])
+                   (CLRPROMPT)
+                   (printout PROMPTWINDOW "Please select the type of hashing you wish." T)
+                   [SETQ INNER.HASH.TYPE (MENU (create
 MENU
+                                                      ITEMS _ (REMOVE (GRAPHERPROP
+                                                                       (WINDOWPROP WINDOW
+                                                                              'GRAPH)
+                                                                       'HASH.TYPE)
+                                                                     '(PARA LINE WORD))
+                                                      MENUOFFSET _
+                                                      (create
 POSITION
+                                                             XCOORD _ 20
+                                                             YCOORD _ -20]
+                   (if
 (NULL INNER.HASH.TYPE)
+                       then
                                  (* ; 
+
                                  "if no hash type is selected, just box the current node and return")

+                            (IMCOMPARE.BOXNODE
 GNODE WINDOW)
+                            (RETURN))
+                   (if
 (NULL IMCOMPARE.LAST.NODE)
+                       then
 (CLRPROMPT)
+                            (PRIN1 "You must select another graph node first." PROMPTWINDOW)
+                            (RETURN))
+                   (printout PROMPTWINDOW "Comparing chunks by " INNER.HASH.TYPE T)
+                   (IMCOMPARE.CHUNKS
 (fetch
 (GRAPHNODE NODEID) of
 IMCOMPARE.LAST.NODE)
+                          (fetch
 (GRAPHNODE NODEID) of
 GNODE)
+                          INNER.HASH.TYPE
+                          (WINDOWPROP WINDOW 'REGION)
+                          (GRAPHERPROP (WINDOWPROP WINDOW 'GRAPH)
+                                 'FILELABELS])
 
 (IMCOMPARE.SHOW.DIST

   [LAMBDA (LST MAX)
                                      (* mjs "30-Dec-83 15:13")

@@ -634,27 +573,31 @@ Copyright (c) 1984, 1985, 1993, 1998 by Xerox Corporation.  All rights reserved.
 
 (MOVD 'COMPARETEXT 'IMCOMPARE)
 
-(RPAQQ IMCOMPARE.LAST.NODE
 NIL)
+(RPAQ? IMCOMPARE.LAST.NODE
 NIL)
 
-(RPAQQ IMCOMPARE.LAST.GRAPH.WINDOW
 NIL)
-
-(RPAQQ IMCOMPARE.HASH.TYPE.MENU
 NIL)
+(RPAQ? IMCOMPARE.LAST.GRAPH.WINDOW
 NIL)
 (DECLARE%: EVAL@COMPILE
 
 (RECORD IMCOMPARE.CHUNK
 (HASHVALUE FILEPTR CHUNKLENGTH FILENAME . OTHERCHUNK)
-                            FILEPTR _ 1 CHUNKLENGTH _ 0)
+                        FILEPTR _ 1)
 
 (RECORD IMCOMPARE.SYMB
 (NEWCOUNT OLDCOUNT . OLDPTR))
 )
 
-(FILESLOAD GRAPHER)
+(FILESLOAD (SYSLOAD)
+       GRAPHER)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD (LOADCOMP)
+       GRAPHER)
+)
 (PUTPROPS COMPARETEXT COPYRIGHT ("Xerox Corporation" 1984 1985 1993 1998))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1365 39345 (COMPARETEXT 1375 . 3770) (IMCOMPARE.BOXNODE 3772 . 4288) (IMCOMPARE.CHUNKS 
-4290 . 8476) (IMCOMPARE.COLLECT.HASH.CHUNKS 8478 . 9707) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 9709
- . 18575) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 18577 . 19340) (IMCOMPARE.HASH 19342 . 26603) (
-IMCOMPARE.LEFTBUTTONFN 26605 . 28341) (IMCOMPARE.LENGTHEN.ATOM 28343 . 28981) (
-IMCOMPARE.MERGE.CONNECTED.CHUNKS 28983 . 32479) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 32481 . 34436) (
-IMCOMPARE.MIDDLEBUTTONFN 34438 . 37010) (IMCOMPARE.SHOW.DIST 37012 . 37458) (
-IMCOMPARE.UPDATE.SYMBOL.TABLE 37460 . 39343)))))
+  (FILEMAP (NIL (1334 38876 (COMPARETEXT 1344 . 3554) (IMCOMPARE.BOXNODE 3556 . 4072) (IMCOMPARE.CHUNKS 
+4074 . 8592) (IMCOMPARE.COLLECT.HASH.CHUNKS 8594 . 11053) (IMCOMPARE.DISPLAY.FILE.DIFFERENCE.GRAPH 
+11055 . 20136) (IMCOMPARE.FIND.TEDIT.TEXT.OBJECT 20138 . 20912) (IMCOMPARE.HASH 20914 . 25101) (
+IMCOMPARE.LEFTBUTTONFN 25103 . 27545) (IMCOMPARE.LENGTHEN.ATOM 27547 . 28249) (
+IMCOMPARE.MERGE.CONNECTED.CHUNKS 28251 . 31747) (IMCOMPARE.MERGE.UNCONNECTED.CHUNKS 31749 . 33704) (
+IMCOMPARE.MIDDLEBUTTONFN 33706 . 36541) (IMCOMPARE.SHOW.DIST 36543 . 36989) (
+IMCOMPARE.UPDATE.SYMBOL.TABLE 36991 . 38874)))))
 STOP

loadups/README.md

@@ -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.
+