Rmk19: Updates and remaining components for managing comparisons and interactions between git and Medley (#658)

* PSEUDOHOSTS: Overlay a file system at the end of a path in another file system

New package, please look through it.

* REGIONMANAGER:  added RELCREATEPOSITION, allow for arguments to be spread

If the WIDTH argument looks like a list of arguments, the arguments are spread out.  Means that a relative region can be passed through intermediate functions.

* EXAMINEDEFS:  More control over regions and windows

Examination windows are returned so that callers can manipulate them

* TEDIT-PF-SEE:  tf respects reader environment and bold faces of DEFUN and DEFMACRO names

* COMPAREDIRECTORIES:  refactored for more flexibility and easier maintenance

Also, based on SPY, made more internal operations work on streams that are located and created once, rather than on file

Added CDMERGE to merge CDVALUES for different subdirectories, to permit scrolling of all differences in a single browser window

* COMPARESOURCES:  Region for CS browser is passed through, window is returned

Also tried to eliminate mismatching of simple edit timestamps

* COMPARETEXT: Files can be input streams, region is passed in, window is returned

* COMPAREDIRECTORIES again:  Fixed a promptwindow bug

* GITFNS:  New package for comparing and copying back and forth from My Medley to the git clone

.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 }}

.gitignore

@@ -1,7 +1,19 @@
 # loadup interim steps
 
 tmp/*
-loadups/init*
+
+# all loadup files 
+
+library/exports.all
+library/RDSYS*
+loadups/lisp.sysout
+loadups/full.sysout
+loadups/*.dribble
+loadups/whereis.hash
+
+# manual cross-reference files
+
+*.IMPTR
 
 #compiled code -- leave in for now
 
@@ -24,7 +36,3 @@ core
 
 # Mac OS detritus
 .DS_Store
-
-# set up by install-diff-filter.sh script
-.gitattributes
-sources/LLREAD.LCOM.~1~

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
@@ -56,7 +99,7 @@ Or from the Common Lisp prompt with:
 ```
 (IL:LOGOUT)
 ```
-When you logout of the system, Medley automatically creates a binary
+When you log out of the system, Medley automatically creates a binary
 dump of your system located in your home directory named
 `lisp.virtualmem`. The next time you run the system, if you don't
 specify a specific image to run, Medley restores that image so that
@@ -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/NOGREET

@@ -0,0 +1,19 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "10-Sep-2021 21:25:42" {DSK}<home>larry>medley>greetfiles>NOGREET.;1
 537    )
+
+
+(PRETTYCOMPRINT NOGREETCOMS)
+
+(RPAQQ NOGREETCOMS
 [(P (COND ((STKPOS 'GREET)
+                                  (SETQ USERGREETFILES NIL)
+                                  (CLOSEF? (INPUT))
+                                  (RETFROM 'GREET])
+
+[COND
+   ((STKPOS 'GREET)
+    (SETQ USERGREETFILES NIL)
+    (CLOSEF? (INPUT))
+    (RETFROM 'GREET]
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+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

@@ -0,0 +1,134 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+
(FILECREATED "17-Oct-2021 16:06:41" {DSK}<home>larry>medley>internal>library>MAKE-PS.;2
 5515   
+
+      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)
+
+(RPAQQ MAKE-PSCOMS

+       [(FNS MAKE-PS MAKE-PS-INIT BADFILE)
+        
+        (* ;; " Load known used image object types")

+
+        (FILES DOC-OBJECTS EQUATIONS IMINDEX IMNAME IMTEDIT IMTOOLS IMTRAN MATHTONS SKETCH TMAX)
+        (ADVISE TEDIT.PROMPTPRINT)
+        (INITVARS (BADFILESFILE)
+               (BADFS)
+               (BADFILES))
+        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-PS-INIT])
+(DEFINEQ
+
+(MAKE-PS

+  [LAMBDA (TFILE PREFIX DEST REDOFLG TOPDIRLEN)
        (* ; "Edited 21-Aug-2021 20:56 by larry")

+    (DECLARE
 (SPECVARS TFILE))
+    (COND
+       ((DIRECTORYNAMEP TFILE)
+        (SETQ TFILE (DIRECTORYNAME TFILE))
+        [OR TOPDIRLEN (SETQ TOPDIRLEN (IPLUS 1 (CL:LENGTH (MKSTRING (FILENAMEFIELD TFILE 'DIRECTORY]
+        [OR DEST (PROGN (ShellCommand (CONCAT "mkdir -p " (UNIX-GETENV "MEDLEYDIR")
+                                             "/tmp/psfiles"))
+                        (SETQ DEST (MEDLEYDIR "tmp/psfiles"]
+
+        (* ;; "first deal with files in this directory")

+
+        (for
 X in
 (IF
 (EQ REDOFLG 'REV)
+                              THEN
 (REVERSE (DIRECTORY (CONCAT TFILE "*.TED*;")))
+                            ELSE
 (DIRECTORY (CONCAT TFILE "*.TED*;")))
+           when
 (NOT (MEMB X BADFILES)) do
 (MAKE-PS
 X PREFIX DEST REDOFLG TOPDIRLEN))
+
+        (* ;; " then deal with subdirs ")

+
+        (for
 X in
 (IF
 (EQ REDOFLG 'REV)
+                              THEN
 (REVERSE (DIRECTORY (CONCAT TFILE "*")))
+                            ELSE
 (DIRECTORY (CONCAT TFILE "*")))
+           when
 [for
 SKIP in
 '(">." ">internal>test" ">dinfo>")
+                       always
 (NOT (STRPOS SKIP (L-CASE X] when
 (DIRECTORYNAMEP X)
+           do
 (MAKE-PS
 X PREFIX DEST REDOFLG TOPDIRLEN)))
+       [(SETQ TFILE (INFILEP TFILE))
+        (PROG ((PSFILE (PACKFILENAME.STRING 'EXTENSION (if
 (EQ REDOFLG 'IP)
+                                                           then
 'IP
+                                                         else
 "PS")
+                              'NAME
+                              (CONCAT (OR PREFIX "")
+                                     (if
 PREFIX
+                                         then
 "-"
+                                       else
 "")
+                                     [PACK (SUBST '- '> (UNPACK (SUBSTRING (FILENAMEFIELD
+                                                                            TFILE
+                                                                            'DIRECTORY)
+                                                                       (IPLUS 1 TOPDIRLEN)
+                                                                       -1]
+                                     "-"
+                                     (FILENAMEFIELD TFILE 'NAME))
+                              'DIRECTORY DEST))
+               (TEXTSTREAM))
+              (if
 (MEMB TFILE BADFILES)
+                  then
 (RETURN))
+              (if
 (AND (NOT REDOFLG)
+                           (INFILEP PSFILE))
+                  then
                                   (* ; " do nothing")

+                        (PRINTOUT T PSFILE " already there" T)
+                elseif
 (EQ REDOFLG 'TEST)
+                  then
 (PRINTOUT T "TESTING " TFILE)
+                        (CLOSEF (OPENTEXTSTREAM TFILE))
+                else
 (PRINTOUT T "Converting " TFILE "...")
+                      (TEDIT.FORMAT.HARDCOPY (SETQ TEXTSTREAM (OPENTEXTSTREAM TFILE))
+                             PSFILE T NIL NIL NIL (if
 (EQ REDOFLG 'IP)
+                                                      then
 'INTERPRESS
+                                                    else
 'POSTSCRIPT))
+                      (printout T " DONE" T)
+                      (CLOSEF? TEXTSTREAM]
+       (T (PRINTOUT T "no such file " T])
+
+(MAKE-PS-INIT

+  [LAMBDA NIL
                                          (* ; "Edited  1-Sep-2021 16:27 by larry")

+                                                             (* ; " initialize")

+    (SETQ BADFILESFILE (MEDLEYDIR "tmp" "badfiles.txt" T))
+    (SETQ BADFS (OPENSTREAM BADFILESFILE 'APPEND))
+    (POSTSCRIPT.INIT)
+    (SETQ BADFILES (SUBSET (READFILE BADFILESFILE)
+                          (FUNCTION INFILEP])
+
+(BADFILE

+  [LAMBDA (X)
                                          (* ; "Edited 16-Aug-2021 13:14 by larry")

+    ([LAMBDA ($$1)
+       (COND
+          ((FMEMB $$1 BADFILES)
+           BADFILES)
+          (T (NCONC1 BADFILES $$1]
+     (OR X TFILE))
+    (PRINT (OR X TFILE)
+           BADFS)
+    (FLUSHOUTPUT BADFS)
+    (CLOSEF? TEXTSTREAM)
+    (RETFROM 'MAKE-PS NIL])
+)
+
+
+
+(* ;; " Load known used image object types")

+
+
+(FILESLOAD DOC-OBJECTS EQUATIONS IMINDEX IMNAME IMTEDIT IMTOOLS IMTRAN MATHTONS SKETCH TMAX)
+
+[XCL:REINSTALL-ADVICE 'TEDIT.PROMPTPRINT :BEFORE '((:LAST (PRIN1 MSG T]
+
+(READVISE TEDIT.PROMPTPRINT)
+
+(RPAQ? BADFILESFILE
 )
+
+(RPAQ? BADFS
 )
+
+(RPAQ? BADFILES
 )
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MAKE-PS-INIT
)
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (793 5117 (MAKE-PS 803 . 4300) (MAKE-PS-INIT 4302 . 4738) (BADFILE 4740 . 5115)))))
+STOP

internal/library/MEDLEY-UTILS

@@ -1,38 +1,128 @@
-(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)
 
-      |changes| |to:|  (VARS MEDLEY-UTILSCOMS)
+
(FILECREATED "26-Dec-2021 18:58:43" |{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;2|
 9049   
 
-      |previous| |date:| "24-Mar-2021 15:45:15" 
-|{DSK}<home>larry>ilisp>medley>internal>library>MEDLEY-UTILS.;3|)
+      :CHANGES-TO (FNS GATHER-INFO)
+
+      :PREVIOUS-DATE "25-Oct-2021 14:54:43" |{DSK}<home>larry>medley>internal>library>MEDLEY-UTILS.;1|
+)
 
 
 (PRETTYCOMPRINT MEDLEY-UTILSCOMS)
 
-(RPAQQ MEDLEY-UTILSCOMS
 ((FNS MEDLEY-FIX-LINKS MEDLEY-FIX-DATES)
-                             (VARS MEDLEY-FIX-DIRS)
-                             (FNS MAKE-EXPORTS-ALL MAKE-WHEREIS-HASH)))
+(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 26-Dec-2021 18:56 by larry")

+                                                             (* \; 
+
                                                             "Edited 24-Oct-2021 09:43 by larry")

+    (SELECTQ PHASE
+        (ALL (|for|
 I |from|
 0 |to|
 4 |do|
 (GATHER-INFO
 I)))
+        (0 (SETQ SYSFILES (UNION SYSFILES FILELST))
+           (SETQ FILELST NIL)
+           (FILESLOAD (SOURCE)
+                  SYSEDIT))
+        (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))))))
 )
 
 (RPAQQ MEDLEY-FIX-DIRS
 ("sources" "library" "lispusers" "internal/library" "greetfiles" 
-                                  "docs>Documentation Tools"))
+                              "docs>Documentation Tools"))
 (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 +135,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 +150,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 (553 7001 (GATHER-INFO 563 . 6103) (MEDLEY-FIX-LINKS 6105 . 6628) (MEDLEY-FIX-DATES 6630
+ . 6999)) (7155 9026 (MAKE-EXPORTS-ALL 7165 . 8181) (MAKE-WHEREIS-HASH 8183 . 9024)))))
 STOP

internal/library/MULTI-COMPILE

@@ -1,13 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
(FILECREATED "16-Nov-94 16:28:04" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;4|
 37236  
+
(FILECREATED "25-Sep-2021 21:28:08" 
+|{DSK}<Users>kaplan>Local>medley3.5>git-medley>internal>library>MULTI-COMPILE.;2|
 37172  
 
-      |changes| |to:|  (VARS MULTI-COMPILECOMS)
-                       (FNS FIND-UNCOMPILED-FILES)
-
-      |previous| |date:| " 9-Sep-94 13:03:19" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;3|)
+      |previous| |date:| "16-Nov-94 16:28:04" 
+|{DSK}<Users>kaplan>Local>medley3.5>git-medley>internal>library>MULTI-COMPILE.;1|)
 
 
-; Copyright (c) 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation.  All rights reserved.
+; Copyright (c) 1988, 1990-1994, 2021 by Venue & Xerox Corporation.
 
 (PRETTYCOMPRINT MULTI-COMPILECOMS)
 
@@ -601,12 +600,12 @@
 
 (ADDTOVAR LAMA
 FIX-FILES)
 )
-(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994))
+(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994 2021))
 (DECLARE\: DONTCOPY
-  (FILEMAP (NIL (7131 8389 (FIND-UNCOMPILED-FILES 7141 . 8387)) (8461 19787 (NEWERDCOMS? 8471 . 12445) (
-NEWERSOURCES? 12447 . 16359) (SETUP-FOR-RECOMPILE 16361 . 18749) (SMASH-OPCODES 18751 . 19269) (
-GET-DIRECTORY-LISTING 19271 . 19568) (GET-OPEN-FILES 19570 . 19785)) (31690 36610 (FIX-FILES 31700 . 
-34497) (FIX-FILE 34499 . 35090) (FIX-COPYRIGHT 35092 . 35319) (FIX-FILE-COPYRIGHT 35321 . 35481) (
-QUALIFY-FIELDS 35483 . 36022) (FIX-TEDIT 36024 . 36330) (FIX-DOCS 36332 . 36608)) (36735 36917 (CLFIX 
-36745 . 36915)))))
+  (FILEMAP (NIL (2676 6156 (BIGCOMP 2676 . 6156)) (6289 7061 (FIND-ALL-SOURCE-FILES 6289 . 7061)) (7062 
+8320 (FIND-UNCOMPILED-FILES 7072 . 8318)) (8392 19718 (NEWERDCOMS? 8402 . 12376) (NEWERSOURCES? 12378
+ . 16290) (SETUP-FOR-RECOMPILE 16292 . 18680) (SMASH-OPCODES 18682 . 19200) (GET-DIRECTORY-LISTING 
+19202 . 19499) (GET-OPEN-FILES 19501 . 19716)) (31621 36541 (FIX-FILES 31631 . 34428) (FIX-FILE 34430
+ . 35021) (FIX-COPYRIGHT 35023 . 35250) (FIX-FILE-COPYRIGHT 35252 . 35412) (QUALIFY-FIELDS 35414 . 
+35953) (FIX-TEDIT 35955 . 36261) (FIX-DOCS 36263 . 36539)) (36666 36848 (CLFIX 36676 . 36846)))))
 STOP

internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST%

@@ -1,91 +0,0 @@
-;; Function To Be Tested: LIST*
-;;
-;; Source: Guy L Steele's CLTL
-;; Section: 15.2 Lists
-;; Page: 267
-;;
-;; Created By:    Kelly Roach
-;;
-;; Creation Date: June 27,1986
-;;
-;; Last Update:   June 27,1986
-;;			   July 15, 1986 Sye/  create test cases
-;;
-;; Filed As:      {ERIS}<LISPCORE>CML>TEST>15-2-LIST*.TEST
-;;
-;;
-;; Syntax:        (LIST* ARG &REST OTHERS)
-;;
-;; Function Description:
-;; LIST* is like LIST except that the last CONS
-;; of the constructed list is ``dotted.''  The last argument to LIST*
-;; is used as the CDR of the last cons constructed;
-;; this need not be an atom.  If it is not an atom,
-;; then the effect is to add several new elements to the front of a list.
-;; For example:
-;; 
-;;     (LIST* 'A 'B 'C 'D) => (A B C . D)
-;;     This is like
-;;     (CONS 'A (CONS 'B (CONS 'C 'D)))
-;;     Also:
-;;     (LIST* 'A 'B 'C '(D E F)) => (A B C D E F)
-;;     (LIST* X) = X
-;;     
-;; 
-;; Argument(s):   ARG - anything
-;;                OTHERS - anything
-;;
-;; Returns:       a dotted list
-;;
-(do-test "test list*0 - test case copied from page 267 of CLtL"
-	(and (EQUAL (LIST* 'A 'B 'C 'D) '(A B C . D))
-		(EQUAL (LIST* 'A 'B 'C '(D E F)) '(A B C D E F))
-		(EQUAL (LIST* 'X) 'X)
-	)
-)
-
-(do-test "test list*1"
-   (and (equal (list* 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999
-                    999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999 999)
-			 (append (make-list 48 :initial-element 999) '(999 . 999)))
-
-	   (equal (list* "evening" 'sun 'reflected "in Lake" 'Shanti) '("evening" sun reflected "in Lake" . Shanti))
-   )
-)
-
-(do-test "test list*2"
-    (equal (list* 1.009 'a (cons 3 4) (funcall #'list* 2.009 #\g "string") (every #'evenp '(2 4 6 8)) (not (or 1 100 1000 0))
-                 (apply #'list*  'm 'n 'b '(88)) (list* (+ 2 3) (caddr '(w x y z))) )
-         '(1.009 a (3 . 4) (2.009 #\g . "string") t nil (m n b . 88) 5 . y)))
-
-(do-test "test list*3"
-   (progn
-    (setq aa '(a b c d e f g h))
-    (equal (list* (last aa)  (nth 3 aa) (nthcdr 5 aa)  (list* (car aa) (endp aa))
-               (progn 1 2 3 (setq x 1 y 2 z 3))
-               (prog2 (defun fun () "fun1") (fun))
-               (prog1 (setq a 100) (setq a (1+ a)))
-               (progn (defmacro mac () `(list* ,(* 2 2) ,(list-length ()))) (mac)))
-          '( (h) d (f g h) (a . nil) 3 "fun1" 100 4 . 0))  ))
-
-(do-test "test list*4 - nested list* functions"
-   (and 
-    (equal (setq aa (list* (list* (list* (list* (list* (list* (list* (list* (list* (list* 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k)))))))))))
-    '(a b c d e f g h i j . k)  )
-    (equal  (list* aa aa aa aa aa)
-		  '((a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k) (a b c d e f g h i j . k)
-               a b c d e f g h i j . k) )
-   )
-)
-
-(do-test "test list*5 -  (list* x) is equivalent to x [page 268]"
-    (and  (eq (list* ()) ())
-		(eq (list* 10) 10)
-		(equal (list* '(1)) '(1))
-		(equal (list* (list* (list 2))) '(2))
-		(prog2 (setq a (list* #'-)) (= (funcall a 4 3 2 1) -2))
-		(equal (list* (list (list* 1 2 3) '(4) ) '(5 . "a")) '(((1 2 . 3) (4)) 5 . "a"))
-	)
-)
-
-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/MSANALYZE

@@ -1,10 +1,10 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
-
(FILECREATED "18-Aug-2021 12:13:11" {DSK}<home>larry>medley>library>MSANALYZE.;5
 62745  
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
 
-      changes to%:  (FNS MSPRGMACRO MSFINDP)
-                    (VARS MSMACROPROPS)
+
(FILECREATED "26-Dec-2021 10:10:02" {DSK}<home>larry>medley>library>MSANALYZE.;6
 62468  
 
-      previous date%: "18-Aug-2021 10:56:25" {DSK}<home>larry>medley>library>MSANALYZE.;4)
+      :CHANGES-TO (FNS MSPRGTEMPLATE)
+
+      :PREVIOUS-DATE "18-Aug-2021 12:13:11" {DSK}<home>larry>medley>library>MSANALYZE.;5)
 
 
 (* ; "
@@ -269,7 +269,7 @@ DONTCOPY
 (DECLARE%: EVAL@COMPILE 
 
 (PUTPROPS MSVBNOTICED
 MACRO
 [OPENLAMBDA (VERB MOD)
-                                      (CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED])
+                              (CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED])
 )
 )
 (DEFINEQ
@@ -752,19 +752,18 @@ DONTCOPY
                          (CDR TEMPLATE])
 
 (MSPRGTEMPLATE

-  (LAMBDA (PARENT TEMPLATE PARENTCONTEXT)
                    (* lmm "23-Jul-86 00:15")

-    (BLOCK)                                                  (* 
-
                       "Masterscope should block every once and a while. This is one place to do it.")

+  [LAMBDA (PARENT TEMPLATE PARENTCONTEXT)                    (* ; "Edited 26-Dec-2021 10:09 by larry")

+                                                             (* lmm "23-Jul-86 00:15")

     (PROG ((VARS
 VARS)
            TEM)
           (COND
-             ((EQ TEMPLATE 'MACRO)
+             [(EQ TEMPLATE 'MACRO)
               (COND
                  ((SETQ TEM (GETMACROPROP (CAR PARENT)
                                    MSMACROPROPS))
                   (MSPRGMACRO
 PARENT TEM))
-                 (T (MSPRGTEMPLATE1
 PARENT '(CALL .. EVAL)))))
-             (T (MSPRGTEMPLATE1
 PARENT TEMPLATE))))))
+                 (T (MSPRGTEMPLATE1
 PARENT '(CALL |..| EVAL]
+             (T (MSPRGTEMPLATE1
 PARENT TEMPLATE])
 
 (MSPRGLAMBDA

   [LAMBDA (EXPR FLG TYPE)
                                (* ; "Edited  3-Jun-88 10:23 by jrb:")

@@ -1036,22 +1035,21 @@ DONTCOPY
 
 (RPAQQ MSRECORDTRANFLG
 NIL)
 
-(ADDTOVAR INVISIBLEVARS
 $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 
-                                $$17)
+(ADDTOVAR INVISIBLEVARS
 $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)
 (DECLARE%: DONTCOPY 
 (DECLARE%: EVAL@COMPILE 
 
 (PUTPROPS INCLISP
 MACRO
 ((.X.)
-                                 (COND
-                                    ((AND INCLISP EACHTIME (NOT (MSFINDP
 INCLISP .X.)))
-                                     INCLISP)
-                                    (T .X.))))
+                         (COND
+                            ((AND INCLISP EACHTIME (NOT (MSFINDP
 INCLISP .X.)))
+                             INCLISP)
+                            (T .X.))))
 
 (PUTPROPS LTEMPLATE
 MACRO
 [LAMBDA (Y)
-                                    (DECLARE
 (LOCALVARS Y))
-                                    (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
-                                                            (GETHASH Y MSTEMPLATES]
-                                         Y])
+                            (DECLARE
 (LOCALVARS Y))
+                            (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
+                                                    (GETHASH Y MSTEMPLATES]
+                                 Y])
 )
 )
 (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
@@ -1265,10 +1263,10 @@ DONTCOPY
 (DECLARE%: EVAL@COMPILE DONTCOPY 
 
 (PUTPROPS LTEMPLATE
 MACRO
 [LAMBDA (Y)
-                                    (DECLARE
 (LOCALVARS Y))
-                                    (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
-                                                            (GETHASH Y MSTEMPLATES]
-                                         Y])
+                            (DECLARE
 (LOCALVARS Y))
+                            (AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
+                                                    (GETHASH Y MSTEMPLATES]
+                                 Y])
 )
 (DEFINEQ
 
@@ -1288,11 +1286,11 @@ DONTCOPY
 )
 (PUTPROPS MSANALYZE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1988 1990 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3820 11339 (VARS 3830 . 3971) (FREEVARS 3973 . 4126) (CALLS 4128 . 10469) (
-COLLECTFNDATA 10471 . 10850) (CALLS3 10852 . 11337)) (13596 52783 (ALLCALLS 13606 . 14285) (
-MSINITFNDATA 14287 . 14531) (MSPRGE 14533 . 21607) (MSPRGMACRO 21609 . 22205) (MSPRGCALL 22207 . 22531
-) (MSBINDVAR 22533 . 23052) (MSPRGRECORD 23054 . 29967) (MSPRGERR 29969 . 30137) (MSPRGTEMPLATE1 30139
- . 39300) (MSPRGTEMPLATE 39302 . 39982) (MSPRGLAMBDA 39984 . 49579) (MSPRGLST 49581 . 49749) (ADDTO 
-49751 . 50542) (NLAMBDAFNP 50544 . 51296) (MSPRGDWIM 51298 . 52117) (MSDWIMTRAN 52119 . 52781)) (62109
- 62541 (MSFINDP 62119 . 62539)))))
+  (FILEMAP (NIL (3759 11278 (VARS 3769 . 3910) (FREEVARS 3912 . 4065) (CALLS 4067 . 10408) (
+COLLECTFNDATA 10410 . 10789) (CALLS3 10791 . 11276)) (13527 52635 (ALLCALLS 13537 . 14216) (
+MSINITFNDATA 14218 . 14462) (MSPRGE 14464 . 21538) (MSPRGMACRO 21540 . 22136) (MSPRGCALL 22138 . 22462
+) (MSBINDVAR 22464 . 22983) (MSPRGRECORD 22985 . 29898) (MSPRGERR 29900 . 30068) (MSPRGTEMPLATE1 30070
+ . 39231) (MSPRGTEMPLATE 39233 . 39834) (MSPRGLAMBDA 39836 . 49431) (MSPRGLST 49433 . 49601) (ADDTO 
+49603 . 50394) (NLAMBDAFNP 50396 . 51148) (MSPRGDWIM 51150 . 51969) (MSDWIMTRAN 51971 . 52633)) (61832
+ 62264 (MSFINDP 61842 . 62262)))))
 STOP

library/MSCOMMON

@@ -1,12 +1,17 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
(FILECREATED " 4-May-92 13:10:53" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;3|
 23489  
 
-      |changes| |to:|  (TEMPLATES CL:DECF CL:INCF CL:PUSH)
+
(FILECREATED "15-Jan-2022 20:17:21" |{DSK}<home>larry>medley>library>MSCOMMON.;4|
 24053  
 
-      |previous| |date:| "12-Jun-90 10:17:31" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>MSCOMMON.;2|)
+      :CHANGES-TO (TEMPLATES ADD-EXEC CL:ASSOC CL:COMPILE-FILE EXEC CL:IN-PACKAGE CL:MAKE-STRING OPEN
+                         CL:PUSH CL:PUSHNEW CL:RASSOC CL:WRITE-LINE CL:WRITE-STRING CL:WHEN CL:UNLESS
+                         )
+                  (FNS FUNCTIONSMSGETDEF FUNCTIONSMSMC VARIABLESMSGETDEF)
+                  (VARS MSCOMMONCOMS)
+
+      :PREVIOUS-DATE " 4-May-92 13:10:53" |{DSK}<home>larry>medley>library>MSCOMMON.;3|)
 
 
-; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+; Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.
 
 (PRETTYCOMPRINT MSCOMMONCOMS)
 
@@ -37,8 +42,8 @@
                CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP 
                CL:STRING-UPCASE CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>=
                CL:SUBLIS CL:SUBSETP CL:SUBST CL:SUBST-IF CL:SUBST-IF-NOT CL:SUBSTITUTE 
-               CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:VECTOR-PUSH 
-               CL:VECTOR-PUSH-EXTEND WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING)
+               CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT CL:TREE-EQUAL CL:UNION CL:UNLESS CL:VECTOR-PUSH
+               CL:VECTOR-PUSH-EXTEND CL:WHEN WRITE CL:WRITE-LINE CL:WRITE-STRING CL:WRITE-TO-STRING)
         (P 
            (* |;;| "First tell Masterscope how to find FUNCTIONS and VARIABLES")

 
@@ -46,7 +51,7 @@
            (MSADDANALYZE 'FUNCTIONS 'FUNCTION 'FUNCTIONS 'FUNCTIONSMSGETDEF 'FUNCTIONSMSMC)
            
            (* |;;| 
-
        "Then add KEYWORD support.  Templates may now contain the following as their last element:")

+
          "Then add KEYWORD support.  Templates may now contain the following as their last element:")

 
            
            (* |;;| "... KEYWORDS list of keywords accepted)")

@@ -65,7 +70,7 @@
            (MSADDMODIFIER 'SPECIFY 'KEYWORDS 'KEYSPECIFY)
            
            (* |;;| 
-
   "Stuff for locally-defined things.  We don't attempt to handle them (*sigh*), just record them.")

+
     "Stuff for locally-defined things.  We don't attempt to handle them (*sigh*), just record them.")

 
            (MSADDRELATION '(FLET FLETS FLETTING FLET))
            (MSADDRELATION '(LABEL LABELS LABELLING LABELLED))
@@ -87,42 +92,48 @@
 (DEFINEQ
 
 (FUNCTIONSMSGETDEF

-  (LAMBDA (NAME TYPE SOURCE OPTIONS)
                     (* \; "Edited 31-Mar-88 17:31 by jrb:")

+  (LAMBDA (NAME TYPE SOURCE OPTIONS)                         (* \; "Edited 31-Mar-88 17:31 by jrb:")

     (LET ((BODY (REMOVE-COMMENTS (GETDEF NAME 'FUNCTIONS SOURCE OPTIONS))))
          (AND BODY (SELECTQ (CAR BODY)
                        (DEFMACRO (OR (GETTEMPLATE NAME)
                                      (SETTEMPLATE NAME 'MACRO))
                                  NIL)
                        (CL:DEFUN 
-          (* |;;| "Body is of the form:")

-          (* |;;| "(DEFUN name (args...) bodies...)")

-          (* |;;| "We want to hand Masterscope a massaged form it will understand.")

-          (* |;;| "Which I believe is of this form:")

+                                 (* |;;| "Body is of the form:")

 
-                                 `(CL:LAMBDA ,(CADDR BODY) ,@(CDDDR BODY)))
+                                 (* |;;| "(DEFUN name (args...) bodies...)")

+
+                                 (* |;;| 
+
                                 "We want to hand Masterscope a massaged form it will understand.")

+
+                                 (* |;;| "Which I believe is of this form:")

+
+                                 `(CL:LAMBDA ,(CADDR BODY)
+                                         ,@(CDDDR BODY)))
                        NIL)))))
 
 (FUNCTIONSMSMC

-  (LAMBDA (NAME TYPE REASON)
                             (* \; "Edited  1-Apr-88 13:47 by jrb:")

-          (* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them")

+  (LAMBDA (NAME TYPE REASON)                                 (* \; "Edited  1-Apr-88 13:47 by jrb:")

+
+    (* |;;| "Trick here is we don't want to mark FUNCTIONS macros as changed because they really don't get analyzed, but we do want to call CHANGEMACRO for them")

 
     (|if|
 (EQ (CAR (GETDEF NAME 'FUNCTIONS NIL '(NOERROR)))
-                  'DEFMACRO)
+              'DEFMACRO)
         |then|
 (CHANGEMACRO NAME TYPE REASON)
               NIL
       |else|
 T)))
 
 (VARIABLESMSGETDEF

-  (LAMBDA (NAME TYPE SOURCE OPTIONS)
                     (* \; "Edited 19-Feb-88 19:46 by jrb:")

-
+  (LAMBDA (NAME TYPE SOURCE OPTIONS)                         (* \; "Edited 19-Feb-88 19:46 by jrb:")

     (LET ((BODY (GETDEF NAME 'VARIABLES SOURCE OPTIONS))
           SPECVARP)
          (AND BODY 
-          
-          (* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things")

+
+              (* |;;| "We have to return something here so Masterscope can get hold of the init form, and so It'll stop looking for other things")

 
               `(CL:LAMBDA NIL ,(IF
 (CADDR BODY)
-                                   THEN
 `(SETQ ,(CADR BODY) ,(CADDR BODY))))))))
+                                   THEN
 `(SETQ ,(CADR BODY)
+                                          ,(CADDR BODY))))))))
 )
 
 
@@ -162,9 +173,9 @@
                                      :LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE))
 
 (SETTEMPLATE 'CL:COMPILER-LET '(! NIL (BOTH (|..| (IF
 LISTP (NIL EVAL |..| EFFECT)
-                                                         NIL))
+                                                      NIL))
                                             (|..| (IF
 LISTP ((BOTH BIND COMPILER-LET))
-                                                         (BOTH BIND COMPILER-LET))))
+                                                      (BOTH BIND COMPILER-LET))))
                                   |..| EFFECT RETURN))
 
 (SETTEMPLATE 'CL:COUNT '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :KEY))
@@ -179,10 +190,10 @@
 
 (SETTEMPLATE 'DECLARE '(|..| (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR))
                                                    (LOCALVARS '(IF
 LISTP (|..| LOCALVARS)
-                                                                      LOCALVARS))
+                                                                   LOCALVARS))
                                                    ((SPECVARS CL:SPECIAL) 
                                                         '(IF
 LISTP (|..| SPECVARS)
-                                                                SPECVARS))
+                                                             SPECVARS))
                                                    NIL)))))
 
 (SETTEMPLATE 'CL:DELETE '(EVAL SMASH KEYWORDS :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY))
@@ -391,7 +402,7 @@
 (SETTEMPLATE 'CL:REPLACE '(SMASH EVAL KEYWORDS :START1 :END1 :START2 :END2))
 
 (SETTEMPLATE 'CL:ROTATEF '(|..| (IF
 (ATOM EXPR)
-                                       SET SMASH)))
+                                    SET SMASH)))
 
 (SETTEMPLATE 'CL:SEARCH '(EVAL EVAL KEYWORDS :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1 
                                :END2))
@@ -401,7 +412,7 @@
 (SETTEMPLATE 'CL:SET-EXCLUSIVE-OR '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
 
 (SETTEMPLATE 'CL:SHIFTF '(|..| (IF
 (ATOM EXPR)
-                                      SET SMASH)
+                                   SET SMASH)
                                EVAL))
 
 (SETTEMPLATE 'CL:SORT '(EVAL FUNCTION KEYWORDS :KEY))
@@ -459,10 +470,14 @@
 
 (SETTEMPLATE 'CL:UNION '(EVAL EVAL KEYWORDS :TEST :TEST-NOT :KEY))
 
+(SETTEMPLATE 'CL:UNLESS '(TEST |..| EFECT RETURN))
+
 (SETTEMPLATE 'CL:VECTOR-PUSH '(EVAL SMASH))
 
 (SETTEMPLATE 'CL:VECTOR-PUSH-EXTEND '(EVAL SMASH EVAL))
 
+(SETTEMPLATE 'CL:WHEN '(TEST |..| EFECT RETURN))
+
 (SETTEMPLATE 'WRITE '(EVAL KEYWORDS :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE
                            :GENSYM :ARRAY))
 
@@ -539,6 +554,6 @@
 (CLRHASH USERTEMPLATES)
 (PUTPROPS MSCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
 (DECLARE\: DONTCOPY
-  (FILEMAP (NIL (5000 6811 (FUNCTIONSMSGETDEF 5010 . 5804) (FUNCTIONSMSMC 5806 . 6286) (
-VARIABLESMSGETDEF 6288 . 6809)))))
+  (FILEMAP (NIL (5280 7291 (FUNCTIONSMSGETDEF 5290 . 6258) (FUNCTIONSMSMC 6260 . 6731) (
+VARIABLESMSGETDEF 6733 . 7289)))))
 STOP

library/SPY

@@ -1,22 +1,22 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "29-Apr-94 14:13:52" {DSK}<king>export>lispcore>library>SPY.;4
 64372  
 
-      changes to%:  (FILES GRAPHER)
-                    (FNS SPY.GRAPH.EDITOR SPY.UPDATE.TITLE SPY.MERGEINFO SPY.MAKEGRAPHNODES SPY.MAX 
-                         SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.MAKE.TREE 
-                         SPY.DELETE SPY.DUMP.BUFFER SPY.ORIGINAL SPY.MERGE.CALLEES)
+
(FILECREATED " 4-Jan-2022 14:09:48" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>SPY.;2
 63314  
 
-      previous date%: "28-Apr-94 15:56:32" {DSK}<king>export>lispcore>library>SPY.;3)
+      :CHANGES-TO (VARS SPYCOMS)
+                  (FNS SPY.MAKE.TREE)
+
+      :PREVIOUS-DATE "29-Apr-94 14:13:52" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>SPY.;1
+)
 
 
 (* ; "
-Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation.  All rights reserved.
+Copyright (c) 1984-1985, 1987-1988, 1990-1991, 1993-1994 by Venue & Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT SPYCOMS)
 
-(RPAQQ SPYCOMS
 
-       ((VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
+(RPAQQ SPYCOMS

+       [(VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
               (SPY.GRAPH.MENU)
               SPY.SHOW.PERCENTAGES SPY.SMALLGHOSTS SPY.ICON)
         (INITVARS (SPY.NEXT 0)
@@ -42,38 +42,41 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
         (MACROS WITH-SPY WITH.SPY)
         (DECLARE%: DONTCOPY (RECORDS SPYRECORD SPYDATA))
         (INITRECORDS SPYRECORD)
-        (DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))))
+        (DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))
+        (P (MOVD? 'NILL 'MODERNWINDOW])
 
-(RPAQQ SPY.BORDERS
 ((NORMAL "Normal" 2 -1)
-                        (GHOST "Shown elsewhere" 2 8840)
-                        (RECURSIVEGHOST "End of recursive chain" 2 0 -1)
-                        (MERGED "Includes other branches" 4 42405)
-                        (SELFRECURSIVE "Includes self-recursive calls" 2 61375)
-                        (RECURSIVE "Head of recursive chain" 4 28086)
-                        (ENDOFLINE "exceeded depth limit" 6 64510)))
+(RPAQQ SPY.BORDERS

+       ((NORMAL "Normal" 2 -1)
+        (GHOST "Shown elsewhere" 2 8840)
+        (RECURSIVEGHOST "End of recursive chain" 2 0 -1)
+        (MERGED "Includes other branches" 4 42405)
+        (SELFRECURSIVE "Includes self-recursive calls" 2 61375)
+        (RECURSIVE "Head of recursive chain" 4 28086)
+        (ENDOFLINE "exceeded depth limit" 6 64510)))
 
 (RPAQQ SPY.BUFFER.SIZE
 5120)
 
 (RPAQQ SPY.FRAGMENTS
 T)
 
-(RPAQQ SPY.NOMERGEFNS
 (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER
-                                 \INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
+(RPAQQ SPY.NOMERGEFNS
 (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER 
+                             \INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
 
-(RPAQQ SPY.MERGEINFO
 ((EXEC :EXEC)
-                          (EXEC-READ-LINE :EXEC)
-                          (EXEC-READ :EXEC)
-                          (XCL-USER::LEX-DO-EVENT :EXEC)
-                          (DO-EVENT :EXEC)
-                          (EVAL-INPUT :EXEC)
-                          (SI::*UNWIND-PROTECT* :ANY)
-                          (\MAKE.PROCESS0 T)
-                          (\PROC.REPEATEDLYEVALQT T)
-                          (\EVALFORM T :EVAL)
-                          (PROGN PROGN :EVAL T)
-                          (TTYIN1 TTYIN)
-                          (TTBIN TTYIN)
-                          (TTWAITFORINPUT TTYIN)
-                          (\PROGV :ANY)))
+(RPAQQ SPY.MERGEINFO

+       ((EXEC :EXEC)
+        (EXEC-READ-LINE :EXEC)
+        (EXEC-READ :EXEC)
+        (XCL-USER::LEX-DO-EVENT :EXEC)
+        (DO-EVENT :EXEC)
+        (EVAL-INPUT :EXEC)
+        (SI::*UNWIND-PROTECT* :ANY)
+        (\MAKE.PROCESS0 T)
+        (\PROC.REPEATEDLYEVALQT T)
+        (\EVALFORM T :EVAL)
+        (PROGN PROGN :EVAL T)
+        (TTYIN1 TTYIN)
+        (TTBIN TTYIN)
+        (TTWAITFORINPUT TTYIN)
+        (\PROGV :ANY)))
 
 (RPAQQ SPY.HASH
 NIL)
 
@@ -102,19 +105,19 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
 
 (RPAQ? SPY.TREE
 )
 
-(RPAQQ SPYOBJCOMS
 ((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX 
-                            SPYOBJ.DISPLAY SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON 
-                            SPY.MERGEINFO)
-                       [VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
-                                                     (FUNCTION SPYOBJ.IMAGEBOX)
-                                                     (FUNCTION SPYOBJ.SAVE)
-                                                     (FUNCTION SPYOBJ.GET)
-                                                     (FUNCTION SPYOBJ.COPY)
-                                                     (FUNCTION SPYOBJ.BUTTON)
-                                                     (FUNCTION SPYOBJ.COPYIN)
-                                                     NIL NIL NIL NIL NIL NIL 'SPYNODE]
-                       (DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
-                       (INITRECORDS SPYOBJDATA)))
+(RPAQQ SPYOBJCOMS

+       ((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX SPYOBJ.DISPLAY 
+             SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON SPY.MERGEINFO)
+        [VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
+                                      (FUNCTION SPYOBJ.IMAGEBOX)
+                                      (FUNCTION SPYOBJ.SAVE)
+                                      (FUNCTION SPYOBJ.GET)
+                                      (FUNCTION SPYOBJ.COPY)
+                                      (FUNCTION SPYOBJ.BUTTON)
+                                      (FUNCTION SPYOBJ.COPYIN)
+                                      NIL NIL NIL NIL NIL NIL 'SPYNODE]
+        (DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
+        (INITRECORDS SPYOBJDATA)))
 (DEFINEQ
 
 (SPYOBJ

@@ -176,148 +179,145 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
             then
 '(:INTERPRETER CL:EVAL])
 )
 
-(RPAQ SPYOBJ.IMAGEFNS
 (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
-                                 (FUNCTION SPYOBJ.IMAGEBOX)
-                                 (FUNCTION SPYOBJ.SAVE)
-                                 (FUNCTION SPYOBJ.GET)
-                                 (FUNCTION SPYOBJ.COPY)
-                                 (FUNCTION SPYOBJ.BUTTON)
-                                 (FUNCTION SPYOBJ.COPYIN)
-                                 NIL NIL NIL NIL NIL NIL 'SPYNODE))
+(RPAQ SPYOBJ.IMAGEFNS

+      (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
+             (FUNCTION SPYOBJ.IMAGEBOX)
+             (FUNCTION SPYOBJ.SAVE)
+             (FUNCTION SPYOBJ.GET)
+             (FUNCTION SPYOBJ.COPY)
+             (FUNCTION SPYOBJ.BUTTON)
+             (FUNCTION SPYOBJ.COPYIN)
+             NIL NIL NIL NIL NIL NIL 'SPYNODE))
 (DECLARE%: DONTCOPY DOEVAL@COMPILE 
 (DECLARE%: EVAL@COMPILE
 
-(ACCESSFNS FX
 ((FXBLOCK (ADDSTACKBASE DATUM)))           (* ; "frame extension index")

-                  (BLOCKRECORD FXBLOCK ((FLAGS BITS 3)       (* ; "= \STK.FX")

-                                        (FAST FLAG)
-                                        (NIL FLAG)
-                                        (INCALL FLAG)        (* ; 
-
                                                           "set when fncall microcode has to punt")

-                                        (VALIDNAMETABLE FLAG)(* ; 
-
                                "if on, NAMETABLE field is filled in.  If off, is same as FNHEADER")

-                                        (NOPUSH FLAG)        (* ; 
-
                         "when returning to this frame, don't push a value.  Set by interrupt code")

-                                        (USECNT BITS 8)
-                                        (%#ALINK WORD)       (* ; "low bit is SLOWP")

-                                        (FNHEADER FULLXPOINTER)
-                                        (NEXTBLOCK WORD)
-                                        (PC WORD)
-                                        (NAMETABLE# FULLXPOINTER)
-                                        (%#BLINK WORD)
-                                        (%#CLINK WORD)))
-                  (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
-                                        (NIL BYTE)
-                                        (NIL BITS 15)        (* ; "most of the bits of #ALINK")

-                                        (SLOWP FLAG)         (* ; 
-
                         "if on, then BLINK and CLINK fields are valid.  If off, they are implicit")

-                                        (NIL FULLXPOINTER 2)
-                                        (NAMETABHI WORD)
-                                        (NAMETABLO WORD)))
-                  (TYPE?
 (IEQ (fetch
 (FX FLAGS) of
 DATUM)
-                                  \STK.FX))
-                  [ACCESSFNS FX ((NAMETABLE (COND
-                                               ((fetch
 (FX VALIDNAMETABLE) of
 DATUM)
-                                                (fetch
 (FX NAMETABLE#) of
 DATUM))
-                                               (T (fetch
 (FX FNHEADER) of
 DATUM)))
-                                        (PROGN (replace
 (FX FAST) of
 DATUM with
 NIL)
-                                               (replace
 (FX NAMETABLE#) of
 DATUM with

-                                                                                         NEWVALUE)
-                                               (replace
 (FX VALIDNAMETABLE) of
 DATUM
-                                                  with
 T)))
-                                 (FRAMENAME (fetch
 (FNHEADER FRAMENAME)
-                                               of
 (fetch
 (FX NAMETABLE) of
 DATUM)))
-                                 (INVALIDP (EQ DATUM 0))     (* ; 
-
                                   "true when A/CLink points at nobody, i.e. FX is bottom of stack")

-                                 [FASTP (NOT (fetch
 (FX SLOWP) of
 DATUM))
-                                        (PROGN (CHECK (NULL NEWVALUE))
-                                               (COND
-                                                  ((fetch
 (FX FASTP) of
 DATUM)
-                                                   (replace
 (FX %#BLINK) of
 DATUM
-                                                      with
 (fetch
 (FX DUMMYBF) of
 DATUM))
-                                                   (replace
 (FX %#CLINK) of
 DATUM
-                                                      with
 (fetch
 (FX %#ALINK) of
 DATUM))
-                                                   (replace
 (FX SLOWP) of
 DATUM with

-                                                                                        T]
-                                 [BLINK (COND
-                                           ((fetch
 (FX FASTP) of
 DATUM)
-                                            (fetch
 (FX DUMMYBF) of
 DATUM))
-                                           (T (fetch
 (FX %#BLINK) of
 DATUM)))
-                                        (PROGN (replace
 (FX %#BLINK) of
 DATUM with
 
-                                                                                            NEWVALUE)
-                                               (COND
-                                                  ((fetch
 (FX FASTP) of
 DATUM)
-                                                   (replace
 (FX %#CLINK) of
 DATUM
-                                                      with
 (fetch
 (FX %#ALINK) of
 DATUM))
-                                                   (replace
 (FX SLOWP) of
 DATUM with

-                                                                                        T]
-                                 [CLINK (IDIFFERENCE (COND
-                                                        ((fetch
 (FX FASTP) of
 DATUM)
-                                                         (fetch
 (FX %#ALINK) of
 DATUM))
-                                                        (T (fetch
 (FX %#CLINK) of
 DATUM)))
-                                               \#ALINK.OFFSET)
-                                        (PROGN (replace
 (FX %#CLINK) of
 DATUM
-                                                  with
 (IPLUS NEWVALUE \#ALINK.OFFSET))
-                                               (COND
-                                                  ((fetch
 (FX FASTP) of
 DATUM)
-                                                   (replace
 (FX %#BLINK) of
 DATUM
-                                                      with
 (fetch
 (FX DUMMYBF) of
 DATUM))
-                                                   (replace
 (FX SLOWP) of
 DATUM with

-                                                                                        T]
-                                 [ALINK (IDIFFERENCE (FLOOR (fetch
 (FX %#ALINK) of
 DATUM)
-                                                            WORDSPERCELL)
-                                               \#ALINK.OFFSET)
-                                        (PROGN [COND
-                                                  ((fetch
 (FX FASTP) of
 DATUM)
-                                                   (replace
 (FX %#BLINK) of
 DATUM
-                                                      with
 (fetch
 (FX DUMMYBF) of
 DATUM))
-                                                   (replace
 (FX %#CLINK) of
 DATUM
-                                                      with
 (fetch
 (FX %#ALINK) of
 DATUM]
-                                               (replace
 (FX %#ALINK) of
 DATUM
-                                                  with
 (IPLUS NEWVALUE \#ALINK.OFFSET
-                                                                  (SUB1 WORDSPERCELL]
-                                 [ACLINK (SHOULDNT)
-                                        (PROGN [COND
-                                                  ((fetch
 (FX FASTP) of
 DATUM)
-                                                   (replace
 (FX %#BLINK) of
 DATUM
-                                                      with
 (fetch
 (FX DUMMYBF) of
 DATUM]
+(ACCESSFNS FX
 ((FXBLOCK (ADDSTACKBASE DATUM)))               (* ; "frame extension index")

+              (BLOCKRECORD FXBLOCK ((FLAGS BITS 3)           (* ; "= \STK.FX")

+                                    (FAST FLAG)
+                                    (NIL FLAG)
+                                    (INCALL FLAG)            (* ; 
+
                                                             "set when fncall microcode has to punt")

+                                    (VALIDNAMETABLE FLAG)    (* ; 
+
                                  "if on, NAMETABLE field is filled in.  If off, is same as FNHEADER")

+                                    (NOPUSH FLAG)            (* ; 
+
                           "when returning to this frame, don't push a value.  Set by interrupt code")

+                                    (USECNT BITS 8)
+                                    (%#ALINK WORD)           (* ; "low bit is SLOWP")

+                                    (FNHEADER FULLXPOINTER)
+                                    (NEXTBLOCK WORD)
+                                    (PC WORD)
+                                    (NAMETABLE# FULLXPOINTER)
+                                    (%#BLINK WORD)
+                                    (%#CLINK WORD)))
+              (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
+                                    (NIL BYTE)
+                                    (NIL BITS 15)            (* ; "most of the bits of #ALINK")

+                                    (SLOWP FLAG)             (* ; 
+
                           "if on, then BLINK and CLINK fields are valid.  If off, they are implicit")

+                                    (NIL FULLXPOINTER 2)
+                                    (NAMETABHI WORD)
+                                    (NAMETABLO WORD)))
+              (TYPE?
 (IEQ (fetch
 (FX FLAGS) of
 DATUM)
+                          \STK.FX))
+              [ACCESSFNS FX ((NAMETABLE (COND
+                                           ((fetch
 (FX VALIDNAMETABLE) of
 DATUM)
+                                            (fetch
 (FX NAMETABLE#) of
 DATUM))
+                                           (T (fetch
 (FX FNHEADER) of
 DATUM)))
+                                    (PROGN (replace
 (FX FAST) of
 DATUM with
 NIL)
+                                           (replace
 (FX NAMETABLE#) of
 DATUM with
 NEWVALUE)
+                                           (replace
 (FX VALIDNAMETABLE) of
 DATUM with
 T)))
+                             (FRAMENAME (fetch
 (FNHEADER FRAMENAME) of
 (fetch
 (FX NAMETABLE)
+                                                                          of
 DATUM)))
+                             (INVALIDP (EQ DATUM 0))         (* ; 
+
                                     "true when A/CLink points at nobody, i.e. FX is bottom of stack")

+                             [FASTP (NOT (fetch
 (FX SLOWP) of
 DATUM))
+                                    (PROGN (CHECK (NULL NEWVALUE))
+                                           (COND
+                                              ((fetch
 (FX FASTP) of
 DATUM)
+                                               (replace
 (FX %#BLINK) of
 DATUM
+                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM))
                                                (replace
 (FX %#CLINK) of
 DATUM
-                                                  with
 (IPLUS NEWVALUE \#ALINK.OFFSET))
-                                               (replace
 (FX %#ALINK) of
 DATUM
-                                                  with
 (IPLUS NEWVALUE \#ALINK.OFFSET
-                                                                  (SUB1 WORDSPERCELL]
+                                                  with
 (fetch
 (FX %#ALINK) of
 DATUM))
+                                               (replace
 (FX SLOWP) of
 DATUM with
 T]
+                             [BLINK (COND
+                                       ((fetch
 (FX FASTP) of
 DATUM)
+                                        (fetch
 (FX DUMMYBF) of
 DATUM))
+                                       (T (fetch
 (FX %#BLINK) of
 DATUM)))
+                                    (PROGN (replace
 (FX %#BLINK) of
 DATUM with
 NEWVALUE)
+                                           (COND
+                                              ((fetch
 (FX FASTP) of
 DATUM)
+                                               (replace
 (FX %#CLINK) of
 DATUM
+                                                  with
 (fetch
 (FX %#ALINK) of
 DATUM))
+                                               (replace
 (FX SLOWP) of
 DATUM with
 T]
+                             [CLINK (IDIFFERENCE (COND
+                                                    ((fetch
 (FX FASTP) of
 DATUM)
+                                                     (fetch
 (FX %#ALINK) of
 DATUM))
+                                                    (T (fetch
 (FX %#CLINK) of
 DATUM)))
+                                           \#ALINK.OFFSET)
+                                    (PROGN (replace
 (FX %#CLINK) of
 DATUM with
 (IPLUS NEWVALUE 
+                                                                                      \#ALINK.OFFSET)
+                                                  )
+                                           (COND
+                                              ((fetch
 (FX FASTP) of
 DATUM)
+                                               (replace
 (FX %#BLINK) of
 DATUM
+                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM))
+                                               (replace
 (FX SLOWP) of
 DATUM with
 T]
+                             [ALINK (IDIFFERENCE (FLOOR (fetch
 (FX %#ALINK) of
 DATUM)
+                                                        WORDSPERCELL)
+                                           \#ALINK.OFFSET)
+                                    (PROGN [COND
+                                              ((fetch
 (FX FASTP) of
 DATUM)
+                                               (replace
 (FX %#BLINK) of
 DATUM
+                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM))
+                                               (replace
 (FX %#CLINK) of
 DATUM
+                                                  with
 (fetch
 (FX %#ALINK) of
 DATUM]
+                                           (replace
 (FX %#ALINK) of
 DATUM with
 (IPLUS NEWVALUE 
+                                                                                      \#ALINK.OFFSET
+                                                                                      (SUB1 
+                                                                                         WORDSPERCELL
+                                                                                            ]
+                             [ACLINK (SHOULDNT)
+                                    (PROGN [COND
+                                              ((fetch
 (FX FASTP) of
 DATUM)
+                                               (replace
 (FX %#BLINK) of
 DATUM
+                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM]
+                                           (replace
 (FX %#CLINK) of
 DATUM with
 (IPLUS NEWVALUE 
+                                                                                      \#ALINK.OFFSET)
+                                                  )
+                                           (replace
 (FX %#ALINK) of
 DATUM with
 (IPLUS NEWVALUE 
+                                                                                      \#ALINK.OFFSET
+                                                                                      (SUB1 
+                                                                                         WORDSPERCELL
+                                                                                            ]
                                                              (* ; 
-
                                    "replaces A & C Links at once more efficiently than separately")

-                                 (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
+
                                      "replaces A & C Links at once more efficiently than separately")

+                             (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
 
-                                 (* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot.  This means that when a FX is copied, the cell preceding the FX is copied too.")

+                             (* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot.  This means that when a FX is copied, the cell preceding the FX is copied too.")

 
-                                 (IVAR (fetch
 (BF IVAR) of
 (fetch
 (FX DUMMYBF)
-                                                                      of
 DATUM)))
-                                 [CHECKED (AND (type?
 FX DATUM)
-                                               (OR (IEQ (fetch
 (FX DUMMYBF) of
 DATUM)
-                                                        (fetch
 (FX BLINK) of
 DATUM))
-                                                   (AND (fetch
 (BF RESIDUAL)
-                                                           of
 (fetch
 (FX DUMMYBF)
-                                                                     of
 DATUM))
-                                                        (IEQ (fetch
 (BF IVAR)
-                                                                of
 (fetch
 (FX DUMMYBF)
-                                                                          of
 DATUM))
-                                                             (fetch
 (BF IVAR)
-                                                                of
 (fetch
 (FX BLINK)
-                                                                          of
 DATUM]
-                                 (FIRSTPVAR (IPLUS DATUM (fetch
 (FX FXSIZE) of
 T)))
+                             (IVAR (fetch
 (BF IVAR) of
 (fetch
 (FX DUMMYBF) of
 DATUM)))
+                             [CHECKED (AND (type?
 FX DATUM)
+                                           (OR (IEQ (fetch
 (FX DUMMYBF) of
 DATUM)
+                                                    (fetch
 (FX BLINK) of
 DATUM))
+                                               (AND (fetch
 (BF RESIDUAL) of
 (fetch
 (FX DUMMYBF)
+                                                                               of
 DATUM))
+                                                    (IEQ (fetch
 (BF IVAR) of
 (fetch
 (FX DUMMYBF)
+                                                                                of
 DATUM))
+                                                         (fetch
 (BF IVAR) of
 (fetch
 (FX BLINK)
+                                                                                of
 DATUM]
+                             (FIRSTPVAR (IPLUS DATUM (fetch
 (FX FXSIZE) of
 T)))
                                                              (* ; "stack offset of PVAR0")

-                                 (FXSIZE (PROGN 10))         (* ; 
-
                                                           "fixed overhead from flags thru clink")

-                                 (PADDING (PROGN 4))         (* ; 
-
                                                          "doublecell of garbage for microcode use")

-                                 (FIRSTTEMP (IPLUS (fetch
 (FX FIRSTPVAR) of
 DATUM)
-                                                   (fetch
 (FX NPVARWORDS) of
 DATUM)
-                                                   (fetch
 (FX PADDING) of
 DATUM)))
+                             (FXSIZE (PROGN 10))             (* ; 
+
                                                             "fixed overhead from flags thru clink")

+                             (PADDING (PROGN 4))             (* ; 
+
                                                            "doublecell of garbage for microcode use")

+                             (FIRSTTEMP (IPLUS (fetch
 (FX FIRSTPVAR) of
 DATUM)
+                                               (fetch
 (FX NPVARWORDS) of
 DATUM)
+                                               (fetch
 (FX PADDING) of
 DATUM)))
                                                              (* ; 
-
                                               "note that NPVARWORDS is obtained from the FNHEADER")

-                                 (SIZE (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 DATUM)
-                                              DATUM])
+
                                                 "note that NPVARWORDS is obtained from the FNHEADER")

+                             (SIZE (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 DATUM)
+                                          DATUM])
 
 (RECORD SPYOBJDATA
 (CACHEDLABEL PERCENT LABEL))
 )
@@ -745,7 +745,9 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
            ", " TOPCOUNT " samples"])
 
 (SPY.MAKE.TREE

-  [LAMBDA (TREES SPYDATA WINDOW)
                      (* ; "Edited 28-Apr-94 13:59 by sybalsky")

+  [LAMBDA (TREES SPYDATA WINDOW)                             (* ; "Edited  4-Jan-2022 14:08 by rmk")

+                                                             (* ; 
+
                                                             "Edited 28-Apr-94 13:59 by sybalsky")

     (PROG (GRAPH IDS W H THRSH TOPCOUNT (*PACKAGE* (fetch
 (SPYDATA PACKAGE) of
 SPYDATA))
                  (*READTABLE* (fetch
 (SPYDATA READTABLE) of
 SPYDATA))
                  (*PRINT-CASE* (fetch
 (SPYDATA PRINT-CASE) of
 SPYDATA)))
@@ -755,8 +757,7 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
           (SETQ THRSH (QUOTIENT (TIMES TOPCOUNT (fetch
 (SPYDATA THRESHOLD) of
 SPYDATA))
                              100))
           (SETQ SPY.NODES)
-          (SETQ SPY.TOPNODES (for
 X in
 TREES collect
 (SPY.MAKEGRAPHNODES
 X THRSH 
-                                                                        SPYDATA)))
+          (SETQ SPY.TOPNODES (for
 X in
 TREES collect
 (SPY.MAKEGRAPHNODES
 X THRSH SPYDATA)))
           (SETQ TITLE (SPY.TITLE
 (CAR SPY.TOPNODES)
                              TOPCOUNT SPYDATA))
           (SETQ SPY.WINDOW (SHOWGRAPH (LAYOUTGRAPH (REVERSE SPY.NODES)
@@ -773,7 +774,8 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
           (WINDOWPROP SPY.WINDOW 'SPYDATA SPYDATA)
           (WINDOWPROP SPY.WINDOW 'TREES TREES)
           (WINDOWPROP SPY.WINDOW 'SPYTITLE TITLE)
-          (WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT])
+          (WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT)
+          (MODERNWINDOW SPY.WINDOW])
 
 (SPY.UPDATE.TITLE

   [LAMBDA (W)
                                         (* ; "Edited 29-Apr-94 14:03 by sybalsky")

@@ -965,23 +967,23 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
 )
 (DECLARE%: EVAL@COMPILE 
 
-[PUTPROPS WITH-SPY MACRO ((FORM)
+(PUTPROPS WITH-SPY
 MACRO
 [(FORM)
                           (PROGN (SPY.START
)
-                                 (PROG1 FORM (SPY.END
]
+                                 (PROG1 FORM (SPY.END
])
 
-[PUTPROPS WITH.SPY MACRO ((FORM)
+(PUTPROPS WITH.SPY
 MACRO
 [(FORM)
                           (PROGN (SPY.START
)
-                                 (PROG1 FORM (SPY.END
]
+                                 (PROG1 FORM (SPY.END
])
 )
 (DECLARE%: DONTCOPY 
 (DECLARE%: EVAL@COMPILE
 
 (DATATYPE SPYRECORD
 (NAME COUNT SUM CALLEES STATUS TREEFROM)
-                        STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT)))
+                    STATUS _ 'NORMAL (INIT (DEFPRINT 'SPYRECORD 'SPY.PRINT)))
 
-(PROPRECORD SPYDATA
 (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE 
-                               READTABLE PRINT-CASE MERGEINFO PENDING)
-                        CUMULATIVE _ T)
+(PROPRECORD SPYDATA
 (DELETED CUMULATIVE MERGETYPE THRESHOLD SPYMENU DEPTH NOGHOSTS PACKAGE READTABLE
+                           PRINT-CASE MERGEINFO PENDING)
+                    CUMULATIVE _ T)
 )
 
 (/DECLAREDATATYPE 'SPYRECORD '(POINTER POINTER POINTER POINTER POINTER POINTER)
@@ -1010,19 +1012,21 @@ Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Co
 
 (FILESLOAD GRAPHER READNUMBER IMAGEOBJ)
 )
+
+(MOVD? 'NILL 'MODERNWINDOW)
 (PUTPROPS SPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1987 1988 1990 1991 1993 1994))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (5474 8081 (SPYOBJ 5484 . 5773) (SPYOBJ.BUTTON 5775 . 5885) (SPYOBJ.SAVE 5887 . 6006) (
-SPYOBJ.COPY 6008 . 6070) (SPYOBJ.GET 6072 . 6201) (SPYOBJ.IMAGEBOX 6203 . 6727) (SPYOBJ.DISPLAY 6729
- . 7028) (SPYOBJ.LABEL 7030 . 7166) (SPYOBJ.HEIGHT 7168 . 7381) (SPYOBJ.COPYIN 7383 . 7426) (
-SPY.COPYBUTTON 7428 . 7520) (SPY.MERGEINFO 7522 . 8079)) (19431 60601 (SPY.FIND.TREE 19441 . 19850) (
-SPY.TOGGLE 19852 . 20042) (SPY.TREE 20044 . 21156) (SPY.LEGEND 21158 . 21508) (SPY.GRAPH.EDITOR 21510
- . 31075) (SPY.END 31077 . 31319) (SPY.MAKEGRAPHNODES 31321 . 33421) (SPY.MAX 33423 . 34306) (
-SPY.MERGE 34308 . 35739) (SPY.MERGE1 35741 . 42224) (SPY.MERGETREE 42226 . 45156) (SPY.NEXT.TREE 45158
- . 45832) (SPY.SUM 45834 . 46523) (SPY.TITLE 46525 . 46742) (SPY.MAKE.TREE 46744 . 48632) (
-SPY.UPDATE.TITLE 48634 . 51210) (SPY.DELETE 51212 . 51747) (SPY.DRAWBOX 51749 . 52274) (
-SPY.BUFFER.ENTRY 52276 . 52514) (SPY.BUTTON 52516 . 53085) (SPY.END.ENTRY 53087 . 53167) (SPY.START 
-53169 . 53453) (SPY.INIT 53455 . 53690) (\SPY.INTERRUPT 53692 . 54328) (SPY.DUMP.BUFFER 54330 . 55790)
- (SPY.START.ENTRY 55792 . 55920) (SPY.ADD.ENTRY 55922 . 56304) (SPY.ORIGINAL 56306 . 57133) (
-SPY.OVERFLOW 57135 . 57236) (SPY.MERGE.CALLEES 57238 . 60274) (SPY.PRINT 60276 . 60599)))))
+  (FILEMAP (NIL (4753 7360 (SPYOBJ 4763 . 5052) (SPYOBJ.BUTTON 5054 . 5164) (SPYOBJ.SAVE 5166 . 5285) (
+SPYOBJ.COPY 5287 . 5349) (SPYOBJ.GET 5351 . 5480) (SPYOBJ.IMAGEBOX 5482 . 6006) (SPYOBJ.DISPLAY 6008
+ . 6307) (SPYOBJ.LABEL 6309 . 6445) (SPYOBJ.HEIGHT 6447 . 6660) (SPYOBJ.COPYIN 6662 . 6705) (
+SPY.COPYBUTTON 6707 . 6799) (SPY.MERGEINFO 6801 . 7358)) (18202 59509 (SPY.FIND.TREE 18212 . 18621) (
+SPY.TOGGLE 18623 . 18813) (SPY.TREE 18815 . 19927) (SPY.LEGEND 19929 . 20279) (SPY.GRAPH.EDITOR 20281
+ . 29846) (SPY.END 29848 . 30090) (SPY.MAKEGRAPHNODES 30092 . 32192) (SPY.MAX 32194 . 33077) (
+SPY.MERGE 33079 . 34510) (SPY.MERGE1 34512 . 40995) (SPY.MERGETREE 40997 . 43927) (SPY.NEXT.TREE 43929
+ . 44603) (SPY.SUM 44605 . 45294) (SPY.TITLE 45296 . 45513) (SPY.MAKE.TREE 45515 . 47540) (
+SPY.UPDATE.TITLE 47542 . 50118) (SPY.DELETE 50120 . 50655) (SPY.DRAWBOX 50657 . 51182) (
+SPY.BUFFER.ENTRY 51184 . 51422) (SPY.BUTTON 51424 . 51993) (SPY.END.ENTRY 51995 . 52075) (SPY.START 
+52077 . 52361) (SPY.INIT 52363 . 52598) (\SPY.INTERRUPT 52600 . 53236) (SPY.DUMP.BUFFER 53238 . 54698)
+ (SPY.START.ENTRY 54700 . 54828) (SPY.ADD.ENTRY 54830 . 55212) (SPY.ORIGINAL 55214 . 56041) (
+SPY.OVERFLOW 56043 . 56144) (SPY.MERGE.CALLEES 56146 . 59182) (SPY.PRINT 59184 . 59507)))))
 STOP

library/SYSEDIT

@@ -1,9 +1,9 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
-
(FILECREATED " 6-Aug-2021 07:35:16" {DSK}<home>larry>ilisp>medley>library>SYSEDIT.;2
 1183   
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "28-Sep-2021 10:16:44" {DSK}<home>larry>medley>library>SYSEDIT.;3
 1307   
 
       changes to%:  (VARS SYSEDITCOMS)
 
-      previous date%: " 6-May-2021 16:22:01" {DSK}<home>larry>ilisp>medley>library>SYSEDIT.;1)
+      previous date%: "24-Sep-2021 20:52:26" {DSK}<home>larry>medley>library>SYSEDIT.;2)
 
 
 (* ; "
@@ -14,19 +14,19 @@ Copyright (c) 1984, 1987, 1990, 2021 by Venue & Xerox Corporation.
 
 (RPAQQ SYSEDITCOMS

        [(VARS (CLISPIFYPRETTYFLG)
-              (MSRECORDTRANFLG T)
               (RECOMPILEDEFAULT 'CHANGES)
               (CLEANUPOPTIONS '(RC F))
               (GLOBALVARFLG T)
               (CLISPIFTRANFLG T)
-              (CROSSCOMPILING 'ASK))
+              (CROSSCOMPILING 'ASK)
+              (DFNFLG 'PROP)
+              (*REPLACE-OLD-EDIT-DATES* NIL)
+              (COPYRIGHTFLG 'PRESERVE))
         (P (RESETVARS ((CROSSCOMPILING T))
                   (LOAD? 'EXPORTS.ALL])
 
 (RPAQQ CLISPIFYPRETTYFLG
 NIL)
 
-(RPAQQ MSRECORDTRANFLG
 T)
-
 (RPAQQ RECOMPILEDEFAULT
 CHANGES)
 
 (RPAQQ CLEANUPOPTIONS
 (RC F))
@@ -37,6 +37,12 @@ Copyright (c) 1984, 1987, 1990, 2021 by Venue & Xerox Corporation.
 
 (RPAQQ CROSSCOMPILING
 ASK)
 
+(RPAQQ DFNFLG
 PROP)
+
+(RPAQQ *REPLACE-OLD-EDIT-DATES*
 NIL)
+
+(RPAQQ COPYRIGHTFLG
 PRESERVE)
+
 (RESETVARS ((CROSSCOMPILING T))
            (LOAD? 'EXPORTS.ALL))
 (PUTPROPS SYSEDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990 2021))

library/SYSEDIT.LCOM

@@ -1,20 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS)
-(FILECREATED " 6-Aug-2021 07:36:12" ("compiled on " {DSK}<home>larry>ilisp>medley>library>SYSEDIT.;2) 
-" 6-Aug-2021 07:14:33" bcompl'd in "FULL  5-Aug-2021 ..." dated " 5-Aug-2021 22:24:43")
-(FILECREATED " 6-Aug-2021 07:35:16" {DSK}<home>larry>ilisp>medley>library>SYSEDIT.;2 1183 changes to%:
- (VARS SYSEDITCOMS) previous date%: " 6-May-2021 16:22:01" 
-{DSK}<home>larry>ilisp>medley>library>SYSEDIT.;1)
-(PRETTYCOMPRINT SYSEDITCOMS)
-(RPAQQ SYSEDITCOMS ((VARS (CLISPIFYPRETTYFLG) (MSRECORDTRANFLG T) (RECOMPILEDEFAULT (QUOTE CHANGES)) (
-CLEANUPOPTIONS (QUOTE (RC F))) (GLOBALVARFLG T) (CLISPIFTRANFLG T) (CROSSCOMPILING (QUOTE ASK))) (P (
-RESETVARS ((CROSSCOMPILING T)) (LOAD? (QUOTE EXPORTS.ALL))))))
-(RPAQQ CLISPIFYPRETTYFLG NIL)
-(RPAQQ MSRECORDTRANFLG T)
-(RPAQQ RECOMPILEDEFAULT CHANGES)
-(RPAQQ CLEANUPOPTIONS (RC F))
-(RPAQQ GLOBALVARFLG T)
-(RPAQQ CLISPIFTRANFLG T)
-(RPAQQ CROSSCOMPILING ASK)
-(RESETVARS ((CROSSCOMPILING T)) (LOAD? (QUOTE EXPORTS.ALL)))
-(PUTPROPS SYSEDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1987 1990 2021))
-NIL

library/TEDIT

@@ -1,14 +1,15 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "19-Apr-2018 12:22:03" {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDIT.;2
 140045 
 
-      changes to%:  (VARS TEDITCOMS)
+
(FILECREATED "30-Dec-2021 20:50:54" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;30
 142870 
 
-      previous date%: "21-Jun-99 20:00:16" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDIT.;1)
+      :CHANGES-TO (FNS TEDIT TEDIT-SEE)
+
+      :PREVIOUS-DATE "28-Dec-2021 11:02:43" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDIT.;24)
 
 
 (* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 1999, 2018 by Venue & Xerox Corporation.  All rights reserved.
+Copyright (c) 1983-1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT TEDITCOMS)
@@ -24,40 +25,40 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
               (TEDIT.DEFAULT.PROPS NIL)
               (TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP))
               (TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU))
-                                                             (* ; 
-
                                            "Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")

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

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

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

               )
         (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
-        (FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE 
+        (FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT-SEE TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE 
              TEDIT.DO.BLUEPENDINGDELETE TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES 
              TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE
              \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN \TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN 
              \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE \TEDIT.DIFFUSE.PARALOOKS 
              \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.")

-        (COMS                                                (* ; "Debugging functions")

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

+        (COMS                                                (* ; "Debugging functions")

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

+        (COMS                                                (* ; "Object-oriented editing")

               (FNS TEDIT.INSERT.OBJECT TEDIT.EDIT.OBJECT TEDIT.FIND.OBJECT TEDIT.FIND.OBJECT.SUBTREE
                    TEDIT.PUT.OBJECT TEDIT.GET.OBJECT TEDIT.OBJECT.CHANGED))
         (FILES TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY
                TEDITPAGE TEDITMENU TEDITFNKEYS)
-        (COMS                                                (* ; "TEDIT Support information")

+        (COMS                                                (* ; "TEDIT Support information")

               (E (SETQ TEDITSYSTEMDATE (DATE)))
               (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.")

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

               (ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
                                               (EXTENSION (TEDIT])
 
@@ -249,21 +250,29 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
                       NIL])
 
 (TEDIT

-  [LAMBDA (TEXT WINDOW DONTSPAWN PROPS)
                  (* ; "Edited 11-Jun-99 14:14 by rmk:")


-                                                             (* ; "Edited 11-Jun-99 14:13 by rmk:")


-                                                             (* ; "Edited 11-Jun-99 14:08 by rmk:")


-                                                             (* ; "Edited  3-Jun-88 14:27 by jds")

+  [LAMBDA (TEXT WINDOW DONTSPAWN PROPS)                      (* ; "Edited 30-Dec-2021 20:50 by rmk")

+                                                             (* ; "Edited 28-Dec-2021 00:12 by rmk")

+                                                             (* ; "Edited 24-Dec-2021 19:21 by rmk")

+                                                             (* ; "Edited 11-Jun-99 14:14 by rmk:")

+                                                             (* ; "Edited  3-Jun-88 14:27 by jds")

 
-    (* ;; "User entry to the text editor.  Takes an optional window to be used for editing")

+    (* ;; "User entry to the text editor.  Takes an optional window to be used for editing")

 
-    (* ;; "DONTSPAWN => Don't try to create a new process for this edit.")

+    (* ;; "DONTSPAWN => Don't try to create a new process for this edit.")

 
-    (PROG (PROC TEDITCREATEDWINDOW)                          (* ; 
-
                                                      "Include the default properties in the list.")

+    (PROG (PROC TEDITCREATEDWINDOW)                          (* ; 
+
                                                        "Include the default properties in the list.")

           [COND
-             ((AND TEXT (ATOM TEXT))                         (* ; 
-
                                      "Make sure the file exists before trying to open the window.")

+             ((AND TEXT (ATOM TEXT))                         (* ; 
+
                                        "Make sure the file exists before trying to open the window.")

               (SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD '((TYPE TEXT]
+          (CL:WHEN (AND WINDOW (OR (LITATOM WINDOW)
+                                   (REGIONP WINDOW)))
+
+              (* ;; "Pass specified and typed regions to TEDIT.CREATEW")

+
+              (PUSH
 PROPS 'REGION-TYPE WINDOW)
+              (SETQ WINDOW NIL))
           (RESETLST
               [RESETSAVE NIL `(AND ,WINDOW (WINDOWPROP ,WINDOW 'TEXTOBJ NIL]
               (WITH.MONITOR TEDIT.STARTUP.MONITORLOCK
@@ -271,7 +280,8 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
                      ((NOT WINDOW)
                       (SETQ TEDITCREATEDWINDOW T)
                       (SETQ WINDOW (COND
-                                      [(OR (NOT TEDIT.DEFAULT.WINDOW)
+                                      [(OR (LISTGET PROPS 'REGION-TYPE)
+                                           (NOT TEDIT.DEFAULT.WINDOW)
                                            (\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW))
                                        (TEDIT.CREATEW (COND
                                                          ((AND TEXT (ATOM TEXT))
@@ -287,28 +297,27 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
                                                                             'REGION)
                                                 TEXT
                                                 (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)))
-                                                             (* ; "Replace the old title")

+                                                             (* ; "Replace the old title")

                                          TEDIT.DEFAULT.WINDOW)))
 
-                      (* ;; 
-
               "Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")

+                      (* ;; 
+
                 "Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")

 
-                      (* ;; 
-
                    "mark that we created the window so that we know we can update the title, etc.")

+                      (* ;; 
+
                      "mark that we created the window so that we know we can update the title, etc.")

 
                       (WINDOWPROP WINDOW 'TEXTOBJ T)))))
           [SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL (APPEND PROPS '(BEING-EDITED T]
-                                                             (* ; 
-
                                                           "Connect the editor to the window")

+                                                             (* ; "Connect the editor to the window")

           (replace
 (TEXTOBJ
 TXTEDITING) of
 (TEXTOBJ
 TEXT) with
 T)
-                                                             (* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")

+                                                             (* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")

           [COND
              (TEDITCREATEDWINDOW (TEXTPROP TEXT 'TEDITCREATEDWINDOW 'T]
           (COND
-             (DONTSPAWN                                      (* ; 
-
                                   "Either no processes running, or specifically not to spawn one.")

+             (DONTSPAWN                                      (* ; 
+
                                     "Either no processes running, or specifically not to spawn one.")

                     (RETURN (\TEDIT2
 TEXT WINDOW T)))
-             (T                                              (* ; "Spawn a process to do the edit.")

+             (T                                              (* ; "Spawn a process to do the edit.")

                 [SETQ PROC (ADD.PROCESS (LIST '\TEDIT2 (KWOTE TEXT)
                                               WINDOW NIL)
                                   'NAME
@@ -322,11 +331,53 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
                 (PROCESSPROP PROC 'WINDOW WINDOW)
                 (COND
                    ((NOT (LISTGET (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS))
-                                'LEAVETTY))                  (* ; 
-
                            "Unless he asked us to leave the tty where it is, TEdit should get it.")

+                                'LEAVETTY))                  (* ; 
+
                              "Unless he asked us to leave the tty where it is, TEdit should get it.")

                     (TTY.PROCESS PROC)))
                 (RETURN PROC])
 
+(TEDIT-SEE

+  [LAMBDA (FILE WINDOW FORMAT TITLE)                         (* ; "Edited 30-Dec-2021 18:03 by rmk")

+                                                             (* ; "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.")

+
+    (* ;; "FORMAT for text files defaults to :UTF-8 if present, otherwise *DEFAULT-EXTERNALFORMAT*")

+
+    (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
+           (LET ((SEESTREAM STREAM)
+                 TSTREAM)
+
+                (* ;; "No need to fiddle with a TEDIT file")

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

+
+                         (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.")

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

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

   [LAMBDA (CH FONT TERMSA)
                                   (* jds "22-OCT-83 19:32")

           
@@ -2192,7 +2243,7 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
 (* ; "TEDIT Support information")

 
 
-(RPAQQ TEDITSYSTEMDATE
 "19-Apr-2018 12:22:04")
+(RPAQQ TEDITSYSTEMDATE
 "30-Dec-2021 20:50:54")
 
 (RPAQ TEDITSUPPORT
 "TEditSupport.PA")
 (DEFINEQ
@@ -2214,23 +2265,23 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993,
 
 
 (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))
+1992 1993 1995 1999 2018 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (4382 115216 (\TEDIT2 4392 . 7143) (COERCETEXTOBJ 7145 . 15921) (TEDIT 15923 . 20892) (
-TEDIT.CHARWIDTH 20894 . 22918) (TEDIT.COPY 22920 . 31356) (TEDIT.DELETE 31358 . 32048) (
-TEDIT.DO.BLUEPENDINGDELETE 32050 . 35117) (TEDIT.INSERT 35119 . 40649) (TEDIT.KILL 40651 . 42208) (
-TEDIT.MAPLINES 42210 . 43609) (TEDIT.MAPPIECES 43611 . 44567) (TEDIT.MOVE 44569 . 54353) (TEDIT.QUIT 
-54355 . 56355) (TEDIT.STRINGWIDTH 56357 . 57028) (TEDIT.\INSERT 57030 . 59055) (TEXTOBJ 59057 . 60182)
- (TEXTSTREAM 60184 . 61799) (\TEDIT.INCLUDE 61801 . 65701) (\TEDIT.INSERT.PIECES 65703 . 75618) (
-\TEDIT.MOVE.PIECEMAPFN 75620 . 77699) (\TEDIT.OBJECT.SHOWSEL 77701 . 81330) (\TEDIT.RESTARTFN 81332 . 
-83327) (\TEDIT.CHARDELETE 83329 . 87291) (\TEDIT.COPY.PIECEMAPFN 87293 . 90518) (\TEDIT.DELETE 90520
- . 98038) (\TEDIT.DIFFUSE.PARALOOKS 98040 . 100804) (\TEDIT.FOREIGN.COPY? 100806 . 104533) (
-\TEDIT.QUIT 104535 . 107681) (\TEDIT.WORDDELETE 107683 . 112516) (\TEDIT1 112518 . 115214)) (115330 
-115446 (\CREATE.TEDIT.RESTART.MENU 115340 . 115444)) (115545 119234 (PLCHAIN 115555 . 115829) (
-PRINTLINE 115831 . 118595) (SEEFILE 118597 . 119232)) (119275 138918 (TEDIT.INSERT.OBJECT 119285 . 
-128362) (TEDIT.EDIT.OBJECT 128364 . 130620) (TEDIT.FIND.OBJECT 130622 . 131515) (
-TEDIT.FIND.OBJECT.SUBTREE 131517 . 132323) (TEDIT.PUT.OBJECT 132325 . 133984) (TEDIT.GET.OBJECT 133986
- . 137185) (TEDIT.OBJECT.CHANGED 137187 . 138916)) (139196 139559 (MAKETEDITFORM 139206 . 139557)))))
+  (FILEMAP (NIL (4336 118040 (\TEDIT2 4346 . 7097) (COERCETEXTOBJ 7099 . 15875) (TEDIT 15877 . 21230) (
+TEDIT-SEE 21232 . 23716) (TEDIT.CHARWIDTH 23718 . 25742) (TEDIT.COPY 25744 . 34180) (TEDIT.DELETE 
+34182 . 34872) (TEDIT.DO.BLUEPENDINGDELETE 34874 . 37941) (TEDIT.INSERT 37943 . 43473) (TEDIT.KILL 
+43475 . 45032) (TEDIT.MAPLINES 45034 . 46433) (TEDIT.MAPPIECES 46435 . 47391) (TEDIT.MOVE 47393 . 
+57177) (TEDIT.QUIT 57179 . 59179) (TEDIT.STRINGWIDTH 59181 . 59852) (TEDIT.\INSERT 59854 . 61879) (
+TEXTOBJ 61881 . 63006) (TEXTSTREAM 63008 . 64623) (\TEDIT.INCLUDE 64625 . 68525) (\TEDIT.INSERT.PIECES
+ 68527 . 78442) (\TEDIT.MOVE.PIECEMAPFN 78444 . 80523) (\TEDIT.OBJECT.SHOWSEL 80525 . 84154) (
+\TEDIT.RESTARTFN 84156 . 86151) (\TEDIT.CHARDELETE 86153 . 90115) (\TEDIT.COPY.PIECEMAPFN 90117 . 
+93342) (\TEDIT.DELETE 93344 . 100862) (\TEDIT.DIFFUSE.PARALOOKS 100864 . 103628) (\TEDIT.FOREIGN.COPY?
+ 103630 . 107357) (\TEDIT.QUIT 107359 . 110505) (\TEDIT.WORDDELETE 110507 . 115340) (\TEDIT1 115342 . 
+118038)) (118154 118270 (\CREATE.TEDIT.RESTART.MENU 118164 . 118268)) (118369 122058 (PLCHAIN 118379
+ . 118653) (PRINTLINE 118655 . 121419) (SEEFILE 121421 . 122056)) (122099 141742 (TEDIT.INSERT.OBJECT 
+122109 . 131186) (TEDIT.EDIT.OBJECT 131188 . 133444) (TEDIT.FIND.OBJECT 133446 . 134339) (
+TEDIT.FIND.OBJECT.SUBTREE 134341 . 135147) (TEDIT.PUT.OBJECT 135149 . 136808) (TEDIT.GET.OBJECT 136810
+ . 140009) (TEDIT.OBJECT.CHANGED 140011 . 141740)) (142020 142383 (MAKETEDITFORM 142030 . 142381)))))
 STOP

library/TEDITDCL.LCOM

@@ -1,9 +1,9 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "30-Apr-2021 17:26:58" ("compiled on " 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2) "29-Apr-2021 09:48:40" brecompiled 
-exprs%: nothing in "Medley  Full Sysout 30-Apr-2021 ..." dated "30-Apr-2021 14:49:58")
-(FILECREATED "30-Apr-2021 17:26:17" {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2 
-86155 previous date%: "25-Aug-94 10:53:00" 
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "21-Sep-2021 12:53:57" ("compiled on " 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2) "20-Sep-2021 11:14:12" brecompiled 
+exprs%: nothing in "FULL 20-Sep-2021 ..." dated "20-Sep-2021 11:14:18")
+(FILECREATED "21-Sep-2021 12:53:57" {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;2 
+86549 changes to%: (VARS TEDITDCLCOMS) previous date%: "30-Apr-2021 17:26:17" 
 {DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITDCL.;1)
 (PRETTYCOMPRINT TEDITDCLCOMS)
 (RPAQQ TEDITDCLCOMS ((* ;;; 
@@ -38,7 +38,9 @@ WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6)
 8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))) (DECLARE%: EVAL@COMPILE DONTCOPY 
 (CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))) (* ;; "FROM TEDITWINDOW") (
 DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) (INITRECORDS TEDITCARET) (* ;; 
-"FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;;; "THE END") (COMS (* ;; 
+"FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;; "FROM TEDITHCPY and TEDITSCREEN") (DECLARE%: 
+EVAL@COMPILE DONTCOPY (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)) (* ;;; "THE END") (
+COMS (* ;; 
 "Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character "
 ) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) (* ; 
 "Must not break before this character (e.g. Japanese right-paren)") (NOTAFTER.LB 2) (* ; 

library/TEDITHCPY

@@ -1,11 +1,11 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "28-Jun-2021 12:35:45" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;2
 105754 
 
-      changes to%:  (FNS \TEDIT.HARDCOPY.FORMATLINE)
+
(FILECREATED "26-Jan-2022 23:03:27" {DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITHCPY.;15
 106802 
 
-      previous date%: "25-Aug-94 10:54:07" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>TEDITHCPY.;1)
+      :CHANGES-TO (VARS TEDITHCPYCOMS)
+
+      :PREVIOUS-DATE "27-Sep-2021 23:28:48" 
+{DSK}<Users>kaplan>Local>medley3.5>my-medley>library>TEDITHCPY.;14)
 
 
 (* ; "
@@ -20,43 +20,48 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
                (FILES (LOADCOMP)
                       TEDITDCL))
         (COMS 
-              (* ;; "Generic interface functions and common code")

+              (* ;; "Generic interface functions and common code")

 
               (FNS TEDIT.HARDCOPY TEDIT.HCPYFILE \TEDIT.HARDCOPY.DISPLAYLINE 
                    \TEDIT.HARDCOPY.FORMATLINE \DOFORMATTING.HARDCOPY \TEDIT.HARDCOPY.MODIFYLOOKS 
                    \TEDIT.HCPYLOOKS.UPDATE \TEDIT.HCPYFMTSPEC \TEDIT.INTEGER.IMAGEBOX))
         (COMS 
-              (* ;; "Functions for scaling distances and regions as needed during hardcopy.")

+              (* ;; "Functions for scaling distances and regions as needed during hardcopy.")

 
               (FNS \TEDIT.SCALE \TEDIT.SCALEREGION))
         (COMS 
-              (* ;; "PRESS-specific code")

+              (* ;; "PRESS-specific code")

 
               (VARS (TEDIT.DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 23495)))
-                                                             (* ; 
-
                                                           "0.75 inches from bottom, 1 from top")

-              )
+                                                             (* ; 
+
                                                             "0.75 inches from bottom, 1 from top")
)
         [COMS 
-              (* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.")

+              (* ;; "Support for the window-menu's HARDCOPY button, LISTFILES, etc.")

 
               (FNS TEDIT.HARDCOPYFN \TEDIT.HARDCOPY \TEDIT.PRESS.HARDCOPY)
-              (P (LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
-                        'TEDIT
-                        (FUNCTION \TEDIT.HARDCOPY)))
+              [P (LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
+                      (COND (IPVALUES                        (* ; 
+
                                          "Only install INTERPRESS printing if INTERPRESS is loaded.")

+                                   (LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
               (P (LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
-                      (COND (PRESSVALUES                     (* ; 
-
                                                  "Only install PRESS printing if PRESS is loaded.")

+                      (COND (PRESSVALUES                     (* ; 
+
                                                    "Only install PRESS printing if PRESS is loaded.")

                                    (LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
-        (COMS 
-              (* ;; "vars for Japanese Line Break")

+        [COMS 
+              (* ;; "vars for Japanese Line Break")

 
-              [VARS (TEDIT.DONT.BREAK.CHARS '(8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251
-                                                   9253 9255 9257 9283 9315 9317 9319 9326 9505 9507
-                                                   9509 9511 9513 9539 9571 9573 9575 9582))
-                    (TEDIT.DONT.LAST.CHARS '(8524 8538 8536 8534]
-              (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS))
+              (INITVARS (TEDIT.DONT.BREAK.CHARS (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" 
+                                                                 "41,115" "41,133" "41,131" "41,127"
+                                                                 "Hira,41" "Hira,43" "Hira,45" 
+                                                                 "Hira,47" "Hira,51" "Hira,103" 
+                                                                 "Hira,143" "Hira,145" "Hira,147" 
+                                                                 "Hira,156" "Kata,41" "Kata,43" 
+                                                                 "Kata,45" "Kata,47" "Kata,51" 
+                                                                 "Kata,103" "Kata,143" "Kata,145" 
+                                                                 "Kata,147" "Kata,156")))
+                     (TEDIT.DONT.LAST.CHARS (CHARCODE ("41,114" "41,132" "41,130" "41,126"]
         (COMS 
-              (* ;; "Support for hardcopying several files as one document")

+              (* ;; "Support for hardcopying several files as one document")

 
               (FNS TEDIT-BOOK))))
 
@@ -1512,22 +1517,22 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
 (DEFINEQ
 
 (TEDIT.HARDCOPYFN

-  [LAMBDA (WINDOW IMAGESTREAM)
                          (* ; "Edited 12-Jun-90 18:35 by mitani")

+  [LAMBDA (WINDOW IMAGESTREAM)
                          (* ; "Edited 21-Sep-2021 15:33 by rmk:")

 
-    (* ;; 
-
 "This is the TEdit HARDCOPYFN, hooking into the system's standard Hardcopy window-menu operation.")

+    (* ;; 
+
 "This is the TEdit HARDCOPYFN, hooking into the system's standard Hardcopy window-menu operation.")

 
     (PROG ((TEXTOBJ (TEXTOBJ WINDOW))
            (TEXTSTREAM (TEXTSTREAM WINDOW)))
 
-     (* ;; "TEXTSTREAM is bound here so we don't drop the steam on the floor if the window goes away, since the TEXTOBJ only has an XPOINTER to the stream in it.  Please don't remove this binding!")

+     (* ;; "TEXTSTREAM is bound here so we don't drop the steam on the floor if the window goes away, since the TEXTOBJ only has an XPOINTER to the stream in it.  Please don't remove this binding!")

 
           (RESETLST
               [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ)
                      '(AND (\TEDIT.MARKINACTIVE OLDVALUE]
               (replace
 (TEXTOBJ EDITOPACTIVE) of
 TEXTOBJ with
 'Hardcopy)
-              (TEDIT.FORMAT.HARDCOPY TEXTOBJ IMAGESTREAM)))  (* ; "Build the hardcopy")

-    ])
+                                                             (* ; "Build the hardcopy")

+              (TEDIT.FORMAT.HARDCOPY TEXTOBJ IMAGESTREAM))])
 
 (\TEDIT.HARDCOPY

   [LAMBDA (FILE PFILE)
                                  (* ; "Edited 12-Jun-90 18:35 by mitani")

@@ -1562,14 +1567,16 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
         PFILE)])
 )
 
-(LISTPUT (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES))
-       'TEDIT
-       (FUNCTION \TEDIT.HARDCOPY))
+[LET [(IPVALUES (ASSOC 'CONVERSION (ASSOC 'INTERPRESS PRINTFILETYPES]
+     (COND
+        (IPVALUES                                            (* ; 
+
                                          "Only install INTERPRESS printing if INTERPRESS is loaded.")

+               (LISTPUT IPVALUES 'TEDIT (FUNCTION \TEDIT.HARDCOPY]
 
 [LET [(PRESSVALUES (ASSOC 'CONVERSION (ASSOC 'PRESS PRINTFILETYPES]
      (COND
-        (PRESSVALUES                                         (* ; 
-
                                                  "Only install PRESS printing if PRESS is loaded.")

+        (PRESSVALUES                                         (* ; 
+
                                                    "Only install PRESS printing if PRESS is loaded.")

                (LISTPUT PRESSVALUES 'TEDIT (FUNCTION \TEDIT.PRESS.HARDCOPY]
 
 
@@ -1577,15 +1584,13 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
 (* ;; "vars for Japanese Line Break")

 
 
-(RPAQQ TEDIT.DONT.BREAK.CHARS
 (8482 8483 8491 8492 8508 8525 8539 8537 8535 9249 9251 9253 9255 
-                                        9257 9283 9315 9317 9319 9326 9505 9507 9509 9511 9513 9539 
-                                        9571 9573 9575 9582))
+(RPAQ? TEDIT.DONT.BREAK.CHARS

+       (CHARCODE ("41,42" "41,43" "41,53" "41,54" "41,74" "41,115" "41,133" "41,131" "41,127" 
+                        "Hira,41" "Hira,43" "Hira,45" "Hira,47" "Hira,51" "Hira,103" "Hira,143" 
+                        "Hira,145" "Hira,147" "Hira,156" "Kata,41" "Kata,43" "Kata,45" "Kata,47" 
+                        "Kata,51" "Kata,103" "Kata,143" "Kata,145" "Kata,147" "Kata,156")))
 
-(RPAQQ TEDIT.DONT.LAST.CHARS
 (8524 8538 8536 8534))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS)
-)
+(RPAQ? TEDIT.DONT.LAST.CHARS
 (CHARCODE ("41,114" "41,132" "41,130" "41,126")))
 
 
 
@@ -1612,11 +1617,11 @@ Copyright (c) 1983-1994, 2021 by Venue & Xerox Corporation.
 (PUTPROPS TEDITHCPY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 
 1991 1992 1993 1994 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3088 99806 (TEDIT.HARDCOPY 3098 . 4349) (TEDIT.HCPYFILE 4351 . 6425) (
-\TEDIT.HARDCOPY.DISPLAYLINE 6427 . 20572) (\TEDIT.HARDCOPY.FORMATLINE 20574 . 67896) (
-\DOFORMATTING.HARDCOPY 67898 . 81191) (\TEDIT.HARDCOPY.MODIFYLOOKS 81193 . 83600) (
-\TEDIT.HCPYLOOKS.UPDATE 83602 . 94210) (\TEDIT.HCPYFMTSPEC 94212 . 99232) (\TEDIT.INTEGER.IMAGEBOX 
-99234 . 99804)) (99895 100979 (\TEDIT.SCALE 99905 . 100199) (\TEDIT.SCALEREGION 100201 . 100977)) (
-101222 103719 (TEDIT.HARDCOPYFN 101232 . 102083) (\TEDIT.HARDCOPY 102085 . 102994) (
-\TEDIT.PRESS.HARDCOPY 102996 . 103717)) (104701 105604 (TEDIT-BOOK 104711 . 105602)))))
+  (FILEMAP (NIL (3784 100502 (TEDIT.HARDCOPY 3794 . 5045) (TEDIT.HCPYFILE 5047 . 7121) (
+\TEDIT.HARDCOPY.DISPLAYLINE 7123 . 21268) (\TEDIT.HARDCOPY.FORMATLINE 21270 . 68592) (
+\DOFORMATTING.HARDCOPY 68594 . 81887) (\TEDIT.HARDCOPY.MODIFYLOOKS 81889 . 84296) (
+\TEDIT.HCPYLOOKS.UPDATE 84298 . 94906) (\TEDIT.HCPYFMTSPEC 94908 . 99928) (\TEDIT.INTEGER.IMAGEBOX 
+99930 . 100500)) (100591 101675 (\TEDIT.SCALE 100601 . 100895) (\TEDIT.SCALEREGION 100897 . 101673)) (
+101918 104469 (TEDIT.HARDCOPYFN 101928 . 102833) (\TEDIT.HARDCOPY 102835 . 103744) (
+\TEDIT.PRESS.HARDCOPY 103746 . 104467)) (105749 106652 (TEDIT-BOOK 105759 . 106650)))))
 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/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

library/UNICODE

@@ -1,18 +1,16 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "21-Aug-2021 13:13:04" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;193
 64903  
+
(FILECREATED "30-Sep-2021 16:03:18" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;194
 64783  
 
-      changes to%:  (FNS MAKE-UNICODE-TRANSLATION-TABLES)
-
-      previous date%: " 8-Aug-2021 13:10:17" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;192)
+      previous date%: "21-Aug-2021 13:13:04" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>UNICODE.;193)
 
 
 (PRETTYCOMPRINT UNICODECOMS)
 
 (RPAQQ UNICODECOMS

        [(COMS 
-              (* ;; "External formats")

+              (* ;; "External formats")

 
               (FNS UTF8.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN)
               (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16.BACKCCODEFN)
@@ -25,14 +23,14 @@
               (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE))
               (FNS XTOUCODE UTOXCODE))
         [COMS 
-              (* ;; "Unicode mapping files")

+              (* ;; "Unicode mapping files")

 
               (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING WRITE-UNICODE-MAPPING 
                    WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER WRITE-UNICODE-MAPPING-FILENAME
                    )
               (VARS XCCS-SET-NAMES)
               
-              (* ;; "Automate dumping of a documentation prefix")

+              (* ;; "Automate dumping of a documentation prefix")

 
               [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" 
                                                                               :RADIX 16))
@@ -43,7 +41,7 @@
               (P (PUSHNEW UNICODEDIRECTORIES (PACK* (UNIX-GETENV "MEDLEYDIR")
                                                     '/unicode/xerox/]
         (COMS 
-              (* ;; "Set up translation tables for UTF8 and UTFBE external formats")

+              (* ;; "Set up translation tables for UTF8 and UTFBE external formats")

 
               (FNS MAKE-UNICODE-TRANSLATION-TABLES)
               [INITVARS (DEFAULT-XCCS-CHARSETS '(LATIN SYMBOLS1 SYMBOLS2 EXTENDED-LATIN FORMS 
@@ -63,7 +61,7 @@
                                                  "NOTE: UNICODE requires EXPORTS.ALL for compilation"
                                                        T)))
                
-               (* ;; "These control the layout of the translation tables.  Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter")

+               (* ;; "These control the layout of the translation tables.  Since many of the upper panels are sparse, doing it per-panel (128) seems more space-efficient, and residual alists can be shorter")

 
                (CONSTANTS (TRANSLATION-SEGMENT-SIZE 128)
                       (MAX-ALIST-LENGTH 10)
@@ -78,13 +76,13 @@
 (DEFINEQ
 
 (UTF8.OUTCHARFN

-  [LAMBDA (STREAM CHARCODE RAW)
                         (* ; "Edited  8-Aug-2021 13:02 by rmk:")


-                                                            (* ; "Edited 17-Aug-2020 08:45 by rmk:")


-                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

+  [LAMBDA (STREAM CHARCODE RAW)
                         (* ; "Edited  8-Aug-2021 13:02 by rmk:")


+                                                            (* ; "Edited 17-Aug-2020 08:45 by rmk:")


+                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

 
-    (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.")

+    (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.")

 
-    (* ;; "Print UTF8 sequence for CHARCODE.  Do not do XCCS to Unicode translation if RAW.")

+    (* ;; "Print UTF8 sequence for CHARCODE.  Do not do XCCS to Unicode translation if RAW.")

 
     (IF
 (EQ CHARCODE (CHARCODE EOL))
         THEN
 (FREPLACE
 (STREAM CHARPOSITION) OF
 STREAM WITH
 0)
@@ -97,13 +95,13 @@
                DO
 (IF
 (ILESSP C 128)
                           THEN
 (\BOUT STREAM C)
                         ELSEIF
 (ILESSP C 2048)
-                          THEN
                           (* ; "x800")

+                          THEN
                           (* ; "x800")

                                 (\BOUT STREAM (LOGOR (LLSH 3 6)
                                                      (LRSH C 6)))
                                 (\BOUT STREAM (LOGOR (LLSH 2 6)
                                                      (LOADBYTE C 0 6)))
                         ELSEIF
 (ILESSP C 65536)
-                          THEN
                           (* ; "x10000")

+                          THEN
                           (* ; "x10000")

                                 (\BOUT STREAM (LOGOR (LLSH 7 5)
                                                      (LRSH C 12)))
                                 (\BOUT STREAM (LOGOR (LLSH 2 6)
@@ -111,7 +109,7 @@
                                 (\BOUT STREAM (LOGOR (LLSH 2 6)
                                                      (LOADBYTE C 0 6)))
                         ELSEIF
 (ILESSP C 2097152)
-                          THEN
                           (* ; "x200000")

+                          THEN
                           (* ; "x200000")

                                 (\BOUT STREAM (LOGOR (LLSH 15 4)
                                                      (LRSH C 18)))
                                 (\BOUT STREAM (LOGOR (LLSH 2 6)
@@ -123,29 +121,29 @@
                         ELSE
 (ERROR "CHARCODE too big for UTF8" C])
 
 (UTF8.INCCODEFN

-  [LAMBDA (STREAM COUNTP RAW)
                           (* ; "Edited  6-Aug-2021 16:02 by rmk:")


-                                                            (* ; "Edited  6-Aug-2020 17:13 by rmk:")

+  [LAMBDA (STREAM COUNTP RAW)
                           (* ; "Edited  6-Aug-2021 16:02 by rmk:")


+                                                            (* ; "Edited  6-Aug-2020 17:13 by rmk:")

 
-    (* ;; "Do not do UNICODE to XCSS translation if RAW.")

+    (* ;; "Do not do UNICODE to XCSS translation if RAW.")

 
-    (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error")

+    (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error")

 
     (DECLARE
 (USEDFREE *BYTECOUNTER*))
     (LET (BYTE1 BYTE2 BYTE3 BYTE4 CODE (COUNT
 1))
          (SETQ BYTE1 (\BIN STREAM))
 
-         (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1")

+         (* ;; "Distinguish on header bytes (modulo peculiar EOF behavior--the caller will get whatever ended up in BYTE1")

 
          (CL:WHEN (SMALLP BYTE1)
              [SETQ CODE (IF
 (ILESSP BYTE1 128)
                             THEN
 
 
-                                  (* ;; 
-
                         "Test first:  Ascii is the common case.  EOL requires its own translation")

+                                  (* ;; 
+
                         "Test first:  Ascii is the common case.  EOL requires its own translation")

 
                                   (SELCHARQ BYTE1
                                        (CR (SELECTC (FETCH
 (STREAM EOLCONVENTION) OF
 STREAM)
-                                               (CR.EOLC      (* ; "Also eq BYTE1")

+                                               (CR.EOLC      (* ; "Also eq BYTE1")

                                                         (CHARCODE EOL))
                                                (CRLF.EOLC (IF
 (EQ (CHARCODE LF)
                                                                       (\PEEKBIN STREAM T))
@@ -160,7 +158,7 @@
                                                BYTE1))
                                        BYTE1)
                           ELSEIF
 (IGEQ BYTE1 (LLSH 15 4))
-                            THEN
                         (* ; "4 bytes")

+                            THEN
                         (* ; "4 bytes")

                                   (SETQ BYTE2 (\BIN STREAM))
                                   (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                                (ILESSP BYTE2 128))
@@ -182,7 +180,7 @@
                                                6)
                                          (LOADBYTE BYTE4 0 6))
                           ELSEIF
 (IGEQ BYTE1 (LLSH 7 5))
-                            THEN
                         (* ; "3 bytes")

+                            THEN
                         (* ; "3 bytes")

                                   (SETQ BYTE2 (\BIN STREAM))
                                   (CL:WHEN (OR (NOT (SMALLP BYTE2))
                                                (ILESSP BYTE2 128))
@@ -197,7 +195,7 @@
                                          (LLSH (LOADBYTE BYTE2 0 6)
                                                6)
                                          (LOADBYTE BYTE3 0 6))
-                          ELSE
                           (* ; "Must be 2 bytes")

+                          ELSE
                           (* ; "Must be 2 bytes")

                                 (SETQ COUNT 2)
                                 (SETQ BYTE2 (\BIN STREAM))
                                 (CL:WHEN (OR (NOT (SMALLP BYTE2))
@@ -211,12 +209,97 @@
          (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT))
          CODE])
 
-(UTF8.PEEKCCODEFN

+(UTF8.PEEKCCODEFN

+  [LAMBDA (STREAM NOERROR RAW)
                          (* ; "Edited 14-Jun-2021 22:53 by rmk:")

+
+    (* ;; "Modeled this after \EUCPEEK on LLREAD.  In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0.  Returns NIL if NOERROR and either invalid UTF8 or end of file.")

+
+    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

+
+    (* ;; "Do not do UNICODE to XCCS translation if RAW")

+
+    (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE)
+          (SETQ BYTE1 (\PEEKBIN STREAM NOERROR))
+
+     (* ;; "Distinguish on header bytex")

+
+          (CL:UNLESS BYTE1 (RETURN NIL))
+          [IF
 (ILESSP BYTE1 128)
+              THEN
 
+
+                    (* ;; 
+
                  "Test first:  Ascii is the common case.  No need to back up, since we peeked.")

+
+                    (SETQ CODE BYTE1)
+            ELSEIF
 (IGEQ BYTE1 (LLSH 15 4))
+              THEN
                                       (* ; "4 bytes")

+                    (\BIN STREAM)
+                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
+                                    (IGEQ BYTE2 128))
+                        (\BACKFILEPTR STREAM)
+                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
+                        (RETURN CODE))
+                    (\BIN STREAM)
+                    (CL:UNLESS (AND (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
+                                    (IGEQ BYTE3 128))
+                        (\BACKFILEPTR STREAM)
+                        (\BACKFILEPTR STREAM)
+                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
+                        (RETURN CODE))
+                    (\BIN STREAM)
+                    (SETQ BYTE4 (\PEEKBIN STREAM NOERROR))   (* ; 
+
                                                           "PEEK the last, no need to back it up")

+                    (\BACKFILEPTR STREAM)
+                    (\BACKFILEPTR STREAM)
+                    (\BACKFILEPTR STREAM)
+                    (IF
 (AND BYTE4 (IGEQ BYTE4 128))
+                        THEN
 (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 3)
+                                                         18)
+                                                   (LLSH (LOADBYTE BYTE2 0 6)
+                                                         12)
+                                                   (LLSH (LOADBYTE BYTE3 0 6)
+                                                         6)
+                                                   (LOADBYTE BYTE4 0 6)))
+                      ELSEIF
 NOERROR
+                      ELSE
 (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3 BYTE4)))
+            ELSEIF
 (IGEQ BYTE1 (LLSH 7 5))
+              THEN
                                       (* ; "3 bytes")

+                    (\BIN STREAM)
+                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
+                                    (IGEQ BYTE2 128))
+                        (\BACKFILEPTR STREAM)
+                        (OR NOERROR (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2)))
+                        (RETURN CODE))
+                    (\BIN STREAM)
+                    (SETQ BYTE3 (\PEEKBIN STREAM NOERROR))
+                    (\BACKFILEPTR STREAM)
+                    (\BACKFILEPTR STREAM)
+                    (IF
 (AND BYTE3 (IGEQ BYTE3 128))
+                        THEN
 (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 4)
+                                                         12)
+                                                   (LLSH (LOADBYTE BYTE2 0 6)
+                                                         6)
+                                                   (LOADBYTE BYTE3 0 6)))
+                      ELSEIF
 NOERROR
+                      ELSE
 (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2 BYTE3)))
+            ELSE
                                         (* ; "Must be 2 bytes")

+                  (\BIN STREAM)
+                  (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
+                  (\BACKFILEPTR STREAM)
+                  (IF
 (AND BYTE2 (IGEQ BYTE2 128))
+                      THEN
 (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
+                                                       6)
+                                                 (LOADBYTE BYTE2 0 6)))
+                    ELSEIF
 NOERROR
+                    ELSE
 (ERROR "INVALID UTF8 SEQUENCE" (LIST BYTE1 BYTE2]
+          (CL:WHEN (AND CODE (NOT RAW))
+              (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOXCCS*)))
+          (RETURN CODE])
 
 (\UTF8.BACKCCODEFN

-    (* ;; "Modeled this after \EUCPEEK on LLREAD.  In the multi-byte (non-ASCII) case, backs the file pointer to the beginning by the proper number of \BACKFILEPTRs, and returns a count of 0.  Returns NIL if NOERROR and either invalid UTF8 or end of file.")

+  [LAMBDA (STREAM COUNTP)
                               (* ; "Edited  6-Aug-2021 16:04 by rmk:")

 
-    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

+    (* ;; "\BACKFILEPTR is NIL at beginning of FILE, just return COUNT")

 
     (DECLARE
 (USEDFREE *BYTECOUNTER*))
     (BIND
 (C _ 0) WHILE
 (CL:WHEN (\BACKFILEPTR STREAM)
@@ -228,12 +311,12 @@
 (DEFINEQ
 
 (UTF16BE.OUTCHARFN

-
-                    (* ;; 
+  [LAMBDA (STREAM CHARCODE RAW)
                         (* ; "Edited  8-Aug-2021 13:09 by rmk:")


+                                                            (* ; "Edited 30-Jan-2020 23:08 by rmk:")

 
-
+    (* ;; "PRINT UTF16 sequence for CHARCODE.  Do not do XCCS to UNICODE translation if RAW.")

 
-            ELSEIF
 (IGEQ BYTE1 (LLSH 15 4))
+    (* ;; "Not sure about EOL conversion if truly %"raw%"")

 
     (IF
 (EQ CHARCODE (CHARCODE EOL))
         THEN
 (FREPLACE
 (STREAM CHARPOSITION) OF
 STREAM WITH
 0)
@@ -245,10 +328,10 @@
        DO
 (\WOUT STREAM C])
 
 (UTF16BE.INCCODEFN

-                        (\BACKFILEPTR STREAM)
+  [LAMBDA (STREAM COUNTP RAW)
                           (* ; "Edited  6-Aug-2021 16:05 by rmk:")

 
-                        (RETURN CODE))
-                    (\BIN STREAM)
+    (* ;; 
+
  "Do not do UNICODE to XCCS translation if RAW.  Test for SMALLPin case of funky EOF behavior")

 
     (DECLARE
 (USEDFREE *BYTECOUNTER*))
     (LET (CODE BYTE1 BYTE2 COUNT)
@@ -264,14 +347,37 @@
                    CODE
            ELSE
 (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM])
 
-            ELSEIF
 (IGEQ BYTE1 (LLSH 7 5))
+(UTF16BE.PEEKCCODEFN

+  [LAMBDA (STREAM NOERROR RAW)
                          (* ; "Edited 14-Jun-2021 22:58 by rmk:")

+
+    (* ;; "Could be that the caller takes care of backing up the file position if the number of binned-bytes is returned.")

+
+    (* ;; "Do not do UNICODE to XCCS translation if RAW")

+
+    (LET (BYTE1 BYTE2 CODE)
+         (SETQ BYTE1 (\PEEKBIN STREAM NOERROR))
+         (IF
 BYTE1
+             THEN
 (\BIN STREAM)
+                   (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
+                   (\BACKFILEPTR STREAM)
+                   (IF
 BYTE2
+                       THEN
 (SETQ CODE (LOGOR (LLSH BYTE1 8)
+                                                  BYTE2))
+                             (CL:IF RAW
+                                 CODE
+                                 (UNICODE.TRANSLATE CODE *UNICODETOXCCS*))
+                     ELSEIF
 NOERROR
+                       THEN
 NIL)
+           ELSEIF
 NOERROR
+             THEN
 NIL
+           ELSE
 (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2])
 
 (\UTF16.BACKCCODEFN

-                    (CL:UNLESS (AND (SETQ BYTE2 (\PEEKBIN STREAM NOERROR))
+  [LAMBDA (STREAM COUNTP)
                               (* ; "Edited  6-Aug-2021 16:07 by rmk:")

 
-                        (\BACKFILEPTR STREAM)
+    (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.")

 
-                        (RETURN CODE))
+    (* ;; "Common for big-ending and little-ending")

 
     (DECLARE
 (USEDFREE *BYTECOUNTER*))
     (CL:WHEN (\BACKFILEPTR STREAM)
@@ -285,11 +391,11 @@
 (DEFINEQ
 
 (MAKE-UNICODE-FORMATS

-                  (\BIN STREAM)
+  [LAMBDA (EXTERNALEOL)
                                 (* ; "Edited  6-Aug-2021 16:08 by rmk:")

 
-                  (\BACKFILEPTR STREAM)
+    (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")

 
-                      THEN
 (SETQ CODE (LOGOR (LLSH (LOADBYTE BYTE1 0 5)
+    (* ;; "The EXTERNALEOL specifies the EOLCONVENTION of the stream, particularly to produce output files with the desired convention.  On input the macro \CHECKEOLC (LLREAD) coerces only that coding to the internal EOL, which is a mistake.")

 
     (MAKE-EXTERNALFORMAT :UTF-8 (FUNCTION UTF8.INCCODEFN)
            (FUNCTION UTF8.PEEKCCODEFN)
@@ -325,11 +431,11 @@
 (DEFINEQ
 
 (UNICODE.UNMAPPED

-                              CHARCODE
+  [LAMBDA (CODE TRANSLATION-TABLE)
                      (* ; "Edited 11-Aug-2020 20:23 by rmk:")

 
-       DO
 (\WOUT STREAM C])
+    (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODED has no fast mapping in TRANSLATION-TABLE.")

 
-(UTF16BE.INCCODEFN

+    (* ;; "We return an existing entry in the hash array of the table.  If CODE has not previously been seen, we allocate a new code in the forward unmapped hasharray and put the inverse in the backward array.")

 
     (LET ((FORWARD (CL:SVREF TRANSLATION-TABLE N-TRANSLATION-SEGMENTS))
           INVERSE NEXTCODE)
@@ -349,9 +455,9 @@
 (DEFINEQ
 
 (XCCS-UTF8-AFTER-OPEN

-(UTF16BE.PEEKCCODEFN

+  [LAMBDA (STREAM ACCESS PARAMETERS)
                    (* ; "Edited 13-Aug-2020 11:54 by rmk:")

 
-
+    (* ;; "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF8.")

 
     (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
                   [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
@@ -379,11 +485,11 @@
 (DEFINEQ
 
 (XTOUCODE

-    (* ;; "Common for big-ending and little-ending")

+  [LAMBDA (XCCSCODE)
                                    (* ; "Edited  9-Aug-2020 09:04 by rmk:")

     (UNICODE.TRANSLATE XCCSCODE *XCCSTOUNICODE*])
 
 (UTOXCODE

-        (IF
 (\BACKFILEPTR STREAM)
+  [LAMBDA (UNICODE)
                                     (* ; "Edited  9-Aug-2020 09:04 by rmk:")

     (UNICODE.TRANSLATE UNICODE *UNICODETOXCCS*])
 )
 
@@ -394,9 +500,8 @@
 (DEFINEQ
 
 (READ-UNICODE-MAPPING-FILENAMES

-
-    (* ;; "RAW formats do not do XCCS/Unicode translation, just deal with the byte encoding.")

-
+  [LAMBDA (FILESPEC)
                                  (* ; "Edited  5-Aug-2020 15:59 by kaplan")


+                                                            (* ; "Edited  4-Aug-2020 17:31 by rmk:")

     (FOR
 F X CSI INSIDE
 FILESPEC
        COLLECT
 (IF
 (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT)
                                   T UNICODEDIRECTORIES)
@@ -412,24 +517,24 @@
                      ELSE
 F])
 
 (READ-UNICODE-MAPPING

-    (MAKE-EXTERNALFORMAT :UTF-16BE (FUNCTION UTF16BE.INCCODEFN)
+  [LAMBDA (FILESPEC NOPRINT NOERROR)
                    (* ; "Edited  3-Jul-2021 13:37 by rmk:")

 
-           (FUNCTION \UTF16.BACKCCODEFN)
+    (* ;; "Combines the char-mapping tables from FILES coded in the Uncode-CDROM format.  Comments prefixed by # and")

 
-           NIL EXTERNALEOL)
+    (* ;; "               Column 1:  Input hex code in the format 0xXXXX")

 
-                                                   (UTF16BE.INCCODEFN
 STREAM COUNTP T]
+    (* ;; "               Column 2:  Corresponding Unicode code-sequence in the format")

 
-                       (UTF16BE.PEEKCCODEFN
 STREAM NOERROR T]
+    (* ;; "                                            0xXXXX  ... 0xYYYY")

 
-           [FUNCTION (LAMBDA (STREAM CHARCODE)
-                       (UTF16BE.OUTCHARFN
 STREAM CHARCODE T]
+    (* ;; 
+
  "               Column 3:  (after #) Character name in some mapping files, utf-8 character")

 
-)
+    (* ;; "                                     for XCCS mapping files")

 
-(MAKE-UNICODE-FORMATS
 EXTERNALEOL)
+    (* ;; "")

 
-(ADDTOVAR *DEFAULT-EXTERNALFORMATS*
 (UNIX :UTF-8))
+    (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode")

 
     (FOR
 FILE [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] IN
 (
 
                                                                     READ-UNICODE-MAPPING-FILENAMES

@@ -461,18 +566,18 @@
                                                                    (NTHCHARCODE LINE START])
 
 (WRITE-UNICODE-MAPPING

-    (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
+  [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK)
        (* ; "Edited 16-Aug-2020 16:56 by rmk:")

 
-                                          'EXTENSION]
+    (* ;; "Writes a symbol unicode mapping file.  Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")

 
-        (STREAMPROP STREAM 'EXTERNALFORMAT :UTF8))])
+    (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.")

 
-(DECLARE%: EVAL@COMPILE DONTCOPY 
+    (* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab>#  Unicode-char")

 
-
-(PUTPROPS UNICODE.TRANSLATE
 MACRO
 [OPENLAMBDA (CODE TRANSLATION-TABLE)
+    (* ;; 
+
  "If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")

 
-                                                                                    TRANSLATION-SHIFT
+    (* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.")

 
     (IF
 (AND (EQ INCLUDECHARSETS T)
                  (NULL FILE))
@@ -513,15 +618,15 @@
                                      "	#  "
                                      (SELECTC FIRSTRIGHTC
                                          (UNDEFINEDCODE 
-                                                                     (CADR CSI))
+                                                        (* ;; "FFFF")

 
                                                         "UNDEFINED")
                                          (MISSINGCODE 
-                     ELSE
 F])
+                                                      (* ;; "FFFE")

 
                                                       "MISSING")
                                          (IF
 (ILESSP FIRSTRIGHTC 32)
-
+                                             THEN
        (* ; "Control chars")

                                                    [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC
                                                                                  (CHARCODE @]
                                            ELSE
 (CHARACTER FIRSTRIGHTC)))
@@ -535,13 +640,13 @@
                  NIL])
 
 (WRITE-UNICODE-INCLUDED

-    (* ;; "")

+  [LAMBDA (MAPPING INCLUDECHARSETS)
                     (* ; "Edited  4-Aug-2020 17:47 by rmk:")

 
-    (* ;; "Result is a list of (fromcode tocode1 ... tocoden) integer lists (almost always with only a single tocode")

+    (* ;; "CSETINFO is a list of (num string name) for each included character set.")

 
     (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING)
 
-                                                                             FILESPEC)
+         (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings")

 
          [SETQ ICSETS (FOR
 C POS KNOWN INSIDE
 (OR INCLUDECHARSETS (FOR
 CSI IN
 
                                                                                        XCCS-SET-NAMES
@@ -569,13 +674,13 @@
                                                                                 ICSETS))
                            COLLECT
 
 
-  [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK)
        (* ; "Edited 16-Aug-2020 16:56 by rmk:")

+                                 (* ;; "The attested subset of INCLUDED")

 
                                  (CL:UNLESS (MEMB CSI CSETINFO)
                                         (PUSH
 CSETINFO CSI))
                                  M))
 
-    (* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab>#  Unicode-char")

+         (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges")

 
          (SETQ CSETINFO (SORT CSETINFO T))
          [SETQ RANGES (FOR
 CTAIL C START END ON
 (FOR
 CSI IN
 CSETINFO
@@ -587,7 +692,7 @@
                                               COLLECT
 (SETQ CTAIL (CDR CTAIL))
                                                     (SETQ END (CAR CTAIL]
 
-                                                                              MAPPING
+         (* ;; "Split out groups of less than 3.  But if a range exhaustively covers a known subset (like JIS), replace by the name")

 
          [SETQ RANGES (FOR
 R STR KNOWN LAST IN
 RANGES
                          JOIN
 (SETQ LAST (CAR (LAST R)))
@@ -607,9 +712,9 @@
          (CL:VALUES IMAPPING CSETINFO RANGES])
 
 (WRITE-UNICODE-MAPPING-HEADER

-                              (CL:UNLESS (EQ CSET (LRSH LEFTC 8))
+  [LAMBDA (STREAM CSETINFO RANGES)
                      (* ; "Edited  4-Aug-2020 17:38 by rmk:")

 
-                                  (SETQ CSI (ASSOC CSET CSETINFO))
+    (* ;; "Writes the standard per-file header information")

 
     (FOR
 LINE IN
 UNICODE-MAPPING-HEADER
        DO
 (PRINTOUT STREAM "#" 2)
@@ -620,7 +725,7 @@
                           THEN
 (PRINTOUT STREAM "s:" -4)
                                 (FOR
 R IN
 RANGES DO
 (PRINTOUT STREAM R " "))
                                 (TERPRI STREAM)
-                                         (UNDEFINEDCODE 
+                        ELSE
                             (* ; "Singleton")

                               (PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
                                      " "
                                      (CADDAR CSETINFO)))
@@ -632,7 +737,7 @@
     (TERPRI STREAM])
 
 (WRITE-UNICODE-MAPPING-FILENAME

-                                           ELSE
 (CHARACTER FIRSTRIGHTC)))
+  [LAMBDA (FILE CSETINFO RANGES)
                        (* ; "Edited  4-Aug-2020 19:34 by rmk:")

     (PACKFILENAME 'BODY [OR FILE (CONCATLIST
                                   (CONS 'XCCS- (IF
 (CDR CSETINFO)
                                                    THEN
 (FOR
 RTAIL R ON
 RANGES
@@ -736,53 +841,53 @@
 (DEFINEQ
 
 (MAKE-UNICODE-TRANSLATION-TABLES

-                 (PRINTOUT STREAM LINE T)))
-    (TERPRI STREAM])
+  [LAMBDA (MAPPING LTORVAR RTOLVAR)
                     (* ; "Edited 21-Aug-2021 13:12 by rmk:")


+                                                            (* ; "Edited 17-Aug-2020 08:46 by rmk:")

 
-(WRITE-UNICODE-MAPPING-FILENAME

+    (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to a Unicode mapping file.")

 
-    (PACKFILENAME 'BODY [OR FILE (CONCATLIST
+    (* ;; "This produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).")

 
-                                                   THEN
 (FOR
 RTAIL R ON
 RANGES
+    (* ;; "")

 
-                                                                     (SETQ R
+    (* ;; "We assume that the left-to-right mapping into Unicode is functional, so that each left code maps to a unique right (Unicode) code, because Unicode is presumably the most refined coding scheme.  But several Unicode codes may map to the same left code, for logically different codes that happen to have the same glyphs. In that case the heuristic is to map each %"from%" code to the lowest of the possible %"to%" codes. This means that round-trip reading/writing or writing/reading from one or both starting points may not always be lossless.")

 
-                                                                          (LIST (CAR R)
+    (* ;; " ")

 
-                                                                                (CDR R))
+    (* ;; " Each recoding array has 256 elements, one for each possible high-order byte of a character code.  An array entry is either NIL, a 256-array of codes indexed by low-order bytes, or an alist of (lower-order-bytes . codes).  The latter is used to save space for sparsely populated character sets.")

 
-                                                                     (CL:IF (CDR RTAIL)
+    (* ;; "")

 
-                                                                     R)
+    (* ;; "The element 256 of each array contains a hash table for characters that might be encountered in XCCS memory or Unicode files for which there is no mapping.  Element 257 contains the corresponding inverse unmapped hash-array, so that UNICODE.TRANSLATE can update them consistently.")

 
-                                                                "="
+    (* ;; "")

 
-           'DIRECTORY
+    (* ;; "UNICODE.TRANSLATE assigns an unmapped Unicode character to a %"not used%" XCCS code position (from 5,0 to 40,FF, leaving other low not-used sets for other internal uses (TEDIT?).")

 
-           'EXTENSION
+    (* ;; "")

 
-)
-
+    (* ;; 
+
  "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF")

 
-       (("0" LATIN)
+    (* ;; "")

 
-        ("42" SYMBOLS2)
+    (* ;; "For the convenience of not having to deal with the multiple values, if LTORVAR or RTOLVAR are given, they are set to the constructed arrays before return.")

 
-        ("44" HIRAGANA)
+    (* ;; "")

 
     (LET ((LTORARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
                             :INITIAL-ELEMENT NIL))
           (RTOLARRAY (CL:MAKE-ARRAY (IPLUS 2 N-TRANSLATION-SEGMENTS)
                             :INITIAL-ELEMENT NIL)))
 
-        ("341" HEBREW)
+         (* ;; "The left-to-right direction (into Unicode).    We start by distributing the mappings into alists in arrays indexed by the higher-order (charaset set byte).  The second loop converts long alists into arrays.")

 
          [FOR
 M LEFTC RBASE RCODES IN
 MAPPING EACHTIME
 (SETQ RCODES (CDR M))
                                                             (SETQ RBASE (CAR RCODES))
             UNLESS
 (IGEQ RBASE MISSINGCODE) DO
 (SETQ LEFTC (CAR M)) 
 
-        ("360" LIGATURES)
-        ("361" ACCENTED-LATIN)
+                                                      (* ;; 
+
                                                    "(CDR RCODES) contains combiners on the base")

 
                                                       (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK)
                                                                      (CL:IF (CDR RCODES)
@@ -796,7 +901,7 @@
                             MAX-ALIST-LENGTH)
             DO
 
 
-
+                  (* ;; "Leave it alone if the alist is short")

 
                   (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
                   (FOR
 P IN
 (CL:SVREF LTORARRAY I)
@@ -806,17 +911,17 @@
                   (CL:SETF (CL:SVREF LTORARRAY I)
                          CSA))
 
-           DATE "        Author:           Ron Kaplan <Ron.Kaplan@post.harvard.edu>" "" 
+         (* ;; "")

 
-           "XC1-3-3-0, 1987) into Unicode 3.0. standard codes.  That is the version of" 
+         (* ;; "Now the right-to-left direction (from Unicode). Here we have to detect and compensate for ambiguity.")

 
          (FOR
 M LEFTC RBASE RCOMBINERS PREV IN
 MAPPING EACHTIME
 (SETQ RBASE (CADR M))
                                                                      (SETQ RCOMBINERS (CDDR M))
             UNLESS
 (OR (IGEQ RBASE MISSINGCODE)
                            RCOMBINERS) DO
 
 
-           "        Unicode character itself (since the Unicode character names" 
-           "        are not available)" 
+                                             (* ;; 
+
                                     "Have we already seen an explicit mapping from right to left?")

 
                                              (SETQ LEFTC (CAR M))
                                              [SETQ PREV (ASSOC (LOGAND RBASE TRANSLATION-MASK)
@@ -838,7 +943,7 @@
                             MAX-ALIST-LENGTH)
             DO
 
 
-
+                  (* ;; "Long list, make an array")

 
                   (SETQ CSA (CL:MAKE-ARRAY TRANSLATION-SEGMENT-SIZE :INITIAL-ELEMENT NIL))
                   (FOR
 P IN
 (CL:SVREF RTOLARRAY I)
@@ -848,9 +953,9 @@
                   (CL:SETF (CL:SVREF RTOLARRAY I)
                          CSA))
 
-
+         (* ;; "")

 
-
+         (* ;; "Allocate the hash arrays for future out-of-map codes.  We we have to keep track of the next available and last possible codes, as well as the first available, for error checking.")

 
          (CL:SETF (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS)
                 (LIST (HASHARRAY 10)
@@ -863,14 +968,14 @@
                       (CHARCODE.DECODE "U+F8FF")
                       (CHARCODE.DECODE "U+E000")))
 
-    (* ;; "")

+         (* ;; "Now put in the inverse unmapped hash arrays")

 
          (CL:SETF (CL:SVREF LTORARRAY (ADD1 N-TRANSLATION-SEGMENTS))
                 (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS))
          (CL:SETF (CL:SVREF RTOLARRAY (ADD1 N-TRANSLATION-SEGMENTS))
                 (CL:SVREF LTORARRAY N-TRANSLATION-SEGMENTS))
 
-
  "An unmapped XCCS character is assigned a code in the %"private use%" code blocks 0xE000-F8FF")

+         (* ;; "")

 
          (CL:WHEN LTORVAR (SETATOMVAL LTORVAR LTORARRAY))
          (CL:WHEN RTOLVAR (SETATOMVAL RTOLVAR RTOLARRAY))
@@ -892,11 +997,11 @@
 (DEFINEQ
 
 (HEXSTRING

-                                                      (CL:PUSH (CONS (LOGAND LEFTC TRANSLATION-MASK)
-                                                                     (CL:IF (CDR RCODES)
+  [LAMBDA (N WIDTH)
                                     (* ; "Edited 23-Jul-2020 08:28 by rmk:")


+                                                             (* ; "Edited 20-Dec-93 17:51 by rmk:")

 
-                                                                         RBASE))
-                                                             (CL:SVREF LTORARRAY (LRSH LEFTC 
+    (* ;; 
+
  "Converts positive numbers to Hex strings, padding on the right with 0 up to WIDTH if given.")

 
     (CL:UNLESS (FIXP N)
         (SETQ N (CHARCODE.DECODE N)))
@@ -915,21 +1020,21 @@
          STR])
 
 (UTF8HEXSTRING

-
+  [LAMBDA (CHARCODE)
                                    (* ; "Edited 10-Aug-2020 08:33 by rmk:")

 
-
+    (* ;; "Utility to produces the UTF8 hexstring representing CODE")

 
     (HEXSTRING
 (IF
 (ILESSP CHARCODE 128)
                        THEN
 CHARCODE
                      ELSEIF
 (ILESSP CHARCODE 2048)
-
+                       THEN
                              (* ; "x800")

                              (LOGOR (LLSH (LOGOR (LLSH 3 6)
                                                  (LRSH CHARCODE 6))
                                           8)
                                     (LOGOR (LLSH 2 6)
                                            (LOADBYTE CHARCODE 0 6)))
                      ELSEIF
 (ILESSP CHARCODE 65536)
-                                                                                    TRANSLATION-SHIFT
+                       THEN
                              (* ; "x10000")

                              (LOGOR (LLSH (LOGOR (LLSH 7 5)
                                                  (LRSH CHARCODE 12))
                                           16)
@@ -939,7 +1044,7 @@
                                     (LOGOR (LLSH 2 6)
                                            (LOADBYTE CHARCODE 0 6)))
                      ELSEIF
 (ILESSP CHARCODE 2097152)
-                                                                 LEFTC)
+                       THEN
                              (* ; "x200000")

                              (LOGOR (LLSH (LOGOR (LLSH 15 4)
                                                  (LRSH CHARCODE 18))
                                           24)
@@ -954,27 +1059,27 @@
                      ELSE
 (ERROR "CHARCODE too big for UTF8" CHARCODE])
 
 (NUTF8CODEBYTES

-                         CSA))
+  [LAMBDA (N)
                                           (* ; "Edited 10-Aug-2020 12:35 by rmk:")

 
-         (* ;; "")

+    (* ;; "Returns the number of bytes needed to encode N in UTF8, ")

 
     (IF
 (ILESSP N 128)
         THEN
 1
       ELSEIF
 (ILESSP N 2048)
-                (LIST (HASHARRAY 10)
+        THEN
                                             (* ; "x800")

               4
       ELSEIF
 (ILESSP N 65536)
-                      (CHARCODE.DECODE "5,0")))
+        THEN
                                             (* ; "x10000")

               3
       ELSEIF
 (ILESSP N 2097152)
-                      (CHARCODE.DECODE "U+E000")
+        THEN
                                             (* ; "x200000")

               2
       ELSE
 (SHOULDNT])
 
 (NUTF8STRINGBYTES

-
+  [LAMBDA (STRING RAWFLG)
                               (* ; "Edited 10-Aug-2020 09:06 by rmk:")

 
-                (CL:SVREF RTOLARRAY N-TRANSLATION-SEGMENTS))
+    (* ;; "Returns the number of bytes it would take to represent STRING in UTF8, assuming it is an XCCS string unless RAWFLG. ")

 
     (FOR
 I C FROM
 1 WHILE
 (SETQ C (NTHCHARCODE STRING I))
        SUM
 (NUTF8CODEBYTES
 (CL:IF RAWFLG
@@ -982,11 +1087,11 @@
                                        (XTOUCODE
 C))])
 
 (XTOUSTRING

-         (LIST LTORARRAY RTOLARRAY])
+  [LAMBDA (XCCSSTRING
 RAWFLG)
                       (* ; "Edited 10-Aug-2020 21:42 by rmk:")

 
-
+    (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XCCSSTRING.  Applies the XCCSTOUNICODE translation unless RAWFLG.  ")

 
-                                         ACCENTED-LATIN GREEK))
+    (* ;; "The resulting string will not be readable inside Medley.")

 
     (LET [(USTR (ALLOCSTRING (NUTF8STRINGBYTES
 XCCSSTRING RAWFLG]
          (FOR
 I CHARCODE (SINDEX _ 0) FROM
 1 WHILE
 (SETQ CHARCODE (NTHCHARCODE XCCSSTRING
@@ -997,7 +1102,7 @@
                       THEN
 (RPLCHARCODE USTR (ADD
 SINDEX 1)
                                       CHARCODE)
                     ELSEIF
 (ILESSP CHARCODE 2048)
-(DEFINEQ
+                      THEN
                               (* ; "x800")

                             (RPLCHARCODE USTR (ADD
 SINDEX 1)
                                    (LOGOR (LLSH 3 6)
                                           (LRSH CHARCODE 6)))
@@ -1005,7 +1110,7 @@
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSEIF
 (ILESSP CHARCODE 65536)
-
+                      THEN
                               (* ; "x10000")

                             (RPLCHARCODE USTR (ADD
 SINDEX 1)
                                    (LOGOR (LLSH 7 5)
                                           (LRSH CHARCODE 12)))
@@ -1016,7 +1121,7 @@
                                    (LOGOR (LLSH 2 6)
                                           (LOADBYTE CHARCODE 0 6)))
                     ELSEIF
 (ILESSP CHARCODE 2097152)
-                                         THEN
 (+ CHAR (CHARCODE 0))
+                      THEN
                               (* ; "x200000")

                             (RPLCHARCODE USTR (ADD
 SINDEX 1)
                                    (LOGOR (LLSH 15 4)
                                           (LRSH CHARCODE 18)))
@@ -1033,9 +1138,9 @@
          USTR])
 
 (XCCSSTRING

-                                          8)
+  [LAMBDA (CODE)
                                        (* ; "Edited 13-Aug-2020 12:16 by rmk:")

 
-                                           (LOADBYTE CHARCODE 0 6)))
+    (* ;; "Returns XCCS character representation of string %"cset,char%"")

 
     (CL:UNLESS (FIXP CODE)
         (SETQ CODE (CHCON1 CODE)))
@@ -1046,14 +1151,14 @@
 (DEFINEQ
 
 (SHOWCHARS

-                     ELSEIF
 (ILESSP CHARCODE 2097152)
+  [LAMBDA (FROMCHAR TOCHAR FONT)
                        (* ; "Edited  1-Aug-2020 09:27 by rmk:")

     (RESETFORM (DSPFONT (OR FONT '(CLASSIC 12))
                       T)
            (CL:WHEN (AND (SMALLP FROMCHAR)
                          (NOT TOCHAR))
 
-                                                 (LOADBYTE CHARCODE 12 6))
-                                          16)
+               (* ;; 
+
    "If a small number, assume it's an octal (in decimal) character set, no need for string quotes")

 
                (SETQ TOCHAR (CONCAT FROMCHAR "," 376))
                (SETQ FROMCHAR (CONCAT FROMCHAR "," 41)))
@@ -1100,15 +1205,15 @@
 )
 )
 (DECLARE%: DONTCOPY
-                       (SETQ CHARCODE (XTOUCODE
 CHARCODE)))
-                  (IF
 (ILESSP CHARCODE 128)
-                      THEN
 (RPLCHARCODE USTR (ADD
 SINDEX 1)
-                                      CHARCODE)
-                    ELSEIF
 (ILESSP CHARCODE 2048)
-                      THEN
                               (* ; "x800")

-                            (RPLCHARCODE USTR (ADD
 SINDEX 1)
-                                   (LOGOR (LLSH 3 6)
-                                          (LRSH CHARCODE 6)))
-                            (RPLCHARCODE USTR (ADD
 SINDEX 1)
-                                   (LOGOR (LLSH 2 6)
+  (FILEMAP (NIL (4046 17726 (UTF8.OUTCHARFN 4056 . 6887) (UTF8.INCCODEFN 6889 . 12379) (UTF8.PEEKCCODEFN
+ 12381 . 17155) (\UTF8.BACKCCODEFN 17157 . 17724)) (17727 21053 (UTF16BE.OUTCHARFN 17737 . 18561) (
+UTF16BE.INCCODEFN 18563 . 19462) (UTF16BE.PEEKCCODEFN 19464 . 20535) (\UTF16.BACKCCODEFN 20537 . 21051
+)) (21083 22891 (MAKE-UNICODE-FORMATS 21093 . 22889)) (22988 24294 (UNICODE.UNMAPPED 22998 . 24292)) (
+24295 24831 (XCCS-UTF8-AFTER-OPEN 24305 . 24829)) (25901 26250 (XTOUCODE 25911 . 26079) (UTOXCODE 
+26081 . 26248)) (26290 42412 (READ-UNICODE-MAPPING-FILENAMES 26300 . 27401) (READ-UNICODE-MAPPING 
+27403 . 30701) (WRITE-UNICODE-MAPPING 30703 . 34920) (WRITE-UNICODE-INCLUDED 34922 . 39644) (
+WRITE-UNICODE-MAPPING-HEADER 39646 . 40878) (WRITE-UNICODE-MAPPING-FILENAME 40880 . 42410)) (45749 
+54228 (MAKE-UNICODE-TRANSLATION-TABLES 45759 . 54226)) (54649 62553 (HEXSTRING 54659 . 55820) (
+UTF8HEXSTRING 55822 . 58027) (NUTF8CODEBYTES 58029 . 58692) (NUTF8STRINGBYTES 58694 . 59175) (
+XTOUSTRING 59177 . 62188) (XCCSSTRING 62190 . 62551)) (62554 64023 (SHOWCHARS 62564 . 64021)))))
 STOP

library/UNIXTELNET

@@ -1,18 +1,27 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-
(FILECREATED "16-Feb-90 17:00:31" "{piglet/n}<piglet>vanmelle>lispusers>UNIXTELNET;11"
 3551   
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "30-Sep-2021 19:23:57" {DSK}<Users>briggs>Projects>medley>library>UNIXTELNET.;2
 3970   
 
-      changes to%:  (VARS UNIXTELNETCOMS) (FNS UNIX-TCPCHAT.INIT UNIX-TCPCHAT.OPEN UNIX-TCPCHAT.HOST.FILTER UNIX-TCPCHAT.GET.LOGIN)
+      changes to%:  (FNS UNIX-TCPCHAT.OPEN)
 
-      previous date%: "30-Jan-90 17:47:34" "{piglet/n}<piglet>vanmelle>lispusers>UNIXTELNET;7")
+      previous date%: "16-Feb-90 17:00:31" {DSK}<Users>briggs>Projects>medley>library>UNIXTELNET.;1
+)
 
 
-(* "
-Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved.
+(* ; "
+Copyright (c) 1989-1990 by Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT UNIXTELNETCOMS)
 
-(RPAQQ UNIXTELNETCOMS ((FNS UNIX-TCPCHAT.HOST.FILTER UNIX-TCPCHAT.OPEN UNIX-TCPCHAT.GET.LOGIN UNIX-TCPCHAT.INIT) (INITVARS (CHAT.LOGINS) (CHAT.LOGINS.MENU)) (GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU) (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD) UNIXCHAT) (ADDVARS (AROUNDEXITFNS UNIX-TCPCHAT.INIT)) (P (UNIX-TCPCHAT.INIT)))))
+(RPAQQ UNIXTELNETCOMS

+       [(FNS UNIX-TCPCHAT.HOST.FILTER UNIX-TCPCHAT.OPEN UNIX-TCPCHAT.GET.LOGIN UNIX-TCPCHAT.INIT)
+        (INITVARS (CHAT.LOGINS)
+               (CHAT.LOGINS.MENU))
+        (GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU)
+        (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
+                                               UNIXCHAT)
+               (ADDVARS (AROUNDEXITFNS UNIX-TCPCHAT.INIT))
+               (P (UNIX-TCPCHAT.INIT])
 (DEFINEQ
 
 (UNIX-TCPCHAT.HOST.FILTER

@@ -20,8 +29,20 @@ Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved.
 )
 
 (UNIX-TCPCHAT.OPEN

-(LAMBDA (HOST TERMTYPE LOGOPTION) (* ; "Edited 14-Feb-90 18:36 by bvm") (* ;; "For use on Maiko: chat to HOST by using rlogin in a shell window.") (LET (NAME STR) (if (AND (OR (NEQ LOGOPTION (QUOTE NONE)) (SETQ NAME (UNIX-TCPCHAT.GET.LOGIN HOST))) (SETQ STR (CREATE-SHELL-STREAM TERMTYPE (CL:FORMAT NIL "exec rlogin ~@[-l ~A ~]~A" NAME HOST)))) then (STREAMPROP STR (QUOTE SENDSCREENPARAMS) (FUNCTION UNIX.SENDSCREENPARAMS)) (STREAMPROP STR (QUOTE SETDISPLAYTYPE) (FUNCTION UNIX.SETDISPLAYTYPE)) (LIST STR STR (QUOTE LOGOPTION) (QUOTE NONE)))))
-)
+  [LAMBDA (HOST TERMTYPE LOGOPTION)                          (* ; 
+
                                                           "Edited 30-Sep-2021 19:23 by briggs")

+                                                             (* ; "Edited 14-Feb-90 18:36 by bvm")

+
+    (* ;; "For use on Maiko: chat to HOST by using ssh in a shell window.")

+
+    (LET (NAME STR)
+         (if
 [AND (OR (NEQ LOGOPTION 'NONE)
+                          (SETQ NAME (UNIX-TCPCHAT.GET.LOGIN
 HOST)))
+                      (SETQ STR (CREATE-SHELL-STREAM TERMTYPE (CL:FORMAT NIL "exec ssh ~@[-l ~A ~]~A"
+                                                                     NAME HOST]
+             then
 (STREAMPROP STR 'SENDSCREENPARAMS (FUNCTION UNIX.SENDSCREENPARAMS))
+                   (STREAMPROP STR 'SETDISPLAYTYPE (FUNCTION UNIX.SETDISPLAYTYPE))
+                   (LIST STR STR 'LOGOPTION 'NONE])
 
 (UNIX-TCPCHAT.GET.LOGIN

 (LAMBDA (HOST) (* ; "Edited 15-Feb-90 11:28 by bvm") (LET (NAME) (if (OR (NULL CHAT.LOGINS) (EQ (SETQ NAME (MENU (OR CHAT.LOGINS.MENU (SETQ CHAT.LOGINS.MENU (create MENU ITEMS _ (APPEND CHAT.LOGINS (QUOTE (("**other**" T "Prompts for a name to login as")))) CENTERFLG _ T TITLE _ "Log in as:"))))) T)) then (* ; "Prompt for a name") (if (SETQ NAME (CHAT.PROMPT.FOR.INPUT (CL:FORMAT NIL "Log in to ~A as user: " HOST) NIL 16)) then (SETQ CHAT.LOGINS (SORT (CONS NAME CHAT.LOGINS) (FUNCTION UALPHORDER))) (SETQ CHAT.LOGINS.MENU NIL))) NAME))
@@ -32,25 +53,26 @@ Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved.
 )
 )
 
-(RPAQ? CHAT.LOGINS)
+(RPAQ? CHAT.LOGINS
 )
 
-(RPAQ? CHAT.LOGINS.MENU)
+(RPAQ? CHAT.LOGINS.MENU
 )
 (DECLARE%: DOEVAL@COMPILE DONTCOPY
 
 (GLOBALVARS CHAT.LOGINS CHAT.LOGINS.MENU)
 )
 (DECLARE%: DONTEVAL@LOAD DOCOPY 
 
-(FILESLOAD (SYSLOAD) UNIXCHAT)
+(FILESLOAD (SYSLOAD)
+       UNIXCHAT)
 
 
-(ADDTOVAR AROUNDEXITFNS UNIX-TCPCHAT.INIT)
+(ADDTOVAR AROUNDEXITFNS
 UNIX-TCPCHAT.INIT)
 
 
-(UNIX-TCPCHAT.INIT)
+(UNIX-TCPCHAT.INIT
)
 )
 (PUTPROPS UNIXTELNET COPYRIGHT ("Xerox Corporation" 1989 1990))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (836 3203 (UNIX-TCPCHAT.HOST.FILTER 846 . 1353) (UNIX-TCPCHAT.OPEN 1355 . 1924) (
-UNIX-TCPCHAT.GET.LOGIN 1926 . 2495) (UNIX-TCPCHAT.INIT 2497 . 3201)))))
+  (FILEMAP (NIL (872 3597 (UNIX-TCPCHAT.HOST.FILTER 882 . 1389) (UNIX-TCPCHAT.OPEN 1391 . 2318) (
+UNIX-TCPCHAT.GET.LOGIN 2320 . 2889) (UNIX-TCPCHAT.INIT 2891 . 3595)))))
 STOP

library/VTCHAT

@@ -1,40 +1,37 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "20-Jan-93 15:06:01" {DSK}<python>lde>lispcore>library>VTCHAT.;2
 21782  
+
(FILECREATED "30-Sep-2021 17:41:51" {DSK}<Users>briggs>Projects>medley>library>VTCHAT.;4
 21924  
 
-      changes to%:  (RECORDS VT100SAVE VT100.STATE)
+      changes to%:  (FNS VTCHAT.STATUS)
 
-      previous date%: "13-Jun-90 01:22:35" {DSK}<python>lde>lispcore>library>VTCHAT.;1)
+      previous date%: "20-Jan-93 15:06:01" {DSK}<Users>briggs>Projects>medley>library>VTCHAT.;3)
 
 
 (* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation.  All rights reserved.
+Copyright (c) 1983-1988, 1990, 1993 by Venue & Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT VTCHATCOMS)
 
-(RPAQQ VTCHATCOMS
 [
-                       (* ;; "VT100 emulator")

+(RPAQQ VTCHATCOMS

+       [
+        (* ;; "VT100 emulator")

 
-                       (FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND)
-                       (FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT 
-                            VTCHAT.CLEARMODES VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE 
-                            VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS)
-                       (INITVARS (VTCHAT.DEBUGGING.FLG)
-                              (VTCHAT.TERM.IDENTITY.STRING "[?1;0c"))
-                       (GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT 
-                              VTCHAT.TERM.IDENTITY.STRING)
-                       (ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE)))
-                       (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
-                              (FILES (LOADCOMP)
-                                     CHATDECLS)
-                              (RECORDS VT100SAVE VT100.STATE))
-                       (INITRECORDS VT100.STATE)
-                       (SYSRECORDS VT100.STATE)
-                       (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
-                                                              VT100KP)
-                              (ADDVARS (CHAT.DISPLAYTYPES (
-                                                       "Replace this string with NIL to prefer vt100"
-                                                           NIL VT100])
+        (FNS VTCHAT.STATE VTCHAT.HANDLECHARACTER VTCHAT.SEQUENCE VTCHAT.DOCOMMAND)
+        (FNS VTCHAT.ADDRESS VTCHAT.REVERSE.INDEX VTCHAT.ATTRIBUTES VTCHAT.DECLFONT VTCHAT.CLEARMODES
+             VTCHAT.SAVE VTCHAT.RESTORE VTCHAT.SETMODE VTCHAT.SETMARGINS VTCHAT.REPORT VTCHAT.STATUS)
+        (INITVARS (VTCHAT.DEBUGGING.FLG)
+               (VTCHAT.TERM.IDENTITY.STRING "[?1;0c"))
+        (GLOBALVARS VTCHAT.DEBUGGING.FLG CHATFONT GRAPHICSFONT VTCHAT.TERM.IDENTITY.STRING)
+        (ADDVARS (CHAT.DRIVERTYPES (VT100 VTCHAT.HANDLECHARACTER VTCHAT.STATE)))
+        (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
+               (FILES (LOADCOMP)
+                      CHATDECLS)
+               (RECORDS VT100SAVE VT100.STATE))
+        (INITRECORDS VT100.STATE)
+        (SYSRECORDS VT100.STATE)
+        (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES (SYSLOAD)
+                                               VT100KP)
+               (ADDVARS (CHAT.DISPLAYTYPES ("Replace this string with NIL to prefer vt100" NIL VT100])
 
 
 
@@ -101,8 +98,29 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Co
 )
 
 (VTCHAT.STATUS

-(LAMBDA (CHAT.STATE VT100.STATE TYPE) (* ; "Edited 18-Dec-86 15:16 by amd") (* ;; "Returns VT100 status info") (LET ((OUTSTREAM (ffetch (CHAT.STATE OUTSTREAM) of (\DTEST CHAT.STATE (QUOTE CHAT.STATE))))) (SELECTQ TYPE (5 (* ; "Host wants device status") (PRIN1 "" OUTSTREAM)) (6 (* ; "Host wants cursor coords") (BOUT OUTSTREAM (CHARCODE ESC)) (BOUT OUTSTREAM (CHARCODE %[)) (BOUT OUTSTREAM (MKSTRING (ADD1 (IQUOTIENT (ffetch (CHAT.STATE YPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTHEIGHT) of CHAT.STATE))))) (BOUT OUTSTREAM (CHARCODE ;)) (BOUT OUTSTREAM (MKSTRING (ADD1 (IQUOTIENT (ffetch (CHAT.STATE XPOS) of CHAT.STATE) (ffetch (CHAT.STATE FONTWIDTH) of CHAT.STATE))))) (BOUT OUTSTREAM (CHARCODE R))) NIL) (FORCEOUTPUT OUTSTREAM)))
-)
+  [LAMBDA (CHAT.STATE VT100.STATE TYPE)                      (* ; 
+
                                                           "Edited 30-Sep-2021 17:30 by briggs")

+                                                             (* ; "Edited 18-Dec-86 15:16 by amd")

+
+    (* ;; "Returns VT100 status info")

+
+    (LET [(OUTSTREAM (ffetch
 (CHAT.STATE OUTSTREAM) of
 (\DTEST CHAT.STATE 'CHAT.STATE]
+         (SELECTQ TYPE
+             (5                                              (* ; "Host wants device status")

+                (PRIN1 "" OUTSTREAM))
+             (6                                              (* ; "Host wants cursor coords")

+                (BOUT OUTSTREAM (CHARCODE ESC))
+                (BOUT OUTSTREAM (CHARCODE %[))
+                (PRIN1 (ADD1 (IQUOTIENT (ffetch
 (CHAT.STATE YPOS) of
 CHAT.STATE)
+                                    (ffetch
 (CHAT.STATE FONTHEIGHT) of
 CHAT.STATE)))
+                       OUTSTREAM)
+                (BOUT OUTSTREAM (CHARCODE ;))
+                (PRIN1 (ADD1 (IQUOTIENT (ffetch
 (CHAT.STATE XPOS) of
 CHAT.STATE)
+                                    (ffetch
 (CHAT.STATE FONTWIDTH) of
 CHAT.STATE)))
+                       OUTSTREAM)
+                (BOUT OUTSTREAM (CHARCODE R)))
+             NIL)
+         (FORCEOUTPUT OUTSTREAM])
 )
 
 (RPAQ? VTCHAT.DEBUGGING.FLG
 )
@@ -236,10 +254,10 @@ Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Co
 )
 (PUTPROPS VTCHAT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1995 10061 (VTCHAT.STATE 2005 . 2515) (VTCHAT.HANDLECHARACTER 2517 . 5091) (
-VTCHAT.SEQUENCE 5093 . 6636) (VTCHAT.DOCOMMAND 6638 . 10059)) (10062 16968 (VTCHAT.ADDRESS 10072 . 
-10590) (VTCHAT.REVERSE.INDEX 10592 . 11161) (VTCHAT.ATTRIBUTES 11163 . 11549) (VTCHAT.DECLFONT 11551
- . 11820) (VTCHAT.CLEARMODES 11822 . 12325) (VTCHAT.SAVE 12327 . 13066) (VTCHAT.RESTORE 13068 . 13775)
- (VTCHAT.SETMODE 13777 . 14849) (VTCHAT.SETMARGINS 14851 . 15442) (VTCHAT.REPORT 15444 . 16204) (
-VTCHAT.STATUS 16206 . 16966)))))
+  (FILEMAP (NIL (1532 9598 (VTCHAT.STATE 1542 . 2052) (VTCHAT.HANDLECHARACTER 2054 . 4628) (
+VTCHAT.SEQUENCE 4630 . 6173) (VTCHAT.DOCOMMAND 6175 . 9596)) (9599 17110 (VTCHAT.ADDRESS 9609 . 10127)
+ (VTCHAT.REVERSE.INDEX 10129 . 10698) (VTCHAT.ATTRIBUTES 10700 . 11086) (VTCHAT.DECLFONT 11088 . 11357
+) (VTCHAT.CLEARMODES 11359 . 11862) (VTCHAT.SAVE 11864 . 12603) (VTCHAT.RESTORE 12605 . 13312) (
+VTCHAT.SETMODE 13314 . 14386) (VTCHAT.SETMARGINS 14388 . 14979) (VTCHAT.REPORT 14981 . 15741) (
+VTCHAT.STATUS 15743 . 17108)))))
 STOP

library/lafite/LAFITE

@@ -1,12 +1,11 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "24-Jun-2021 19:17:01" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4
 71992  
+
(FILECREATED "30-Sep-2021 22:59:08" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;5
 71956  
 
-      changes to%:  (FNS \LAFITE.EOF)
-                    (FILES LAFITEDECLS)
+      changes to%:  (FILES LAFITEDECLS)
 
-      previous date%: "22-Aug-94 13:00:22" 
-{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;2)
+      previous date%: "24-Jun-2021 19:17:01" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITE.;4)
 
 
 (* ; "
@@ -75,19 +74,19 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
                      (LAFITE.PERSONAL.VARS LAFITEDEFAULTHOST&DIR LAFITE.SIGNATURE))
               (FNS LAFITE.AROUNDEXIT \LAFITE.MARK.FOLDERS.OBSOLETE \LAFITE.CHECK.FOLDERS 
                    \LAFITE.ASSURE.FOLDER.READY \LAFITE.AFTERLOGIN))
-        (COMS                                                (* ; "misc utilities")

+        (COMS                                                (* ; "misc utilities")

               (FNS LA.RESETSHADE LA.MENU.ITEM NTHMESSAGE \LAFITE.MAKE.MSGARRAY 
                    \LAFITE.ADDMESSAGES.TO.ARRAY \MAILFOLDER.DEFPRINT \LAFITEMSG.DEFPRINT 
                    LA.POSITION.FROM.REGION MAILFOLDERBUSY)
               (CURSORS LA.CROSSCURSOR)
-                                                             (* ; "Low level file functions")

+                                                             (* ; "Low level file functions")

               (FNS TOCFILENAME DELETEMAILFOLDER \LAFITE.OPEN.FOLDER \LAFITE.REPORT.FILE.WONT.OPEN 
                    \LAFITE.FOLDER.CHANGED \LAFITE.REBROWSE.FOLDER \LAFITE.FOLDER.CHANGED.MENU 
                    \LAFITE.SET.FOLDER.STREAM \LAFITE.OPENSTREAM \LAFITE.CREATE.MENU \LAFITE.EOF 
                    \LAFITE.CLOSE.FOLDER)
               (FNS \LAFITE.DESCRIBE.FOLDER))
-        (COMS                                                (* ; 
-
                                                      "Make is easy to load new versions of Lafite")

+        (COMS                                                (* ; 
+
                                                      "Make is easy to load new versions of Lafite")

               (FNS LOAD-LAFITE)
               (VARS LAFITEFILES))
         [DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (SOURCE)
@@ -102,14 +101,14 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
                      (FILES LAFITEBROWSE LAFITECOMMANDS LAFITEFOLDERS LAFITESEND LAFITEMAIL 
                             LAFITESORT TEDIT LAFITETEDIT LAFITEFIND ATTACHEDWINDOW MAILSCAVENGE)
                      (P * (PROGN LAFITE.PROCLAMATIONS))
-                                                             (* ; 
-
                                      "Proclaim user interface variables.  Value is on LAFITEDECLS")

+                                                             (* ; 
+
                                      "Proclaim user interface variables.  Value is on LAFITEDECLS")

                      (P (\LAFITE.GLOBAL.INIT)
                         (COND ((EQ MAKESYSNAME :LYRIC)
                                (FILESLOAD (SYSLOAD)
                                       NSCHARPATCH)
-                                                             (* ; 
-
                                                           "Patch to horrid Lyric NS chars bug")

+                                                             (* ; 
+
                                                           "Patch to horrid Lyric NS chars bug")

                                (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T]
         (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
@@ -117,7 +116,7 @@ Copyright (c) 1982-1989, 1993-1994, 2021 by Xerox Corporation and Bolt Beranek a
 
 (RPAQQ LAFITEVERSION#
 10)
 
-(RPAQQ LAFITESYSTEMDATE
 "24-Jun-2021 19:17:01")
+(RPAQQ LAFITESYSTEMDATE
 "30-Sep-2021 22:59:08")
 (DEFINEQ
 
 (LAFITE

@@ -277,8 +276,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
                                                 DEFAULTFONT)
                                          (CHARWIDTH (CHARCODE "W")
                                                 DEFAULTFONT))
-                                                             (* ; 
-
                                       "Yes, user has not changed default to a variable width font")

+                                                             (* ; 
+
                                       "Yes, user has not changed default to a variable width font")

                                      DEFAULTFONT)
                                     (T (FONTCREATE '(GACHA 10]
         (LAFITEHARDCOPYFONT LAFITEDISPLAYFONT)
@@ -317,8 +316,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
                          DEFAULTFONT)
                   (CHARWIDTH (CHARCODE "W")
                          DEFAULTFONT))
-                                                             (* ; 
-
                                       "Yes, user has not changed default to a variable width font")

+                                                             (* ; 
+
                                       "Yes, user has not changed default to a variable width font")

               DEFAULTFONT)
              (T (FONTCREATE '(GACHA 10])
 
@@ -864,8 +863,8 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
 (COND
    ((EQ MAKESYSNAME :LYRIC)
     (FILESLOAD (SYSLOAD)
-           NSCHARPATCH)                                      (* ; 
-
                                                           "Patch to horrid Lyric NS chars bug")

+           NSCHARPATCH)                                      (* ; 
+
                                                           "Patch to horrid Lyric NS chars bug")

     (MOVD? 'PROMPTFORWORD 'TTYINPROMPTFORWORD NIL T)))
 )
 (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
@@ -879,28 +878,28 @@ Mode affects SendMail only; mail is still retrieved in all modes.~]" (if \LAFITE
 (PUTPROPS LAFITE COPYRIGHT ("Xerox Corporation and Bolt Beranek and Newman Inc." 1982 1983 1984 1985 
 1986 1987 1988 1989 1993 1994 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7140 22186 (LAFITE 7150 . 8461) (LAFITE.ON.FROM.BACKGROUND 8463 . 8834) (\LAFITE.OFF 
-8836 . 9220) (\LAFITE.START.PROC 9222 . 10998) (LAFITE.COMPUTE.CACHED.VARS 11000 . 13702) (
-\LAFITE.PROCESS 13704 . 14070) (\LAFITE.START.ABORT 14072 . 14264) (\LAFITE.QUIT 14266 . 14508) (
-\LAFITE.RESTART 14510 . 14643) (\LAFITE.SUBQUIT 14645 . 15943) (\LAFITE.QUIT.PROC 15945 . 18681) (
-\LAFITEDEFAULTHOST&DIR 18683 . 19493) (LAFITEDEFAULTHOST&DIR 19495 . 19665) (MAKELAFITECOMMANDWINDOW 
-19667 . 21306) (EXTRACTMENUCOMMAND 21308 . 21556) (DOMAINLAFITECOMMAND 21558 . 21707) (
-LAFITE.TOGGLE.SERVER.TRACE 21709 . 22184)) (22261 25229 (LAFITEMODE 22271 . 22751) (\LAFITE.INFER.MODE
- 22753 . 23106) (\LAFITE.SHOW.MODE 23108 . 23345) (\LAFITE.MODE.TITLE 23347 . 23632) (
-LAFITE.SHOW.MODE.P 23634 . 23875) (LAFITE.ALL.MODES.P 23877 . 24220) (SET.LAFITE.MODE.INTERACTIVELY 
-24222 . 24804) (\LAFITE.COMPUTE.MODE.COMMANDS 24806 . 25227)) (26079 27835 (\LAFITE.LOGIN 26089 . 
-26471) (\LAFITE.LOGIN.NORESTART 26473 . 26579) (LAFITE.PROMPT.FOR.LOGIN 26581 . 27600) (
-\LAFITE.REAUTHENTICATE 27602 . 27833)) (35346 38788 (LAFITE.AROUNDEXIT 35356 . 35894) (
-\LAFITE.MARK.FOLDERS.OBSOLETE 35896 . 36812) (\LAFITE.CHECK.FOLDERS 36814 . 37213) (
-\LAFITE.ASSURE.FOLDER.READY 37215 . 37625) (\LAFITE.AFTERLOGIN 37627 . 38786)) (38820 41758 (
-LA.RESETSHADE 38830 . 39208) (LA.MENU.ITEM 39210 . 39628) (NTHMESSAGE 39630 . 39713) (
-\LAFITE.MAKE.MSGARRAY 39715 . 40145) (\LAFITE.ADDMESSAGES.TO.ARRAY 40147 . 40728) (
-\MAILFOLDER.DEFPRINT 40730 . 40977) (\LAFITEMSG.DEFPRINT 40979 . 41141) (LA.POSITION.FROM.REGION 41143
- . 41620) (MAILFOLDERBUSY 41622 . 41756)) (41936 58324 (TOCFILENAME 41946 . 42377) (DELETEMAILFOLDER 
-42379 . 42899) (\LAFITE.OPEN.FOLDER 42901 . 47516) (\LAFITE.REPORT.FILE.WONT.OPEN 47518 . 48242) (
-\LAFITE.FOLDER.CHANGED 48244 . 50648) (\LAFITE.REBROWSE.FOLDER 50650 . 53615) (
-\LAFITE.FOLDER.CHANGED.MENU 53617 . 54540) (\LAFITE.SET.FOLDER.STREAM 54542 . 55236) (
-\LAFITE.OPENSTREAM 55238 . 55777) (\LAFITE.CREATE.MENU 55779 . 56132) (\LAFITE.EOF 56134 . 57476) (
-\LAFITE.CLOSE.FOLDER 57478 . 58322)) (58325 58909 (\LAFITE.DESCRIBE.FOLDER 58335 . 58907)) (58970 
-60076 (LOAD-LAFITE 58980 . 60074)) (67787 69064 (\LAFITE.GLOBAL.INIT 67797 . 69062)))))
+  (FILEMAP (NIL (7104 22150 (LAFITE 7114 . 8425) (LAFITE.ON.FROM.BACKGROUND 8427 . 8798) (\LAFITE.OFF 
+8800 . 9184) (\LAFITE.START.PROC 9186 . 10962) (LAFITE.COMPUTE.CACHED.VARS 10964 . 13666) (
+\LAFITE.PROCESS 13668 . 14034) (\LAFITE.START.ABORT 14036 . 14228) (\LAFITE.QUIT 14230 . 14472) (
+\LAFITE.RESTART 14474 . 14607) (\LAFITE.SUBQUIT 14609 . 15907) (\LAFITE.QUIT.PROC 15909 . 18645) (
+\LAFITEDEFAULTHOST&DIR 18647 . 19457) (LAFITEDEFAULTHOST&DIR 19459 . 19629) (MAKELAFITECOMMANDWINDOW 
+19631 . 21270) (EXTRACTMENUCOMMAND 21272 . 21520) (DOMAINLAFITECOMMAND 21522 . 21671) (
+LAFITE.TOGGLE.SERVER.TRACE 21673 . 22148)) (22225 25193 (LAFITEMODE 22235 . 22715) (\LAFITE.INFER.MODE
+ 22717 . 23070) (\LAFITE.SHOW.MODE 23072 . 23309) (\LAFITE.MODE.TITLE 23311 . 23596) (
+LAFITE.SHOW.MODE.P 23598 . 23839) (LAFITE.ALL.MODES.P 23841 . 24184) (SET.LAFITE.MODE.INTERACTIVELY 
+24186 . 24768) (\LAFITE.COMPUTE.MODE.COMMANDS 24770 . 25191)) (26043 27799 (\LAFITE.LOGIN 26053 . 
+26435) (\LAFITE.LOGIN.NORESTART 26437 . 26543) (LAFITE.PROMPT.FOR.LOGIN 26545 . 27564) (
+\LAFITE.REAUTHENTICATE 27566 . 27797)) (35310 38752 (LAFITE.AROUNDEXIT 35320 . 35858) (
+\LAFITE.MARK.FOLDERS.OBSOLETE 35860 . 36776) (\LAFITE.CHECK.FOLDERS 36778 . 37177) (
+\LAFITE.ASSURE.FOLDER.READY 37179 . 37589) (\LAFITE.AFTERLOGIN 37591 . 38750)) (38784 41722 (
+LA.RESETSHADE 38794 . 39172) (LA.MENU.ITEM 39174 . 39592) (NTHMESSAGE 39594 . 39677) (
+\LAFITE.MAKE.MSGARRAY 39679 . 40109) (\LAFITE.ADDMESSAGES.TO.ARRAY 40111 . 40692) (
+\MAILFOLDER.DEFPRINT 40694 . 40941) (\LAFITEMSG.DEFPRINT 40943 . 41105) (LA.POSITION.FROM.REGION 41107
+ . 41584) (MAILFOLDERBUSY 41586 . 41720)) (41900 58288 (TOCFILENAME 41910 . 42341) (DELETEMAILFOLDER 
+42343 . 42863) (\LAFITE.OPEN.FOLDER 42865 . 47480) (\LAFITE.REPORT.FILE.WONT.OPEN 47482 . 48206) (
+\LAFITE.FOLDER.CHANGED 48208 . 50612) (\LAFITE.REBROWSE.FOLDER 50614 . 53579) (
+\LAFITE.FOLDER.CHANGED.MENU 53581 . 54504) (\LAFITE.SET.FOLDER.STREAM 54506 . 55200) (
+\LAFITE.OPENSTREAM 55202 . 55741) (\LAFITE.CREATE.MENU 55743 . 56096) (\LAFITE.EOF 56098 . 57440) (
+\LAFITE.CLOSE.FOLDER 57442 . 58286)) (58289 58873 (\LAFITE.DESCRIBE.FOLDER 58299 . 58871)) (58934 
+60040 (LOAD-LAFITE 58944 . 60038)) (67751 69028 (\LAFITE.GLOBAL.INIT 67761 . 69026)))))
 STOP

library/lafite/LAFITEFIND

@@ -1,47 +1,45 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED " 3-Jun-92 10:10:41" {DSK}<usr>local>users>welch>lisp>lafite>LAFITEFIND.;2
 15951  
+
(FILECREATED "30-Sep-2021 23:01:05" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEFIND.;2
 14882  
 
-      previous date%: "15-Jun-90 16:06:40" {DSK}<usr>local>users>welch>lisp>lafite>LAFITEFIND.;1)
+      changes to%:  (FILES LAFITEDECLS)
+
+      previous date%: " 3-Jun-92 10:10:41" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITEFIND.;1)
 
 
 (* ; "
-Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+Copyright (c) 1984-1988, 1990, 1992, 2021 by Venue & Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT LAFITEFINDCOMS)
 
-(RPAQQ LAFITEFINDCOMS
 ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD 
-                                \LAFITE.GO.TO.FIRST \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST 
-                                \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT \LAFITE.DO.FIND 
-                                \LAFITE.FIND.START)
-                           (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE)
-                                  (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS 
-                                         LAFITEFINDTYPEMENU LAFITEFINDAREAMENU LAFITEEXTRAMENU 
-                                         LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH)
-                                  (FILES (SOURCE)
-                                         LAFITEDECLS)
-                                  (LOCALVARS . T))
-                           (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
-                           (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS)
-                           (ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND 
-                                                                 "Search mail for something")
-                                           ["Find Related" '\LAFITE.FIND.RELATED 
-                                            "Find all messages from here on in reply to this message"
-                                                  (SUBITEMS ("Find Related Forward" 
-                                                                   '\LAFITE.FIND.RELATED)
-                                                         ("Find Related Backward" 
-                                                                '\LAFITE.FIND.RELATED.BACKWARD]
-                                           ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search"
-                                                  )
-                                           ("Go to #" '\LAFITE.GO.TO.INTERACTIVE 
-                                                 "Scroll to and select a specific message by number."
-                                                  (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST 
-                                                                "Scroll to and select first message."
-                                                                   )
-                                                         ("Go to Last" '\LAFITE.GO.TO.LAST 
-                                                                "Scroll to and select last message."]
-                                  (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU))
-                           (VARS (\LAFITE.LAST.SEARCH))))
+(RPAQQ LAFITEFINDCOMS

+       ((FNS \LAFITE.FIND \LAFITE.FIND.RELATED \LAFITE.FIND.RELATED.BACKWARD \LAFITE.GO.TO.FIRST 
+             \LAFITE.GO.TO.INTERACTIVE \LAFITE.GO.TO.LAST \LAFITE.FIND.AGAIN \LAFITE.FIND.PROMPT 
+             \LAFITE.DO.FIND \LAFITE.FIND.START)
+        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SEARCHSTATE)
+               (GLOBALVARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS LAFITEFINDTYPEMENU 
+                      LAFITEFINDAREAMENU LAFITEEXTRAMENU LAFITEEXTRAMENUFLG \LAFITE.LAST.SEARCH)
+               (FILES (SOURCE)
+                      LAFITEDECLS)
+               (LOCALVARS . T))
+        (INITVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
+        (VARS LAFITEFINDAREAMENUITEMS LAFITEFINDTYPEMENUITEMS)
+        (ADDVARS [LAFITEEXTRAMENUITEMS ("Find" '\LAFITE.FIND "Search mail for something")
+                        ["Find Related" '\LAFITE.FIND.RELATED 
+                               "Find all messages from here on in reply to this message"
+                               (SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED)
+                                      ("Find Related Backward" '\LAFITE.FIND.RELATED.BACKWARD]
+                        ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
+                        ("Go to #" '\LAFITE.GO.TO.INTERACTIVE 
+                               "Scroll to and select a specific message by number."
+                               (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST 
+                                                "Scroll to and select first message.")
+                                      ("Go to Last" '\LAFITE.GO.TO.LAST 
+                                             "Scroll to and select last message."]
+               (LAFITEMENUVARS LAFITEFINDTYPEMENU LAFITEFINDAREAMENU))
+        (VARS (\LAFITE.LAST.SEARCH))))
 (DEFINEQ
 
 (\LAFITE.FIND

@@ -147,45 +145,47 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporat
 
 (RPAQ? LAFITEFINDAREAMENU
 NIL)
 
-(RPAQQ LAFITEFINDAREAMENUITEMS
 ((From 'From "Search From: field for string (or To: if from self)"
-                                          )
-                                    (Subject 'Subject "Search Subject: field for string")
-                                    (Body 'Body "Search message bodies for string")
-                                    (Mark 'Mark "Search for messages with specified mark character")
-                                    (Related 'Related 
-                                           "Search for a message with same Subject, modulo Re:")))
+(RPAQQ LAFITEFINDAREAMENUITEMS

+       ((From 'From "Search From: field for string (or To: if from self)")
+        (Subject 'Subject "Search Subject: field for string")
+        (Body 'Body "Search message bodies for string")
+        (Mark 'Mark "Search for messages with specified mark character")
+        (Related 'Related "Search for a message with same Subject, modulo Re:")))
 
-(RPAQQ LAFITEFINDTYPEMENUITEMS
 (("Find Next One" '(FORWARD ONE)
-                                           "Search forward from selected message")
-                                    ("Find Next All" '(FORWARD ALL)
-                                           "Search forward from selected message")
-                                    ("Find Previous One" '(BACKWARD ONE)
-                                           "Search backward from selected message")
-                                    ("Find Previous All" '(BACKWARD ALL)
-                                           "Search backward from selected message")))
+(RPAQQ LAFITEFINDTYPEMENUITEMS

+       (("Find Next One" '(FORWARD ONE)
+               "Search forward from selected message")
+        ("Find Next All" '(FORWARD ALL)
+               "Search forward from selected message")
+        ("Find Previous One" '(BACKWARD ONE)
+               "Search backward from selected message")
+        ("Find Previous All" '(BACKWARD ALL)
+               "Search backward from selected message")))
 
-(ADDTOVAR LAFITEEXTRAMENUITEMS
 ("Find" '\LAFITE.FIND "Search mail for something")
-                                   ["Find Related" '\LAFITE.FIND.RELATED 
-                                          "Find all messages from here on in reply to this message"
-                                          (SUBITEMS ("Find Related Forward" '\LAFITE.FIND.RELATED)
-                                                 ("Find Related Backward" 
-                                                        '\LAFITE.FIND.RELATED.BACKWARD]
-                                   ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
-                                   ("Go to #" '\LAFITE.GO.TO.INTERACTIVE 
-                                          "Scroll to and select a specific message by number."
-                                          (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST 
-                                                           "Scroll to and select first message.")
-                                                 ("Go to Last" '\LAFITE.GO.TO.LAST 
-                                                        "Scroll to and select last message."))))
+(ADDTOVAR LAFITEEXTRAMENUITEMS

+          ("Find" '\LAFITE.FIND "Search mail for something")
+          ["Find Related" '\LAFITE.FIND.RELATED 
+                 "Find all messages from here on in reply to this message" (SUBITEMS
+                                                                            ("Find Related Forward"
+                                                                             '\LAFITE.FIND.RELATED)
+                                                                            ("Find Related Backward"
+                                                                             
+                                                                             '
+                                                                        \LAFITE.FIND.RELATED.BACKWARD
+                                                                             ]
+          ("Find Again" '\LAFITE.FIND.AGAIN "Repeat previous search")
+          ("Go to #" '\LAFITE.GO.TO.INTERACTIVE "Scroll to and select a specific message by number."
+                 (SUBITEMS ("Go to First" '\LAFITE.GO.TO.FIRST "Scroll to and select first message.")
+                        ("Go to Last" '\LAFITE.GO.TO.LAST "Scroll to and select last message."))))
 
 (ADDTOVAR LAFITEMENUVARS
 LAFITEFINDTYPEMENU LAFITEFINDAREAMENU)
 
 (RPAQQ \LAFITE.LAST.SEARCH
 NIL)
-(PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992))
+(PUTPROPS LAFITEFIND COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1992 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3089 12861 (\LAFITE.FIND 3099 . 4131) (\LAFITE.FIND.RELATED 4133 . 4798) (
-\LAFITE.FIND.RELATED.BACKWARD 4800 . 4936) (\LAFITE.GO.TO.FIRST 4938 . 5105) (
-\LAFITE.GO.TO.INTERACTIVE 5107 . 5719) (\LAFITE.GO.TO.LAST 5721 . 5929) (\LAFITE.FIND.AGAIN 5931 . 
-6513) (\LAFITE.FIND.PROMPT 6515 . 8637) (\LAFITE.DO.FIND 8639 . 11790) (\LAFITE.FIND.START 11792 . 
-12859)))))
+  (FILEMAP (NIL (2309 12081 (\LAFITE.FIND 2319 . 3351) (\LAFITE.FIND.RELATED 3353 . 4018) (
+\LAFITE.FIND.RELATED.BACKWARD 4020 . 4156) (\LAFITE.GO.TO.FIRST 4158 . 4325) (
+\LAFITE.GO.TO.INTERACTIVE 4327 . 4939) (\LAFITE.GO.TO.LAST 4941 . 5149) (\LAFITE.FIND.AGAIN 5151 . 
+5733) (\LAFITE.FIND.PROMPT 5735 . 7857) (\LAFITE.DO.FIND 7859 . 11010) (\LAFITE.FIND.START 11012 . 
+12079)))))
 STOP

library/lafite/LAFITESORT

@@ -1,19 +1,334 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-
(FILECREATED " 7-Feb-95 13:10:22" {DSK}<lispcore>lafite>parc-94>LAFITESORT.;2
 12117  
-
-      changes to%:  (VARS LAFITESORTCOMS)
-
-      previous date%: " 7-Oct-89 14:07:49" {DSK}<lispcore>lafite>parc-94>LAFITESORT.;1)
-
-
-(* ; "
-Copyright (c) 1989, 1995 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT LAFITESORTCOMS)
-
-(RPAQQ LAFITESORTCOMS

-       [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
-                                                LAFITEDECLS))
-        (FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY 
-             LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER 
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "30-Sep-2021 22:58:58" 
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1
 19675  
+
+      previous date%: " 7-Feb-95 13:10:22" 
+{DSK}<USERS>KAPLAN>LOCAL>MEDLEY3.5>GIT-MEDLEY>LIBRARY>LAFITE>LAFITESORT.;1)
+
+
+(* ; "
+Copyright (c) 1989, 1995, 2021 by Xerox Corporation.
+")
+
+(PRETTYCOMPRINT LAFITESORTCOMS)
+
+(RPAQQ LAFITESORTCOMS

+       [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
+                                                LAFITEDECLS))
+        (FNS LAFITE.ASSURE.DATE.FIELDS LAFITE.PARSE.DATE.FIELD LAFITE.PARSE.DATE.FIELD.ONLY 
+             LAFITE.SORT.BY.DATE LAFITE.SORT.MESSAGES LAFITEMSG.DATE.ORDER 
+             \LAFITE.SORT.BY.DATE.INTERACTIVE \LAFITE.SORT.BY.DATE.REGION)
+        [APPENDVARS (LAFITEEXTRAMENUITEMS ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE 
+                                        "Sort all the messages in this folder by their Date: fields."
+                                                 (SUBITEMS ("Sort Entire Folder" 
+                                                                  '\LAFITE.SORT.BY.DATE.INTERACTIVE 
+                                        "Sort all the messages in this folder by their Date: fields."
+                                                                  )
+                                                        ("Sort Selected Range" 
+                                                               '\LAFITE.SORT.BY.DATE.REGION 
+                               "Sort only the messages between the first and last selected messages."
+                                                               ]
+        (COMS                                                (* ; "Date hax")

+              (FNS GDATE1-6)
+              (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays)
+                     (GLOBALVARS \TimeZoneComp \DayLightSavings])
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD (SOURCE)
+       LAFITEDECLS)
+)
+(DEFINEQ
+
+(LAFITE.ASSURE.DATE.FIELDS

+  [LAMBDA (FOLDER FIRST# LAST#)
                          (* ; "Edited  5-May-89 15:46 by bvm")

+
+    (* ;; "Assure that messages FIRST# thru LAST# have IDATE fields.  FIRST# & LAST# default.")

+
+    (for
 I from
 (OR FIRST# 1) to
 (OR LAST# (fetch
 (MAILFOLDER %#OFMESSAGES)
+                                                          of
 FOLDER))
+       bind
 (STREAM _ (\LAFITE.OPEN.FOLDER FOLDER 'INPUT :ABORT))
+             (MESSAGES _ (fetch
 (MAILFOLDER MESSAGEDESCRIPTORS) of
 FOLDER))
+             (FAILURECNT _ 0)
+             (MISSING _ 0)
+             MSG ID PREV DATEFAILURE DATEFETCHED BABBLED
+       do
 [if
 (fetch
 (LAFITEMSG DATEFETCHED?) of
 (SETQ MSG (NTHMESSAGE MESSAGES I)))
+                  then
                                   (* ; "Ok")

+                        (if
 (NOT (fetch
 (LAFITEMSG DATEKNOWN?) of
 MSG))
+                            then
 (add
 FAILURECNT 1))
+                else
 (if
 (NOT BABBLED)
+                             then
                        (* ; "Tell user what's taking so long")

+                                   (LAB.PROMPTPRINT FOLDER "Collecting dates... ")
+                                   (SETQ BABBLED T))
+                      (if
 (FIXP (SETQ ID (LAFITE.PARSE.HEADER STREAM \LAPARSE.DATEFIELD
+                                                    (fetch
 (LAFITEMSG START) of
 MSG)
+                                                    (fetch
 (LAFITEMSG END) of
 MSG)
+                                                    T)))
+                          then
 (replace
 (LAFITEMSG IDATE) of
 MSG with
 ID)
+                                (replace
 (LAFITEMSG DATEKNOWN?) of
 MSG with
 T)
+                                (replace
 (LAFITEMSG DATEFETCHED?) of
 MSG with
 T)
+                                (replace
 (LAFITEMSG DATE) of
 MSG with
 NIL) 
+                                                             (* ; 
+
                                                      "So it will be regenerated in canonical form")

+                                (OR DATEFETCHED (SETQ DATEFETCHED I))
+                        else
 (replace
 (LAFITEMSG DATEKNOWN?) of
 MSG with
 NIL)
+                              (if
 LAFITEDEBUGFLG
+                                  then
 (LAB.FORMAT FOLDER 
+                                           " ~:[Date missing for~;Could not parse date of~] msg ~D. "
+                                                  ID I))
+                              (add
 FAILURECNT 1)
+                              (if
 (NULL ID)
+                                  then
 (add
 MISSING 1))
+                              (if
 [AND (> I 1)
+                                           (fetch
 (LAFITEMSG DATEFETCHED?)
+                                              of
 (SETQ PREV (NTHMESSAGE MESSAGES (SUB1 I]
+                                  then
                   (* ; 
+
                                                     "Guess that message i has date just after i-1")

+                                        (replace
 (LAFITEMSG IDATE) of
 MSG
+                                           with
 (ADD1 (fetch
 (LAFITEMSG IDATE) of
 PREV)))
+                                        (replace
 (LAFITEMSG DATEFETCHED?) of
 MSG with

+                                                                                         T)
+                                else
 (SETQ DATEFAILURE I]
+       finally
 (if
 (AND DATEFETCHED (< DATEFETCHED (fetch
 (MAILFOLDER TOCLASTMESSAGE#)
+                                                              of
 FOLDER)))
+                       then
                              (* ; 
+
          "Assure that the toc will be rewritten at least this far back so that we save the dates.")

+                             (replace
 (MAILFOLDER TOCLASTMESSAGE#) of
 FOLDER with
 
+                                                                                          DATEFETCHED
+                                    ))
+             (COND
+                ([AND DATEFAILURE (NOT (for
 I from
 (ADD1 (OR FIRST# 1))
+                                          to
 (fetch
 (MAILFOLDER %#OFMESSAGES) of
 FOLDER)
+                                          when
 (fetch
 (LAFITEMSG DATEFETCHED?)
+                                                      of
 (SETQ MSG (NTHMESSAGE MESSAGES I)))
+                                          do
             (* ; "Got a date later on")

+                                                (SETQ ID (fetch
 (LAFITEMSG IDATE) of
 MSG))
+                                                (for
 J from
 DATEFAILURE
+                                                   to
 (OR FIRST# 1) by
 -1
+                                                   do
    (* ; 
+
                                                           "Store guess dates for first message(s)")

+                                                         (replace
 (LAFITEMSG IDATE)
+                                                            of
 (SETQ MSG (NTHMESSAGE MESSAGES J))
+                                                            with
 (add
 ID -1))
+                                                         (replace
 (LAFITEMSG DATEFETCHED?)
+                                                            of
 MSG with
 T))
+                                                (RETURN T]
+                 (LAB.PROMPTPRINT FOLDER "Could not parse dates of ANY messages in this file."))
+                ((> FAILURECNT 0)
+                 (LAB.FORMAT FOLDER (if
 (< MISSING FAILURECNT)
+                                        then
 
+                                         " Note: Could not parse date field of ~D of these messages."
+                                      else
 " Note: Missing date field for ~D of these messages.")
+                        FAILURECNT])
+
+(LAFITE.PARSE.DATE.FIELD

+  [LAMBDA (STREAM)
                                       (* ; "Edited  5-May-89 12:52 by bvm")

+    (LET* ((DATESTR (LAFITE.READ.TO.EOL STREAM))
+           (ID (IDATE DATESTR)))
+          (if
 [AND ID (> ID (CONSTANT (IDATE "1-jan-70 1200"]
+              then
                                       (* ; "Plausible date.  Test is for those silly senders who didn't get the date set and have messages reading %"31-dec-00 ...%"")

+                    ID
+            else
 (CONCAT (OR (SUBSTRING DATESTR 1 6 DATESTR)
+                                 DATESTR)
+                            "?"])
+
+(LAFITE.PARSE.DATE.FIELD.ONLY

+  [LAMBDA (STREAM)
+    (DECLARE
 (USEDFREE PARSERESULT))
                 (* ; "Edited 26-Apr-89 14:35 by bvm")

+    (SETQ PARSERESULT (LAFITE.PARSE.DATE.FIELD
 STREAM])
+
+(LAFITE.SORT.BY.DATE

+  [LAMBDA (FOLDER FIRST# LAST#)
                          (* ; "Edited 26-Apr-89 15:32 by bvm")

+    (WITH.MONITOR (fetch
 (MAILFOLDER FOLDERLOCK) of
 FOLDER)
+        (LAFITE.ASSURE.DATE.FIELDS
 FOLDER FIRST# LAST#)
+        (LAFITE.SORT.MESSAGES
 FOLDER (FUNCTION LAFITEMSG.DATE.ORDER)
+               FIRST# LAST#))])
+
+(LAFITE.SORT.MESSAGES

+  [LAMBDA (FOLDER COMPAREFN FIRST# LAST#)
                (* ; "Edited  7-Oct-89 14:03 by bvm")

+    (WITH.MONITOR (fetch
 (MAILFOLDER FOLDERLOCK) of
 FOLDER)
+        (OR FIRST# (SETQ FIRST# 1))
+        (OR LAST# (SETQ LAST# (fetch
 (MAILFOLDER %#OFMESSAGES) of
 FOLDER)))
+        (LAB.PROMPTPRINT FOLDER "Sorting... ")
+        (LET* ((MESSAGES (fetch
 (MAILFOLDER MESSAGEDESCRIPTORS) of
 FOLDER))
+               (SORTED (CL:STABLE-SORT (for
 I from
 FIRST# to
 LAST#
+                                          collect
 (NTHMESSAGE MESSAGES I))
+                              COMPAREFN)))
+              (while
 (AND SORTED (EQ (fetch
 (LAFITEMSG %#) of
 (CAR SORTED))
+                                         FIRST#)) do
     (* ; 
+
                                                "Skip over the initial prefix of in-order messages")

+                                                        (add
 FIRST# 1)
+                                                        (SETQ SORTED (CDR SORTED)))
+              (if
 (NULL SORTED)
+                  then
 (LAB.PROMPTPRINT FOLDER "already in order")
+                else
 (replace
 (MAILFOLDER FOLDEROUTOFORDER) of
 FOLDER with
 T)
+                      (if
 (< FIRST# (fetch
 (MAILFOLDER FIRSTCHANGEDMESSAGE) of
 FOLDER))
+                          then
 (replace
 (MAILFOLDER FIRSTCHANGEDMESSAGE) of
 FOLDER
+                                      with
 FIRST#))
+                      (UNINTERRUPTABLY
+                          (for
 MSG in
 SORTED as
 I from
 FIRST#
+                             do
 (replace
 (LAFITEMSG %#) of
 MSG with
 I)
+                                   (SETA MESSAGES I MSG)))
+                      [LET ((FIRSTSEL (fetch
 (MAILFOLDER FIRSTSELECTEDMESSAGE) of
 FOLDER))
+                            (LASTSEL (fetch
 (MAILFOLDER LASTSELECTEDMESSAGE) of
 FOLDER)))
+                           (if
 (>= LASTSEL FIRSTSEL)
+                               then
 (if
 (AND (>= FIRSTSEL FIRST#)
+                                                     (<= FIRSTSEL LAST#))
+                                            then
         (* ; 
+
                                 "Start of selection was inside here, have to recompute its number")

+                                                  (replace
 (MAILFOLDER FIRSTSELECTEDMESSAGE)
+                                                     of
 FOLDER with
 (LAB.FIND.SELECTED.MSG
+                                                                             FOLDER FIRST# LAST#)))
+                                     (if
 (AND (>= LASTSEL FIRST#)
+                                                  (<= LASTSEL LAST#))
+                                         then
            (* ; 
+
                                   "End of selection was inside here, have to recompute its number")

+                                               (replace
 (MAILFOLDER LASTSELECTEDMESSAGE)
+                                                  of
 FOLDER with
 (LAB.REV.FIND.SELECTED.MSG
+                                                                          FOLDER FIRST# LAST#]
+                      (LAB.DISPLAYLINES FOLDER FIRST# LAST# NIL T)
+                      (LAB.PROMPTPRINT FOLDER "done"))))])
+
+(LAFITEMSG.DATE.ORDER

+  [LAMBDA (X Y)
                                          (* ; "Edited 26-Apr-89 14:53 by bvm")

+
+    (* ;; "True if msg X has older date than msg Y.  Since date field is stored as an unboxed 32-bit integer, we open code %"<%" here to avoid boxing.")

+
+    (LET [(HIDIFF (- (LOGXOR (fetch
 (LAFITEMSG IDATEHI) of
 X)
+                            32768)
+                     (LOGXOR (fetch
 (LAFITEMSG IDATEHI) of
 Y)
+                            32768]
+
+         (* ;; "HIDIFF is unsigned difference of high words")

+
+         (OR (< HIDIFF 0)
+             (AND (EQ HIDIFF 0)
+                  (< (fetch
 (LAFITEMSG IDATELO) of
 X)
+                     (fetch
 (LAFITEMSG IDATELO) of
 Y])
+
+(\LAFITE.SORT.BY.DATE.INTERACTIVE

+  [LAMBDA (FOLDER FIRST# LAST#)
                          (* ; "Edited  3-May-89 18:38 by bvm")

+    (if
 (LAB.MOUSECONFIRM FOLDER "Click LEFT to confirm sorting ~D messages by date"
+                   (if
 LAST#
+                       then
 (ADD1 (- LAST# FIRST#))
+                     else
 (fetch
 (MAILFOLDER %#OFMESSAGES) of
 FOLDER)))
+        then
 (\LAFITE.PROCESS `(,(FUNCTION LAFITE.SORT.BY.DATE)
+                                    ',FOLDER
+                                    ',FIRST#
+                                    ',LAST#)
+                        "LafiteSort"])
+
+(\LAFITE.SORT.BY.DATE.REGION

+  [LAMBDA (FOLDER)
                                       (* ; "Edited 28-Apr-89 16:23 by bvm")

+    (LET ((FIRST# (fetch
 (MAILFOLDER FIRSTSELECTEDMESSAGE) of
 FOLDER))
+          (LAST# (fetch
 (MAILFOLDER LASTSELECTEDMESSAGE) of
 FOLDER)))
+         (if
 (> LAST# FIRST#)
+             then
 (\LAFITE.SORT.BY.DATE.INTERACTIVE
 FOLDER FIRST# LAST#)
+           else
 (LAB.FORMAT FOLDER "There is ~:[no~;only one~] message selected."
+                           (EQ LAST# FIRST#])
+)
+
+(APPENDTOVAR LAFITEEXTRAMENUITEMS
 ("Sort by Date" '\LAFITE.SORT.BY.DATE.INTERACTIVE 
+                                        "Sort all the messages in this folder by their Date: fields."
+                                             (SUBITEMS ("Sort Entire Folder" 
+                                                              '\LAFITE.SORT.BY.DATE.INTERACTIVE 
+                                        "Sort all the messages in this folder by their Date: fields."
+                                                              )
+                                                    ("Sort Selected Range" 
+                                                           '\LAFITE.SORT.BY.DATE.REGION 
+                               "Sort only the messages between the first and last selected messages."
+                                                           ))))
+
+
+
+(* ; "Date hax")

+
+(DEFINEQ
+
+(GDATE1-6

+  [LAMBDA (D)
                                            (* ; "Edited 26-Apr-89 15:24 by bvm")

+
+    (* ;; "Return a string containing the day and month given in internal date D.")

+
+    (* ;; "This is an optimization by source code simplification of (SUBSTRING (GDATE IDT) 1 6)")

+
+    (PROG ((CHECKDLS \DayLightSavings)
+           [DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D)
+                                1)
+                      (CONSTANT (IQUOTIENT (TIMES 60 60)
+                                       2]
+           HR DAY4 YDAY WDAY YEAR4 TOTALDAYS DLS)            (* ; 
+
                         "DQ is number of hours since day 0, getting us past the sign bit problem.")

+
+     (* ;; "Now we can adjust to the current time zone.  Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897")

+
+          (SETQ HR (IREMAINDER (SETQ DQ (- (+ DQ (CONSTANT (ITIMES 24 \4YearsDays)))
+                                           \TimeZoneComp))
+                          24))
+          (SETQ TOTALDAYS (IQUOTIENT DQ 24))
+      DTLOOP
+          (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays))     (* ; 
+
                                                 "DAY4 = number of days since last leap year day 0")

+          [SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 '((789 . 3)
+                                                  (424 . 2)
+                                                  (59 . 1)
+                                                  (0 . 0]    (* ; 
+
                              "pretend every year is a leap year, adding one for days after Feb 28")

+          (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays))     (* ; 
+
                                              "YEAR4 = number of years til that last leap year / 4")

+          (SETQ YDAY (IREMAINDER DAY4 366))                  (* ; 
+
                                               "YDAY is the ordinal day in the year (jan 1 = zero)")

+          (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3)
+                            7))
+          [COND
+             ((AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY)))
+
+              (* ;; "This date is during daylight savings, so add 1 hour.  Third arg is day of the week, which we determine by taking days mod 7 plus offset.  Monday = zero in this scheme.  Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year")

+
+              (COND
+                 ((> (SETQ HR (ADD1 HR))
+                     23)
+
+                  (* ;; "overflowed into the next day.  This case is too hard (we might have overflowed the month, for example), so just go back and recompute")

+
+                  (SETQ TOTALDAYS (ADD1 TOTALDAYS))
+                  (SETQ HR 0)
+                  (SETQ CHECKDLS NIL)
+                  (GO DTLOOP]
+          (RETURN (LET* [[MONTH (\DTSCAN YDAY '((335 . "Dec")
+                                                (305 . "Nov")
+                                                (274 . "Oct")
+                                                (244 . "Sep")
+                                                (213 . "Aug")
+                                                (182 . "Jul")
+                                                (152 . "Jun")
+                                                (121 . "May")
+                                                (91 . "Apr")
+                                                (60 . "Mar")
+                                                (31 . "Feb")
+                                                (0 . "Jan"]
+                         [DAY (ADD1 (- YDAY (CAR MONTH]
+                         (RESULT (CONCAT "   " (CDR MONTH]
+                        (\RPLRIGHT RESULT 2 DAY 1)
+                        RESULT])
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \4YearsDays
 1461)
+
+
+(CONSTANTS \4YearsDays)
+)
+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \TimeZoneComp \DayLightSavings)
+)
+)
+(PUTPROPS LAFITESORT COPYRIGHT ("Xerox Corporation" 1989 1995 2021))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2020 14676 (LAFITE.ASSURE.DATE.FIELDS 2030 . 8127) (LAFITE.PARSE.DATE.FIELD 8129 . 8766
+) (LAFITE.PARSE.DATE.FIELD.ONLY 8768 . 8983) (LAFITE.SORT.BY.DATE 8985 . 9345) (LAFITE.SORT.MESSAGES 
+9347 . 12737) (LAFITEMSG.DATE.ORDER 12739 . 13487) (\LAFITE.SORT.BY.DATE.INTERACTIVE 13489 . 14133) (
+\LAFITE.SORT.BY.DATE.REGION 14135 . 14674)) (15566 19381 (GDATE1-6 15576 . 19379)))))
+STOP

library/lafite/LAFITETEDIT

@@ -1,14 +1,18 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "20-May-92 11:28:47" {DSK}<project>medley2.0>library>lafitetedit.;7
 12308  
+
(FILECREATED "30-Sep-2021 23:07:55" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITETEDIT.;3
 12516  
 
-      changes to%:  (FNS TEDIT.ASSURE.NO.BACKING.FILE)
-                    (VARS LAFITETEDITCOMS)
+      changes to%:  (VARS LAFITETEDITCOMS)
+                    (FNS LA.ADJUST.FORMATTING LA.SKIP.LOOKS.LIST LA.DETACH.TEDIT LA.TEDIT.INCLUDE 
+                         LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE)
+                    (FILES LAFITEDECLS)
 
-      previous date%: "29-Apr-92 13:30:23" {DSK}<project>medley2.0>library>lafitetedit.;5)
+      previous date%: "30-Sep-2021 22:59:28" 
+{DSK}<Users>kaplan>Local>medley3.5>git-medley>library>lafite>LAFITETEDIT.;2)
 
 
 (* ; "
-Copyright (c) 1988, 1990, 1992 by Xerox Corporation.  All rights reserved.
+Copyright (c) 1988, 1990, 1992, 2021 by Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT LAFITETEDITCOMS)
@@ -21,10 +25,10 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation.  All rights reserved.
              LA.WINDOW.FROM.TEXTSTREAM TEDIT.ASSURE.NO.BACKING.FILE)
         (DECLARE%: EVAL@COMPILE DONTCOPY 
 
-               (* ;; "Need TEDIT internal declarations for LA.ADJUST.FORMATTING.  Can't just do (FILES (SOURCE) TEDITDECLS), because there is a compiled version that is already loaded that isn't enough.")

+               (* ;; "Need TEDIT internal declarations for LA.ADJUST.FORMATTING.  Can't just do (FILES (SOURCE) TEDITDCL), because there is a compiled version that is already loaded that isn't enough.")

 
-               (P (CL:UNLESS (GET 'TEDITDECLS 'FILE)
-                         (FILESLOAD TEDITDECLS)))
+               (P (CL:UNLESS (GET 'TEDITDCL 'FILE)
+                         (FILESLOAD TEDITDCL)))
                (FILES (SOURCE)
                       LAFITEDECLS)
                (GLOBALVARS *TEDIT-FILE-READTABLE*)
@@ -181,8 +185,8 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation.  All rights reserved.
 )
 (DECLARE%: EVAL@COMPILE DONTCOPY 
 
-(CL:UNLESS (GET 'TEDITDECLS 'FILE)
-       (FILESLOAD TEDITDECLS))
+(CL:UNLESS (GET 'TEDITDCL 'FILE)
+       (FILESLOAD TEDITDCL))
 
 
 (FILESLOAD (SOURCE)
@@ -198,9 +202,9 @@ Copyright (c) 1988, 1990, 1992 by Xerox Corporation.  All rights reserved.
 (LOCALVARS . T)
 )
 )
-(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992))
+(PUTPROPS LAFITETEDIT COPYRIGHT ("Xerox Corporation" 1988 1990 1992 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1342 11940 (LA.ADJUST.FORMATTING 1352 . 7488) (LA.SKIP.LOOKS.LIST 7490 . 8064) (
-LA.DETACH.TEDIT 8066 . 8431) (LA.TEDIT.INCLUDE 8433 . 8922) (LA.WINDOW.FROM.TEXTSTREAM 8924 . 9370) (
-TEDIT.ASSURE.NO.BACKING.FILE 9372 . 11938)))))
+  (FILEMAP (NIL (1549 12147 (LA.ADJUST.FORMATTING 1559 . 7695) (LA.SKIP.LOOKS.LIST 7697 . 8271) (
+LA.DETACH.TEDIT 8273 . 8638) (LA.TEDIT.INCLUDE 8640 . 9129) (LA.WINDOW.FROM.TEXTSTREAM 9131 . 9577) (
+TEDIT.ASSURE.NO.BACKING.FILE 9579 . 12145)))))
 STOP

lispusers/BACKGROUND-YIELD

@@ -0,0 +1,50 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+
(FILECREATED "14-Nov-2021 22:05:58" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;2
 1597   
+
+      changes to%:  (VARS BACKGROUND-YIELD)
+
+      previous date%: "20-Sep-2021 11:37:28" {DSK}<home>larry>medley>lispusers>BACKGROUND-YIELD.;1)
+
+
+(PRETTYCOMPRINT BACKGROUND-YIELDCOMS)
+
+(RPAQQ BACKGROUND-YIELDCOMS
 (
+                                 (* ;; 
+
                               " Add a call to BACKGROUNDFNS to yield when not otherwise busy")

+
+                                 (FNS BACKGROUND-YIELD INIT-YIELD)
+                                 (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INIT-YIELD T)))
+                                 (VARS BACKGROUND-YIELD)))
+
+
+
+(* ;; " Add a call to BACKGROUNDFNS to yield when not otherwise busy")

+
+(DEFINEQ
+
+(BACKGROUND-YIELD

+  [LAMBDA NIL
                                          (* ; "Edited 20-Sep-2021 11:37 by larry")

+    (IF
 (FIXP BACKGROUND-YIELD)
+        THEN
 (SUBRCALL YIELD BACKGROUND-YIELD)
+              (SUBRCALL CAUSE-INTERRUPT])
+
+(INIT-YIELD

+  [LAMBDA (ONP)
                                        (* ; "Edited 19-Sep-2021 13:32 by larry")

+    (SETQ BACKGROUNDFNS (REMOVE 'BACKGROUND-YIELD BACKGROUNDFNS))
+    (if
 [AND ONP (CCODEP (GETD 'BACKGROUND-YIELD]
+        then
 
+
+              (* ;; " add to end")

+
+              (SETQ BACKGROUNDFNS (APPEND BACKGROUNDFNS '(BACKGROUND-YIELD
])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(INIT-YIELD
 T)
+)
+
+(RPAQQ BACKGROUND-YIELD
 833333)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (833 1482 (BACKGROUND-YIELD 843 . 1098) (INIT-YIELD 1100 . 1480)))))
+STOP

lispusers/COMPARESOURCES

@@ -1,43 +1,73 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED " 5-Sep-2020 19:02:30" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;3
 20197  
 
-      changes to%:  (FNS \CS.COMPARE.MASTERS)
+
(FILECREATED "25-Jan-2022 16:05:14" {MM}<lispusers>COMPARESOURCES.;115
 41781  
 
-      previous date%: "19-Apr-2018 10:50:03" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>COMPARESOURCES.;2)
+      :CHANGES-TO (FNS CSOBJ.BUTTONEVENTINFN)
+
+      :PREVIOUS-DATE "24-Jan-2022 23:12:17" {MM}<lispusers>COMPARESOURCES.;113)
 
 
 (* ; "
-Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation.  All rights reserved.
+Copyright (c) 1985-1988, 2018, 2020-2021 by Xerox Corporation.
 ")
 
 (PRETTYCOMPRINT COMPARESOURCESCOMS)
 
 (RPAQQ COMPARESOURCESCOMS

-       ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1
-             \CS.FILTER.GARBAGE)
-        (FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM 
-             \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS
-             \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS)
+       ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.EXAMINE \CS.FIXFNS 
+             \CS.SORT.DECLARES \CS.SORT.DECLARE1 \CS.FILTER.GARBAGE)
+        (FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM 
+             \CS.ISRECFORM \CS.ISCOURIERFORM \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM
+             \CS.PROP.NAME \CS.COMPARE.PROPS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM 
+             \CS.COMPARE.FPKGCOMS \CS.COMPARE.DEFINE-FILE-INFO)
+        [COMS (FNS CSOBJ.CREATE CSOBJ.DISPLAYFN CSOBJ.IMAGEBOXFN CSOBJ.BUTTONEVENTINFN 
+                   CSOBJ.COPYBUTTONEVENTINFN)
+              (INITVARS (COMPARESOURCES-IMAGEFNS (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN 
+                                                        NIL NIL NIL 'CSOBJ.BUTTONEVENTINFN
+                                                        'CSOBJ.COPYBUTTONEVENTINFN]
         (VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS)
+        (COMS (FNS CSBROWSER)
+              (INITVARS (COMPARESOURCES-BROWSER-TYPE 'OBJECTWINDOW))
+              (FILES (SYSLOAD)
+                     OBJECTWINDOW EXAMINEDEFS REGIONMANAGER))
         (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE)
                (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS))))
 (DEFINEQ
 
 (COMPARESOURCES

-  [LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM)
          (* ; "Edited 19-Apr-2018 10:49 by rmk:")

+  [LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM)               (* ; "Edited 26-Dec-2021 21:32 by rmk")

+                                                             (* ; "Edited 20-Dec-2021 09:51 by rmk")

+                                                             (* ; "Edited  9-Dec-2021 23:13 by rmk")

+                                                             (* ; "Edited  4-Dec-2021 19:54 by rmk")

+                                                             (* ; "Edited 23-Nov-2021 19:46 by rmk:")

+                                                             (* ; "Edited 30-Oct-2021 20:13 by rmk:")

+                                                             (* ; "Edited 19-Apr-2018 10:49 by rmk:")

 
-(* ;;; "Compare two lisp source files, reporting differences.")

+(* ;;; "Compare two lisp source files, reporting differences.  LISTSTREAM if given is an open stream")

 
     (DECLARE
 (SPECVARS FILEX FILEY EXAMINE DIFFERENCES))
-    (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY)
-          [SETQ FILEX (OR (FINDFILE FILEX T)
-                          (RETURN (printout LISTSTREAM FILEX " not found" T]
-          [SETQ FILEY (OR (FINDFILE FILEY T)
-                          (RETURN (printout LISTSTREAM FILEY " not found" T]
+    (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY DATECOL
+                 [INSERTOBJECTS (AND EXAMINE (IF
 (TEXTSTREAMP LISTSTREAM)
+                                                 THEN
 'TEDIT
+                                               ELSEIF
 (OBJWINDOWP LISTSTREAM)
+                                                 THEN
 'OBJECTWINDOW]
+                 (COMPARESTREAM LISTSTREAM)
+                 (CONTEXTSTREAM LISTSTREAM)
+                 OBJECTS)
+          (DECLARE
 (SPECVARS INSERTOBJECTS OBJECTABLE))
+          (CL:WHEN INSERTOBJECTS
+              (SETQ COMPARESTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
+              (SETQ CONTEXTSTREAM (CL:MAKE-STRING-OUTPUT-STREAM))
+              (LINELENGTH 65535 COMPARESTREAM)               (* ; "Let the receiver do the wrapping")

+              (LINELENGTH 65535 CONTEXTSTREAM))
+          (OR (INFILEP FILEX)
+              (SETQ FILEX (FINDFILE FILEX T))
+              (RETURN (printout CONTEXTSTREAM FILEX " not found" T)))
+          (OR (INFILEP FILEY)
+              (SETQ FILEY (FINDFILE FILEY T))
+              (RETURN (printout CONTEXTSTREAM FILEY " not found" T)))
 
-     (* ;; "Read the two files, throwing out extraneous forms & such:")

+     (* ;; "Read the two files, throwing out extraneous forms & such:")

 
           (CL:MULTIPLE-VALUE-SETQ (BODYX ENVX)
                  (READFILE FILEX))
@@ -45,186 +75,324 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation.  All righ
           (CL:MULTIPLE-VALUE-SETQ (BODYY ENVY)
                  (READFILE FILEY))
           (SETQ BODYY (\CS.FILTER.GARBAGE
 BODYY))
-          (printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE)
-                 " and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE)
-                 ":" T T)
+          [SETQ DATECOL (PLUS 2 (CONSTANT (NCHARS "Comparing"))
+                              (IMAX (NCHARS FILEX)
+                                    (NCHARS FILEY]
+          (printout CONTEXTSTREAM "Comparing " FILEX .TAB0 DATECOL "dated " (GETFILEINFO FILEX
+                                                                                   'CREATIONDATE)
+                 .TAB
+                 [SUB1 (CONSTANT (IDIFFERENCE (NCHARS "Comparing ")
+                                        (NCHARS "and "]
+                 " and " FILEY .TAB0 DATECOL "dated " (GETFILEINFO FILEY 'CREATIONDATE)
+                 T T)
           [SETQ DECLAREX (for
 EXPR in
 BODYX collect
 EXPR when
 (EQ (CAR EXPR)
-                                                                                  'DECLARE%:]
+                                                                  'DECLARE%:]
           (SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX))
           [SETQ DECLAREY (for
 EXPR in
 BODYY collect
 EXPR when
 (EQ (CAR EXPR)
-                                                                                  'DECLARE%:]
+                                                                  'DECLARE%:]
           (SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY))
           (WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT))
-              (\CS.COMPARE.MASTERS
 BODYX BODYY DW? LISTSTREAM)
+              (\CS.COMPARE.MASTERS
 BODYX BODYY DW? CONTEXTSTREAM COMPARESTREAM)
 
-              (* ;; "Done with the non-DECLARE: expressions.  Now sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare")

+              (* ;; "Done with the non-DECLARE: expressions.  Nw sort what's left according to when it is eval'ed so that we can hopefully further reduce the amount of stuff to compare")

 
               (SETQ BODYX (\CS.SORT.DECLARES
 DECLAREX))
               (SETQ BODYY (\CS.SORT.DECLARES
 DECLAREY))
               [SETQ BODYX (APPEND BODYX (for
 Y in
 BODYY collect
 (LIST (CAR Y))
                                            unless
 (SASSOC (CAR Y)
-                                                             BODYX]
-                                                             (* ; 
-
                "Add placeholders for any declaration types in Y not in X to simplify what follows")

+                                                         BODYX]
+                                                             (* ; 
+
                  "Add placeholders for any declaration types in Y not in X to simplify what follows")

               [for
 X in
 BODYX bind
 Y TYPE
                  do
 (SETQ Y (SASSOC (CAR X)
-                                       BODYY))
-                       (SETQ TYPE (CAR X))
-                       [SETQ X (LDIFFERENCE (CDR X)
-                                      (PROG1 (CDR Y)
-                                          (SETQ Y (LDIFFERENCE (CDR Y)
-                                                         X)))]
-                       (COND
-                          ((OR X Y)
-                           (printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
+                                   BODYY))
+                    (SETQ TYPE (CAR X))
+                    (SETQ X (CL:SET-DIFFERENCE (CDR X)
+                                   (PROG1 (CDR Y)
+                                       (SETQ Y (CL:SET-DIFFERENCE (CDR Y)
+                                                      X :TEST (FUNCTION EQUALALL))))
+                                   :TEST
+                                   (FUNCTION EQUALALL)))
+                    (COND
+                       ((OR X Y)
+                        (printout CONTEXTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
                                                                                     CL:SET-DIFFERENCE
                                                                                      TYPE 
                                                                                  DEFAULT.DECLARE.TAGS
                                                                                      )
                                                                                    '(--]
-                                  " forms------" T)          (* ; 
-
                         "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")

-                           (\CS.COMPARE.MASTERS
 (REVERSE X)
-                                  (REVERSE Y)
-                                  DW? LISTSTREAM]
-              (TERPRI LISTSTREAM))
+                               " forms------" T)             (* ; 
+
                           "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")

+                        (\CS.COMPARE.MASTERS
 (REVERSE X)
+                               (REVERSE Y)
+                               DW? CONTEXTSTREAM COMPARESTREAM]
+              (TERPRI CONTEXTSTREAM))
+          (SELECTQ INSERTOBJECTS
+              (OBJECTWINDOW (CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
+                                (PUSH
 OBJECTS (CSOBJ.CREATE
 (CL:GET-OUTPUT-STREAM-STRING 
+                                                                   CONTEXTSTREAM))))
+                            (SETQ OBJECTS (DREVERSE OBJECTS))
+                            (OBJ.ADDMANYTOW LISTSTREAM OBJECTS))
+              (TEDIT (HELP "Don't know about TEDIT"))
+              (NIL)
+              (HELP))
           (RETURN (OR (REVERSE DIFFERENCES)
                       'SAME])
 
 (\CS.COMPARE.MASTERS

-  [LAMBDA (BODYX BODYY DW? LISTSTREAM)
                  (* ; "Edited  5-Sep-2020 19:01 by rmk:")

-                                                             (* ; "Edited 15-Apr-88 14:41 by bvm")

-    (LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS)
-         (DECLARE
 (USEDFREE DIFFERENCES))
-         [SETQ FNSX (for
 EXPR in
 BODYX collect
 EXPR when
 (EQ (CAR EXPR)
-                                                                             'DEFINEQ]
-         (SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX))
-         (SETQ FNSX (for
 BOD in
 FNSX join
 (CDR BOD)))
-         [SETQ FNSY (for
 EXPR in
 BODYY collect
 EXPR when
 (EQ (CAR EXPR)
-                                                                             'DEFINEQ]
-         (SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY))
-         (SETQ FNSY (for
 BOD in
 FNSY join
 (CDR BOD)))
-         [COND
-            ((OR FNSX FNSY)
-             (printout LISTSTREAM "---Functions: " T)
-             [COND
-                (DW? (LET ((NOSPELLFLG T))
-                          (DECLARE
 (SPECVARS NOSPELLFLG))
-                          (for
 X in
 FNSX when
 (SETQ Y (ASSOC (CAR X)
-                                                                         FNSY))
-                             do
                          (* ; 
-
                                              "Only bother dwimifying the ones that look different")

-                                   (DWIMIFY (CADR X)
-                                          T)
-                                   (DWIMIFY (CADR Y)
-                                          T]
-             (COND
-                ((SETQ DIFS (\CS.COMPARE.TYPES
 FNSX FNSY NIL [FUNCTION (LAMBDA (X Y STREAM)
-                                                                             (COMPARELISTS
-                                                                              (CADR X)
-                                                                              (CADR Y)
-                                                                              STREAM]
-                                   (FUNCTION CAR)
-                                   LISTSTREAM))
-                 (push
 DIFFERENCES (CONS 'FNS DIFS]
-         [for
 TYPE in
 FILEPKGTYPES when
 (AND (CL:SYMBOLP TYPE)
-                                                         (SETQ DEFFERS (GET TYPE :DEFINED-BY)))
+  [LAMBDA (BODYX BODYY DW?)                                  (* ; "Edited 18-Jan-2022 22:00 by rmk")

+                                                             (* ; "Edited 19-Dec-2021 21:05 by rmk")

+                                                             (* ; "Edited  5-Sep-2020 19:01 by rmk:")

+                                                             (* ; "Edited 15-Apr-88 14:41 by bvm")

+    (DECLARE
 (USEDFREE DIFFERENCES COMPARESTREAM))
+    (LET (YTHING XTHING PRED DIFS TMP)
+         (SETQ BODYX (CL:REMOVE-IF (FUNCTION EDITDATE?)
+                            BODYX))                          (* ; 
+
                                                             "We don't care about editdate comments")

+         (SETQ BODYY (CL:REMOVE-IF (FUNCTION EDITDATE?)
+                            BODYY))
+         (SETQ BODYX (\CS.FIXFNS
 BODYX))
+         (SETQ BODYY (\CS.FIXFNS
 BODYY))
+         (CL:WHEN (AND (SETQ XTHING (ASSOC 'DEFINE-FILE-INFO BODYX))
+                       (SETQ YTHING (ASSOC 'DEFINE-FILE-INFO BODYY))
+                       (\CS.COMPARE.DEFINE-FILE-INFO
 XTHING YTHING))
+             (SETQ BODYX (REMOVE XTHING BODYX))
+             (SETQ BODYY (REMOVE YTHING BODYY)))
+
+         (* ;; "These are for commonlispy definers")

+
+         [for
 TYPE DEFFERS in
 FILEPKGTYPES when
 (AND (CL:SYMBOLP TYPE)
+                                                     (SETQ DEFFERS (GET TYPE :DEFINED-BY)))
             do
 
+               (* ;; "handle definer based things")

 
-                  (* ;; "handle definer based things")

+               (for
 DEFFER in
 DEFFERS do
 (SETQ XTHING (for
 X in
 BODYX collect
 X
+                                                         when
 (EQ (CAR X)
+                                                                  DEFFER)))
+                                         (SETQ YTHING (for
 X in
 BODYY collect
 X
+                                                         when
 (EQ (CAR X)
+                                                                  DEFFER))) 
 
-                  (for
 DEFFER in
 DEFFERS
-                     do
 (SETQ XTHING (for
 X in
 BODYX collect
 X
-                                            when
 (EQ (CAR X)
-                                                         DEFFER)))
-                           (SETQ YTHING (for
 X in
 BODYY collect
 X
-                                           when
 (EQ (CAR X)
-                                                        DEFFER)))
-                           (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING))
-                           (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING))
-                           (COND
-                              ((SETQ DIFS (\CS.COMPARE.TYPES
 XTHING YTHING
-                                                 (CONCAT (OR (CL:DOCUMENTATION TYPE 'DEFINE-TYPES)
-                                                             TYPE)
-                                                        " defined by " DEFFER)
-                                                 NIL
-                                                 (GET DEFFER :DEFINITION-NAME)
-                                                 LISTSTREAM))
-                               (COND
-                                  ((SETQ TMP (ASSOC TYPE DIFFERENCES))
-                                   (NCONC TMP DIFS))
-                                  (T (push
 DIFFERENCES (CONS TYPE DIFS]
-         [for
 TYPE in
 COMPARESOURCETYPES
-            do
 (SETQ PRED (fetch
 (CSTYPE PREDFN) of
 TYPE))
-                  (SETQ XTHING (for
 X in
 BODYX collect
 X when
 (CL:FUNCALL PRED X)))
-                  (SETQ YTHING (for
 X in
 BODYY collect
 X when
 (CL:FUNCALL PRED X)))
-                  (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING))
-                  (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING))
-                  (COND
-                     ((SETQ DIFS (\CS.COMPARE.TYPES
 XTHING YTHING
-                                        (OR (fetch
 (CSTYPE TITLE) of
 TYPE)
-                                            (L-CASE (MKSTRING (fetch
 (CSTYPE FPKGTYPE)
-                                                                 of
 TYPE))
-                                                   T))
-                                        (fetch
 (CSTYPE COMPAREFN) of
 TYPE)
-                                        (OR (fetch
 (CSTYPE IDFN) of
 TYPE)
-                                            (FUNCTION CADR))
-                                        LISTSTREAM))
-                      (SETQ TYPE (fetch
 (CSTYPE FPKGTYPE) of
 TYPE))
-                      (COND
-                         ((SETQ TMP (ASSOC TYPE DIFFERENCES))
-                          (NCONC TMP DIFS))
-                         (T (push
 DIFFERENCES (CONS TYPE DIFS]
-         [SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX
-                                            (SETQ BODYX (LDIFFERENCE BODYX BODYY)))]
+                                         (* ;; "Take out all of the THINGS we are about to do.  ")

+
+                                         (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
+                                                            (FUNCTION EQUALALL)))
+                                         (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
+                                                            (FUNCTION EQUALALL)))
+                                         (COND
+                                            ((SETQ DIFS (\CS.COMPARE.TYPES

+                                                         XTHING YTHING
+                                                         (CONCAT (OR (CL:DOCUMENTATION TYPE
+                                                                            'DEFINE-TYPES)
+                                                                     TYPE)
+                                                                " defined by " DEFFER)
+                                                         NIL
+                                                         (GET DEFFER :DEFINITION-NAME)))
+                                             (COND
+                                                ((SETQ TMP (ASSOC TYPE DIFFERENCES))
+                                                 (NCONC TMP DIFS))
+                                                (T (push
 DIFFERENCES (CONS TYPE DIFS]
+
+         (* ;; "These are for other filepkage types, as registered in COMPARESOURCETYPES")

+
+         [for
 TYPE in
 COMPARESOURCETYPES do
 (SETQ PRED (fetch
 (CSTYPE PREDFN) of
 TYPE))
+                                            (SETQ XTHING (for
 X in
 BODYX collect
 X
+                                                            when
 (CL:FUNCALL PRED X)))
+                                            (SETQ YTHING (for
 X in
 BODYY collect
 X
+                                                            when
 (CL:FUNCALL PRED X)))
+                                            (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING :TEST
+                                                               (FUNCTION EQUALALL)))
+                                            (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING :TEST
+                                                               (FUNCTION EQUALALL)))
+                                            (COND
+                                               ([SETQ DIFS (\CS.COMPARE.TYPES

+                                                            XTHING YTHING
+                                                            (OR (fetch
 (CSTYPE TITLE) of
 TYPE)
+                                                                (MKSTRING (fetch
 (CSTYPE FPKGTYPE)
+                                                                             of
 TYPE)))
+                                                            (fetch
 (CSTYPE COMPAREFN) of
 TYPE)
+                                                            (OR (fetch
 (CSTYPE IDFN) of
 TYPE)
+                                                                (FUNCTION CADR]
+                                                (SETQ TYPE (fetch
 (CSTYPE FPKGTYPE) of
 TYPE))
+                                                (COND
+                                                   ((SETQ TMP (ASSOC TYPE DIFFERENCES))
+                                                    (NCONC TMP DIFS))
+                                                   (T (push
 DIFFERENCES (CONS TYPE DIFS]
+         (SETQ BODYY (CL:SET-DIFFERENCE BODYY (PROG1 BODYX
+                                                  (SETQ BODYX (CL:SET-DIFFERENCE
+                                                               BODYX BODYY :TEST
+                                                               (FUNCTION EQUALALL))))
+                            :TEST
+                            (FUNCTION EQUALALL)))
          (COND
             ((OR BODYX BODYY)
-             (printout LISTSTREAM T "---Expressions:" T)
+             (printout CONTEXTSTREAM T "---Expressions:" T)
              (LET ((COMMENTX 0)
-                   (COMMENTY 0)
-                   EXTRAS)                                   (* ; "Remove comments")

-                  [SETQ BODYX (for
 X in
 BODYX collect
 X
-                                 unless
 (COND
-                                               ((EQ (CAR X)
-                                                    COMMENTFLG)
-                                                (add
 COMMENTX 1)
-                                                T]
-                  [SETQ BODYY (for
 Y in
 BODYY collect
 Y
-                                 unless
 (COND
-                                               ((EQ (CAR Y)
-                                                    COMMENTFLG)
-                                                (add
 COMMENTY 1)
-                                                T]
+                   (COMMENTY 0))                             (* ; "Remove comments")

+                  [SETQ BODYX (for
 X in
 BODYX collect
 X unless
 (COND
+                                                                  ((EQ (CAR X)
+                                                                       COMMENTFLG)
+                                                                   (add
 COMMENTX 1)
+                                                                   T]
+                  [SETQ BODYY (for
 Y in
 BODYY collect
 Y unless
 (COND
+                                                                  ((EQ (CAR Y)
+                                                                       COMMENTFLG)
+                                                                   (add
 COMMENTY 1)
+                                                                   T]
                   (COND
                      ((OR (NEQ COMMENTX 0)
                           (NEQ COMMENTY 0))
-                      (printout LISTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments." T T
-                             )))
+                      (printout CONTEXTSTREAM .I1 COMMENTX " comments -> " .I1 COMMENTY " comments."
+                             T T)))
                   [COND
-                     ((SETQ EXTRAS (COND
-                                      (BODYX (COND
-                                                (BODYY (COMPARELISTS BODYX BODYY LISTSTREAM)
-                                                       NIL)
-                                                (T (printout LISTSTREAM "These are not on " FILEY)
-                                                   BODYX)))
-                                      (BODYY (printout LISTSTREAM "These are not on " FILEX)
-                                             BODYY)))
-                      (printout LISTSTREAM ":" T)
-                      (for
 X in
 EXTRAS do
 (LVLPRINT X LISTSTREAM 2 3]
-                  [COND
-                     ((AND (OR BODYX BODYY)
-                           (OR (EQ EXAMINE T)
-                               (EQMEMB 'MISC EXAMINE)))
-                      (IF
 (EQMEMB 2WINDOWS EXAMINE)
-                          THEN
 (EDITE BODYX)
-                                (EDITE BODYY)
-                        ELSE
 (EDITE (LIST BODYX BODYY]
+                     [BODYX (COND
+                               (BODYY (COMPARELISTS BODYX BODYY COMPARESTREAM)
+                                      (\CS.EXAMINE
 BODYX BODYY))
+                               (T (printout COMPARESTREAM "These are not on File 2:" T)
+                                  (FOR
 X IN
 BODYX DO
 (LVLPRINT X COMPARESTREAM 2 3)
+                                                     (\CS.EXAMINE
 X NIL T]
+                     (BODYY (printout COMPARESTREAM "These are not on File 1:" T)
+                            (FOR
 Y IN
 BODYY DO
 (LVLPRINT Y COMPARESTREAM 2 3)
+                                               (\CS.EXAMINE
 NIL Y T]
                   (OR (ASSOC 'Other DIFFERENCES)
                       (push
 DIFFERENCES (LIST 'Other '--])
 
 (\CS.COMPARE.TYPES

-(LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN LISTSTREAM) (DECLARE (USEDFREE FILEX FILEY EXAMINE)) (* ; "Edited 29-Dec-86 11:49 by jds") (* ;;; "Compare things using COMPAREFN.  Deltas -> LISTSTREAM.") (COND ((AND (OR XTHING YTHING) (PROGN (SETQ XTHING (LDIFFERENCE XTHING (PROG1 YTHING (SETQ YTHING (LDIFFERENCE YTHING XTHING))))) (OR XTHING YTHING))) (LET (X Y RESULT NAME) (AND TITLE (printout LISTSTREAM T "---" TITLE ":" T T)) (for TAIL on XTHING do (SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL)))) (COND ((NOT (SETQ Y (find Y in YTHING suchthat (EQUAL (CL:FUNCALL IDFN Y) NAME)))) (printout LISTSTREAM |.P2| NAME " is not on " FILEY T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE X)))) (T (printout LISTSTREAM |.P2| NAME ": " T) (COND (COMPAREFN (CL:FUNCALL COMPAREFN X Y LISTSTREAM)) (T (COMPARELISTS X Y LISTSTREAM))) (TERPRI LISTSTREAM) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE OLD) EXAMINE)) (EDITE (LIST X Y)))) (RPLACA (FMEMB Y YTHING)))) (RPLACA TAIL) (push RESULT NAME)) (for Y in (LDIFFERENCE YTHING XTHING) do (printout LISTSTREAM |.P2| (SETQ NAME (CL:FUNCALL IDFN Y)) " is not on " FILEX T) (COND ((OR (EQ EXAMINE T) (EQMEMB (QUOTE NEW) EXAMINE)) (EDITE Y))) (push RESULT NAME)) RESULT))))
-)
+  [LAMBDA (XTHING YTHING TITLE COMPAREFN IDFN)               (* ; "Edited  9-Dec-2021 23:19 by rmk")

+                                                             (* ; "Edited  1-Dec-2021 23:25 by rmk:")

+                                                             (* ; "Edited 30-Nov-2021 23:07 by rmk:")

+                                                             (* ; "Edited 27-Nov-2021 12:32 by rmk:")

+                                                             (* ; "Edited 25-Nov-2021 13:29 by rmk:")

+                                                             (* ; "Edited 29-Dec-86 11:49 by jds")

+
+(* ;;; "Compare things using COMPAREFN.  Deltas -> COMPARESTREAM.  Anything that passes the WHEN predicate has a difference somewhere, will produce some output. ")

+
+    (DECLARE
 (USEDFREE CONTEXTSTREAM COMPARESTREAM))
+    (LET (X Y RESULT NAME)
+         (CL:WHEN (AND (OR XTHING YTHING)
+                       (PROGN (SETQ XTHING (CL:SET-DIFFERENCE XTHING
+                                                  (PROG1 YTHING
+                                                      (SETQ YTHING (CL:SET-DIFFERENCE
+                                                                    YTHING XTHING :TEST
+                                                                    (FUNCTION EQUALALL))))
+                                                  :TEST
+                                                  (FUNCTION EQUALALL)))
+                              (OR XTHING YTHING)))
+             DF
+
+             (* ;; "We know we are going to have some output.  Strings can go directly onto theCONTEXTSTREAM, and objects may then be inserted.")

+
+             (AND TITLE (printout CONTEXTSTREAM T "---" TITLE ":" T T))
+             (for
 TAIL on
 XTHING
+                do
 [SETQ NAME (CL:FUNCALL IDFN (SETQ X (CAR TAIL]
+                   [COND
+                      ([NOT (SETQ Y (find
 Y in
 YTHING suchthat
 (EQUAL (CL:FUNCALL IDFN Y)
+                                                                      NAME]
+                       (printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT 
+                              " is not on File 2" T T)
+                       (\CS.EXAMINE
 X NIL T NAME))
+                      (T (printout COMPARESTREAM .FONT BOLDFONT .P2 NAME ":" .FONT DEFAULTFONT T)
+                         (COND
+                            (COMPAREFN (CL:FUNCALL COMPAREFN X Y COMPARESTREAM))
+                            (T (COMPARELISTS X Y COMPARESTREAM)))
+                         (\CS.EXAMINE
 X Y NIL NAME)
+                         (RPLACA (FMEMB Y YTHING]
+                   (RPLACA TAIL)
+                   (push
 RESULT NAME))
+             (for
 Y in
 (CL:SET-DIFFERENCE YTHING XTHING :TEST (FUNCTION EQUALALL))
+                do
 (SETQ NAME (CL:FUNCALL IDFN Y))
+                   (printout COMPARESTREAM .FONT BOLDFONT .P2 NAME .FONT DEFAULTFONT 
+                          " is not on File 1" T T)
+                   (\CS.EXAMINE
 Y NIL T NAME)
+                   (push
 RESULT NAME))
+             RESULT)])
+
+(\CS.EXAMINE

+  [LAMBDA (X Y ONLYONE NAME TYPE)                            (* ; "Edited 24-Dec-2021 22:48 by rmk")

+                                                             (* ; "Edited 19-Dec-2021 22:46 by rmk")

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

+                                                             (* ; "Edited  4-Dec-2021 16:43 by rmk")

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

+                                                             (* ; "Edited 29-Nov-2021 20:37 by rmk:")

+                                                             (* ; "Edited 27-Nov-2021 11:21 by rmk:")

+    (DECLARE
 (USEDFREE EXAMINE INSERTOBJECTS COMPARESTREAM CONTEXTSTREAM OBJECTS))
+
+    (* ;; "ONLYONE as a flag, because we don't want to test X or Y for NIL, that could be the contrasting value.")

+
+    (* ;; "I don't understand MISC:  changed but otherwise unclassified.  Does that mean just an unknown type?")

+
+    (* ;; "The only call seemed to be from \CS.COMPARE.MASTERS, where EXTRAS is set to either BODYX or BODYY if the other one is NIL.  It may be that that call only happens in the MISC case.")

+
+    (CL:UNLESS NAME (SETQ NAME "from File"))
+
+    (* ;; "Context gets printed to the CONTEXTSTREAM, diffs go to the COMPARESTREAM. If we aren't doing objects, those are the same streams, and the output gets printed in the right order.  Nothing to do here.")

+
+    (IF
 INSERTOBJECTS
+        THEN
 (SELECTQ INSERTOBJECTS
+                 (OBJECTWINDOW [LET (STRING)
+
+                                    (* ;; "Take out last EOL, let SEPDIST space things out.")

+
+                                    (CL:UNLESS (EQ 0 (GETFILEPTR CONTEXTSTREAM))
+                                        (SETQ STRING (CL:GET-OUTPUT-STREAM-STRING CONTEXTSTREAM))
+                                        (CL:WHEN (EQ (CHARCODE EOL)
+                                                     (NTHCHARCODE STRING -1))
+                                            (SETQ STRING (OR (SUBSTRING STRING 1 -2)
+                                                             "")))
+                                        (PUSH
 OBJECTS (CSOBJ.CREATE
 STRING)))
+                                    (CL:UNLESS (EQ 0 (GETFILEPTR COMPARESTREAM))
+                                        (SETQ STRING (CL:GET-OUTPUT-STREAM-STRING COMPARESTREAM))
+
+                                 (* ;; "Don't know why, but SEPTDIST doesn't work if there if there isn't at least one EOL. Magically, this gets the right appearance and behavior.")

+
+                                        (CL:WHEN (AND (EQ (CHARCODE EOL)
+                                                          (NTHCHARCODE STRING -1))
+                                                      (EQ (CHARCODE EOL)
+                                                          (NTHCHARCODE STRING -2)))
+                                            (SETQ STRING (OR (SUBSTRING STRING 1 -2)
+                                                             "")))
+                                        (PUSH
 OBJECTS (CSOBJ.CREATE
 STRING
+                                                             (LIST NAME TYPE X Y LABEL1 LABEL2)
+                                                             ONLYONE)))])
+                 (TEDIT (HELP "TEDIT NOT IMPLEMENTED"))
+                 NIL)
+      ELSEIF
 (OR (LISTP X)
+                 (LISTP Y))
+        THEN
                                                 (* ; 
+
                                                    "No point in bringing up an editor on a non-list")

+             (IF
 ONLYONE
+                 THEN
 (IF
 (OR (EQMEMB T EXAMINE)
+                              (EQMEMB 'NEW EXAMINE))
+                          THEN
 (EDITE (OR X Y)))
+               ELSEIF
 (OR (EQMEMB T EXAMINE)
+                          (EQMEMB 'OLD EXAMINE)
+                          (EQMEMB 'MISCC))
+                 THEN
 (IF
 (EQMEMB '2WINDOWS EXAMINE)
+                          THEN
 (EXAMINEDEFS X Y NAME TYPE)
+                        ELSE
 (EDITE (LIST X Y])
+
+(\CS.FIXFNS

+  [LAMBDA (BODY DW?)
                                        (* ; "Edited 29-Nov-2021 20:42 by rmk:")


+                                                            (* ; "Edited 26-Nov-2021 13:34 by rmk:")

+
+    (* ;; "RMK: Functions are special in that they are grouped under DEFINEQ and they may need dwimifying.  We don't want to deal with these idiosyncracies below, so our strategy is to split each multi-fn defineq into a sequence of single-fn defineqs , one for each function, then let it fall through.  After dwimifying, things should be standard.")

+
+    (LET (DEFINEQS FNS (NOSPELLFLG T))
+         (DECLARE
 (SPECVARS NOSPELLFLG))
+         [SETQ DEFINEQS (for
 EXPR in
 BODY collect
 EXPR when
 (EQ (CAR EXPR)
+                                                                'DEFINEQ]
+         (SETQ BODY (CL:SET-DIFFERENCE BODY DEFINEQS))       (* ; 
+
                    "Remove all the multiple function defineqs, so we can pack on the exploded forms")

+         [SETQ FNS (for
 DFQ in
 DEFINEQS join
 (FOR
 FN IN
 (CDR DFQ)
+                                                COLLECT
 
+
+                                                      (* ;; "FN is a single (NAME DEF) pair")

+
+                                                      `(DEFINEQ (,@FN]
+         (CL:WHEN DW?
+             (FOR
 FN IN
 FNS DO
 (DWIMIFY (CADADR FN)
+                                      T)))
+         (SETQ BODY (APPEND FNS BODY])
 
 (\CS.SORT.DECLARES

 (LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags  . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT))
@@ -240,6 +408,24 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation.  All righ
 )
 (DEFINEQ
 
+(\CS.ISFNFORM

+  [LAMBDA (X)
                                               (* ; "Edited 29-Nov-2021 20:34 by rmk:")


+                                                            (* ; "Edited 26-Nov-2021 13:19 by rmk:")

+    (EQ 'DEFINEQ (CAR (LISTP X])
+
+(\CS.COMPARE.FNS

+  [LAMBDA (DQX DQY STREAM)
                                  (* ; "Edited 29-Nov-2021 20:51 by rmk:")

+
+    (* ;; "CADADR is the body")

+
+    (COMPARELISTS (CADADR DQX)
+           (CADADR DQY)
+           STREAM])
+
+(\CS.FNSID

+  [LAMBDA (DQX)
                                             (* ; "Edited 29-Nov-2021 20:50 by rmk:")

+    (CAR (CADR DQX])
+
 (\CS.ISVARFORM

 (LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL)))
 
@@ -290,10 +476,144 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation.  All righ
 (\CS.COMPARE.FPKGCOMS

 (LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:16 by jds") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (COMPARELISTS (CADR (CADDDR X)) (CADR (CADDDR Y)) STREAM))
 )
+
+(\CS.COMPARE.DEFINE-FILE-INFO

+  [LAMBDA (DFI1 DFI2)                                        (* ; "Edited 19-Dec-2021 21:02 by rmk")

+    (AND (EQUAL (LISTGET :READTABLE DFI1)
+                (LISTGET :READTABLE DFI2))
+         (EQUAL (LISTGET :PACKAGE DFI1)
+                (LISTGET :PACKAGE DFI2))
+         (EQ (OR (LISTGET :BASE DFI1)
+                 10)
+             (OR (LISTGET :BASE DFI2)
+                 10))
+         (EQ (OR (LISTGET :FORMAT DFI1)
+                 *DEFAULT-EXTERNALFORMAT*)
+             (OR (LISTGET :FORMAT DFI2)
+                 *DEFAULT-EXTERNALFORMAT*])
+)
+(DEFINEQ
+
+(CSOBJ.CREATE

+  [LAMBDA (STRING COMPAREDATA ONLYONE)
                       (* ; "Edited  4-Dec-2021 09:57 by rmk")


+                                                            (* ; "Edited  1-Dec-2021 13:26 by rmk:")

+    (LET ((OBJ (IMAGEOBJCREATE STRING COMPARESOURCES-IMAGEFNS)))
+         (IMAGEOBJPROP OBJ 'COMPAREDATA COMPAREDATA)
+         (IMAGEOBJPROP OBJ 'ONLYONE ONLYONE)
+         OBJ])
+
+(CSOBJ.DISPLAYFN

+  [LAMBDA (OBJ WINDOW)
                                       (* ; "Edited  4-Dec-2021 08:24 by rmk")


+                                                            (* ; "Edited  1-Dec-2021 14:18 by rmk:")

+    (DSPFONT DEFAULTFONT WINDOW)
+    (FOR
 I C (FONTARRAY _ (FONTMAPARRAY))
+         (STRING _ (IMAGEOBJPROP OBJ 'OBJECTDATUM)) FROM
 1
+       DO
 (SELCHARQ (SETQ C (NTHCHARCODE STRING I))
+               (EOL (TERPRI WINDOW))
+               (NIL (RETURN))
+               (IF
 (EQ C (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
+                   THEN
 (DSPFONT (ELT FONTARRAY (NTHCHARCODE STRING (ADD
 I 1)))
+                               WINDOW)
+                 ELSE
 (PRINTCCODE C WINDOW])
+
+(CSOBJ.IMAGEBOXFN

+  [LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN)             (* ; "Edited  9-Dec-2021 23:02 by rmk")

+                                                             (* ; "Edited  7-Dec-2021 10:50 by rmk")

+                                                             (* ; "Edited  5-Dec-2021 23:52 by rmk")

+                                                             (* ; "Edited  4-Dec-2021 08:24 by rmk")

+                                                             (* ; "Edited  1-Dec-2021 13:27 by rmk:")

+
+    (* ;; "Calculate the height of each line, and the width of the widest line.")

+
+    (* ;; 
+
    "Probably ought to compute the max height per line, at every font change, add it at each EOL.")

+
+    (SETQ IMAGESTREAM (GETSTREAM IMAGESTREAM 'OUTPUT))
+    (FOR
 I C (STRING _ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
+         (FONT _ (FONTCREATE DEFAULTFONT NIL NIL NIL IMAGESTREAM))
+         (HEIGHT _ 0)
+         (LINELENGTH _ 0)
+         (MAXLINELENGTH _ 0)
+         (FONTARRAY _ (FONTMAPARRAY)) FROM
 1
+       DO
 (SELCHARQ (SETQ C (NTHCHARCODE STRING I))
+               (EOL (ADD
 HEIGHT (FONTPROP FONT 'HEIGHT))
+                    (CL:WHEN (IGREATERP LINELENGTH MAXLINELENGTH)
+                           (SETQ MAXLINELENGTH LINELENGTH))
+                    (SETQ LINELENGTH 0))
+               (NIL                                          (* ; "end of string")

+                    (CL:WHEN (IGREATERP LINELENGTH MAXLINELENGTH)
+                           (SETQ MAXLINELENGTH LINELENGTH))
+                    (RETURN (CREATE
 IMAGEBOX
+                                   XSIZE _ MAXLINELENGTH
+                                   YSIZE _ HEIGHT
+                                   YDESC _ (DIFFERENCE HEIGHT (FONTPROP FONT 'HEIGHT))
+                                   XKERN _ 0)))
+               (IF
 (EQ C (CONSTANT (CHARCODE.DECODE FONTESCAPECHAR)))
+                   THEN
 (SETQ FONT (FONTCREATE (ELT FONTARRAY (NTHCHARCODE STRING (ADD
 I 1)))
+                                          NIL NIL NIL IMAGESTREAM))
+                 ELSE
 (ADD
 LINELENGTH (CHARWIDTH C FONT])
+
+(CSOBJ.BUTTONEVENTINFN

+  [LAMBDA (OBJ WINDOW)
                                       (* ; "Edited 25-Jan-2022 16:04 by rmk")


+                                                             (* ; "Edited 23-Jan-2022 18:11 by rmk")

+    (LET
+     [(COMPAREDATA (IMAGEOBJPROP OBJ 'COMPAREDATA]
+     (CL:WHEN (AND COMPAREDATA (MOUSESTATE LEFT)
+                   (UNTILMOUSESTATE (NOT LEFT)))
+         (LET
+          ((NAME (POP
 COMPAREDATA))
+           (TYPE (POP
 COMPAREDATA))
+           (DEF1 (POP
 COMPAREDATA))
+           (DEF2 (POP
 COMPAREDATA))
+           (TITLE1 (POP
 COMPAREDATA))
+           (TITLE2 (CAR COMPAREDATA)))
+
+          (* ;; "Move the cursor to just slightly below the current object, so that the edit windows are well aligned. We have to figure out the bottom of the current object, in screen coordinates.")

+
+          [LET ((OBJREGION (OBJ.FIND.REGION WINDOW OBJ)))
+               (\CURSORPOSITION (IPLUS 20 LASTMOUSEX)
+                      (IPLUS (IDIFFERENCE (FETCH
 (REGION BOTTOM) OF
 OBJREGION)
+                                    (FETCH
 (REGION HEIGHT) OF
 OBJREGION))
+                             (FETCH
 (REGION TOP) OF
 (WINDOWREGION WINDOW]
+          (LET
+           [EWINDOW (RELPOS (RELCREATEPOSITION `(,WINDOW 0.5)
+                                   `(,WINDOW 0 -2]
+           (CL:WHEN [WINDOWP (SETQ EWINDOW (WINDOWPROP WINDOW 'EXAMINEWINDOW]
+                  (CLOSEW EWINDOW))
+           (SETQ EWINDOW
+            (IF
 (IMAGEOBJPROP OBJ 'ONLYONE)
+                THEN

+                [SEDIT:GET-WINDOW
+                 (SEDIT:SEDIT (OR DEF1 DEF2)
+                        `(:REGION ,(RELCREATEREGION 600 (CL:IF (ILESSP (COUNT
 (OR DEF1 DEF2))
+                                                                      100)
+                                                            150
+                                                            400)
+                                          (CL:IF DEF1
+                                              'RIGHT
+                                              'LEFT)
+                                          'TOP RELPOS NIL T]
+              ELSE
                                           (* ; "Spread the arguments")

+                   (EXAMINEDEFS NAME TYPE DEF1 DEF2 TITLE1 TITLE2 RELPOS)))
+           (WINDOWPROP WINDOW 'EXAMINEWINDOW EWINDOW)
+           (WINDOWADDPROP WINDOW 'CLOSEFN [FUNCTION (LAMBDA (W)
+                                                      (CLOSEW (WINDOWPROP W 'EXAMINEWINDOW]
+                  T)
+           EWINDOW)))])
+
+(CSOBJ.COPYBUTTONEVENTINFN

+  [LAMBDA (OBJ WINDOW REGION)                                (* ; "Edited  3-Jan-2022 08:36 by rmk")

+    (CL:WHEN (CAR (IMAGEOBJPROP OBJ 'COMPAREDATA))
+        [COPYINSERT (CAR (IMAGEOBJPROP OBJ 'COMPAREDATA])])
 )
 
+(RPAQ? COMPARESOURCES-IMAGEFNS
 (IMAGEFNSCREATE 'CSOBJ.DISPLAYFN 'CSOBJ.IMAGEBOXFN NIL NIL NIL
+                                      'CSOBJ.BUTTONEVENTINFN
+                                      'CSOBJ.COPYBUTTONEVENTINFN))
+
 (RPAQQ COMPARESOURCETYPES

-       ((VARS \CS.ISVARFORM \CS.COMPARE.VARS)
+       ((FNS \CS.ISFNFORM \CS.COMPARE.FNS \CS.FNSID "FNS defined by DEFINEQ")
+        (VARS \CS.ISVARFORM \CS.COMPARE.VARS)
         (MACROS \CS.ISMACROFORM)
         (RECORDS \CS.ISRECFORM)
         (PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties")
@@ -303,6 +623,60 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation.  All righ
         (FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR)))
 
 (RPAQQ DEFAULT.DECLARE.TAGS
 (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST))
+(DEFINEQ
+
+(CSBROWSER

+  [LAMBDA (FILEX FILEY DW? LABEL1 LABEL2 REGION)
+
+    (* ;; "Edited 24-Jan-2022 23:11 by rmk: EXAMINE is non-NIL, we run the compare twice.  Once to get the TEDIT up as a kind of table of contents, and the second time to run through all of the SEDIT windows.")

+
+    (* ;; "If EXAMINE is non-NIL, we run the compare twice.  Once to get the TEDIT up as a kind of table of contents, and the second time to run through all of the SEDIT windows.")

+
+    (* ;; "Returns browser window")

+
+    (* ;; "Don't use the INFILEP value, because that might screw with capitalization that the caller prefers.  If the file can be found that way, then lower functions will find it.")

+
+    (DECLARE
 (SPECVARS LABEL1 LABEL2))
+    (OR (INFILEP FILEX)
+        (SETQ FILEX (FINDFILE FILEX NIL DIRECTORIES))
+        (ERROR "FILE NOT FOUND" FILEX))
+    (OR (INFILEP FILEY)
+        (SETQ FILEY (FINDFILE FILEY NIL DIRECTORIES))
+        (ERROR "FILE NOT FOUND" FILEY))
+    (CL:UNLESS (LISPSOURCEFILEP FILEX)
+           (ERROR FILEX " is not a Medley source file"))
+    (CL:UNLESS (LISPSOURCEFILEP FILEY)
+           (ERROR FILEX " is not a Medley source file"))
+    (LET [(TITLE (CONCAT "COMPARESOURCES of " (OR LABEL1 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL
+                                                                'BODY FILEX))
+                        " and "
+                        (OR LABEL2 (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FILEY]
+         (SELECTQ COMPARESOURCES-BROWSER-TYPE
+             (OBJECTWINDOW (LET [(WINDOW (OBJ.CREATEW 'VERTICAL REGION TITLE NIL T
+                                                (FONTPROP DEFAULTFONT 'HEIGHT]
+                                (WINDOWPROP WINDOW 'UNDERSCONTRUCTION T)
+                                (GETPROMPTWINDOW WINDOW T)
+                                (WINDOWPROP WINDOW 'UNDERSCONTRUCTION NIL)
+                                (COMPARESOURCES
 FILEX FILEY '(T 2WINDOWS)
+                                       DW? WINDOW)
+                                (OPENW WINDOW)
+                                WINDOW))
+             (TEDIT (LET ((TSTREAM (OPENTEXTSTREAM)))
+                         (DSPFONT DEFAULTFONT TSTREAM)
+                         (COMPARESOURCES
 FILEX FILEY EXAMINE DW? TSTREAM)
+                         [TEDIT TSTREAM REGION NIL `(READONLY T WINDOWTYPE COMPARESOURCES-TEDIT TITLE
+                                                           ,TITLE]
+                         (CL:WHEN NIL
+                             EXAMINE
+                             (COMPARESOURCES
 FILEX FILEY EXAMINE DW? (OPENSTREAM '{NULL} 'OUTPUT)))
+                         (WFROMDS TSTREAM)))
+             (HELP])
+)
+
+(RPAQ? COMPARESOURCES-BROWSER-TYPE
 'OBJECTWINDOW)
+
+(FILESLOAD (SYSLOAD)
+       OBJECTWINDOW EXAMINEDEFS REGIONMANAGER)
 (DECLARE%: EVAL@COMPILE DONTCOPY 
 (DECLARE%: EVAL@COMPILE
 
@@ -314,14 +688,18 @@ Copyright (c) 1985, 1986, 1987, 1988, 2018, 2020 by Xerox Corporation.  All righ
 (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)
 )
 )
-(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020))
+(PUTPROPS COMPARESOURCES COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 2018 2020 2021))
 (DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1166 16557 (COMPARESOURCES 1176 . 5134) (\CS.COMPARE.MASTERS 5136 . 13057) (
-\CS.COMPARE.TYPES 13059 . 14308) (\CS.SORT.DECLARES 14310 . 14653) (\CS.SORT.DECLARE1 14655 . 16075) (
-\CS.FILTER.GARBAGE 16077 . 16555)) (16558 19286 (\CS.ISVARFORM 16568 . 16673) (\CS.COMPARE.VARS 16675
- . 17337) (\CS.ISMACROFORM 17339 . 17477) (\CS.ISRECFORM 17479 . 17572) (\CS.ISCOURIERFORM 17574 . 
-17674) (\CS.ISTEMPLATEFORM 17676 . 17774) (\CS.COMPARE.TEMPLATES 17776 . 18141) (\CS.ISPROPFORM 18143
- . 18298) (\CS.PROP.NAME 18300 . 18445) (\CS.COMPARE.PROPS 18447 . 18604) (\CS.ISADDVARFORM 18606 . 
-18699) (\CS.COMPARE.ADDVARS 18701 . 18866) (\CS.ISFPKGCOMFORM 18868 . 19075) (\CS.COMPARE.FPKGCOMS 
-19077 . 19284)))))
+  (FILEMAP (NIL (1768 27559 (COMPARESOURCES 1778 . 8291) (\CS.COMPARE.MASTERS 8293 . 16437) (
+\CS.COMPARE.TYPES 16439 . 19577) (\CS.EXAMINE 19579 . 23806) (\CS.FIXFNS 23808 . 25310) (
+\CS.SORT.DECLARES 25312 . 25655) (\CS.SORT.DECLARE1 25657 . 27077) (\CS.FILTER.GARBAGE 27079 . 27557))
+ (27560 31540 (\CS.ISFNFORM 27570 . 27838) (\CS.COMPARE.FNS 27840 . 28082) (\CS.FNSID 28084 . 28228) (
+\CS.ISVARFORM 28230 . 28335) (\CS.COMPARE.VARS 28337 . 28999) (\CS.ISMACROFORM 29001 . 29139) (
+\CS.ISRECFORM 29141 . 29234) (\CS.ISCOURIERFORM 29236 . 29336) (\CS.ISTEMPLATEFORM 29338 . 29436) (
+\CS.COMPARE.TEMPLATES 29438 . 29803) (\CS.ISPROPFORM 29805 . 29960) (\CS.PROP.NAME 29962 . 30107) (
+\CS.COMPARE.PROPS 30109 . 30266) (\CS.ISADDVARFORM 30268 . 30361) (\CS.COMPARE.ADDVARS 30363 . 30528) 
+(\CS.ISFPKGCOMFORM 30530 . 30737) (\CS.COMPARE.FPKGCOMS 30739 . 30946) (\CS.COMPARE.DEFINE-FILE-INFO 
+30948 . 31538)) (31541 37731 (CSOBJ.CREATE 31551 . 31964) (CSOBJ.DISPLAYFN 31966 . 32719) (
+CSOBJ.IMAGEBOXFN 32721 . 34882) (CSOBJ.BUTTONEVENTINFN 34884 . 37481) (CSOBJ.COPYBUTTONEVENTINFN 37483
+ . 37729)) (38595 41299 (CSBROWSER 38605 . 41297)))))
 STOP