Update README.md

* 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

* REGIONMANAGER:  Added CLOSEWITH and MOVEWITh

Primitives for building hierarchically dependent window clusters

* PSEUDOHOSTS:  Added PSEUDOHOSTNAME, hierarchical hosts #663

For hierarchical hosts (hosts whose prefixes are extensions of the prefixes of other pseudohosts), always the pseudofilename is always the shortest one.  See #663 for more details

* EXAMINEDEFS:  Fix prettyprint of non-function expressions

* GITFNS, Comparison files:  Use CLOSEWITH and MOVEWITH abstractions for window hierarchies

.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,6 +36,3 @@ core
 
 # Mac OS detritus
 .DS_Store
-
-# set up by install-diff-filter.sh script
-.gitattributes

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.

CLTL2/CMLDEFFER.~2~

@@ -1,248 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
-
(IL:FILECREATED "24-Mar-92 14:56:18" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLDEFFER.;3|
 40644  
-
-      IL:|changes| IL:|to:|  (IL:VARS IL:CMLDEFFERCOMS)
-
-      IL:|previous| IL:|date:| " 4-Jan-92 15:32:26" 
-IL:|{DSK}<usr>local>lde>lispcore>sources>CMLDEFFER.;2|)
-
-
-; Copyright (c) 1986, 1900, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
-
-(IL:PRETTYCOMPRINT IL:CMLDEFFERCOMS)
-
-(IL:RPAQQ IL:CMLDEFFERCOMS ((IL:* IL:|;;;| "DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.") (IL:* IL:|;;| "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned.") (IL:* IL:|;;;| "Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init") (IL:COMS (IL:* IL:\; "Filepkg interface") (IL:FUNCTIONS REMOVE-COMMENTS PPRINT-DEFINER PPRINT-DEFINER-FITP PPRINT-DEFINER-RECURSE) (IL:VARIABLES IL:*REMOVE-INTERLISP-COMMENTS*) (IL:* IL:\; "Share with xcl?") (IL:FUNCTIONS %DEFINE-TYPE-DELDEF %DEFINE-TYPE-GETDEF %DEFINE-TYPE-FILE-DEFINITIONS %DEFINE-TYPE-FILEGETDEF %DEFINE-TYPE-SAVE-DEFN %DEFINE-TYPE-PUTDEF)) (IL:COMS (IL:* IL:\; "Compatibility with old cmldeffer") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:MOVD (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN)) (IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF)) (IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER))))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:* IL:|;;| "Set up fake definer prototype stuff for FNS") (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))) (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))))) (IL:COMS (IL:* IL:\; "The groundwork for bootstrapping ") (IL:DEFINE-TYPES IL:DEFINE-TYPES IL:FUNCTIONS IL:VARIABLES) (IL:* IL:\; "DefDefiner itself and friends") (IL:FUNCTIONS SI::EXPANSION-FUNCTION SI::MACRO-FUNCALL WITHOUT-FILEPKG)) (IL:COMS (IL:* IL:\; "Compatibility with old cmldeffer") (IL:FUNCTIONS IL:WITHOUT-FILEPKG)) (IL:COMS (IL:* IL:\; "Some special forms") (IL:FUNCTIONS DEFINER DEFINER-VARIABLE-TYPE NAMED-PROGN)) (IL:COMS (IL:* IL:\; "Auxiliary functions") (IL:FUNCTIONS GET-DEFINER-NAME %DELETE-DEFINER) (IL:FUNCTIONS DEF-DEFINE-TYPE DEFDEFINER DEFDEFINER-VARIABLE-TYPE) (IL:FUNCTIONS %EXPAND-DEFINER %DEFINER-NAME)) (IL:COMS (IL:* IL:\; "The most commonly-used definers") (IL:FUNCTIONS DEFUN DEFINLINE DEFMACRO) (IL:FUNCTIONS DEFVAR DEFPARAMETER DEFCONSTANT DEFGLOBALVAR DEFGLOBALPARAMETER)) (IL:COMS (IL:* IL:\; "Here so that the evaluator can be in the init without definers being in the init.") (IL:DEFINE-TYPES IL:SPECIAL-FORMS) (IL:FUNCTIONS %REMOVE-SPECIAL-FORM) (IL:FUNCTIONS DEFINE-SPECIAL-FORM) (IL:* IL:\; "Form for defining interpreters of special forms")) (IL:COMS (IL:* IL:\; "Don't note changes to these properties/variables") (IL:PROP IL:PROPTYPE IL:MACRO-FN :UNDEFINERS IL:UNDEFINERS :DEFINER-FOR IL:DEFINER-FOR :DEFINED-BY IL:DEFINED-BY :DEFINITION-NAME IL:DEFINITION-NAME) (IL:* IL:\; "Templates for definers not defined here.  These should really be where they're defined.") (IL:PROP :DEFINITION-PRINT-TEMPLATE DEFCOMMAND DEFINE-CONDITION DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD DEFSETF DEFSTRUCT DEFTYPE)) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLDEFFER)))
-
-
-
-(IL:* IL:|;;;| 
-"DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.")

-
-
-
-
-(IL:* IL:|;;| 
-"BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned."
-)

-
-
-
-
-(IL:* IL:|;;;| 
-"Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init"
-)

-
-
-
-
-(IL:* IL:\; "Filepkg interface")

-
-
-(DEFUN REMOVE-COMMENTS (X) (IL:* IL:|;;;| "Removes SEdit-style comments from the given list structure.") (COND ((NOT (CONSP X)) X) ((AND (CONSP (CAR X)) (EQ (CAAR X) (QUOTE IL:*)) (CONSP (CDAR X)) (OR (MEMBER (CADAR X) (QUOTE (IL:\; IL:|;;| IL:|;;;| IL:|;;;;| IL:\|)) :TEST (FUNCTION EQ)) (IL:* IL:\; "a sedit comment") (EQ IL:*REMOVE-INTERLISP-COMMENTS* T) (IL:* IL:\; "always strip") (PROGN (IF (EQ IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :WARN)) (WARN "Possible comment not stripped ~S" (CAR X))) NIL))) (REMOVE-COMMENTS (CDR X))) (T (LET ((A (REMOVE-COMMENTS (CAR X))) (D (REMOVE-COMMENTS (CDR X)))) (IF (AND (EQ A (CAR X)) (EQ D (CDR X))) X (CONS A D))))))
-
-(DEFUN PPRINT-DEFINER (DEFINE-EXPRESSION) (DECLARE (SPECIAL IL:FORMFLG IL:SPACEWIDTH)) (IL:* IL:\; "Bound in prettyprinter") (COND ((OR (NULL IL:FORMFLG) (ATOM (CDR DEFINE-EXPRESSION))) (IL:* IL:\; "Degenerate cases or printing as a quoted form--punt to default prettyprinting") DEFINE-EXPRESSION) (T (LET ((IL:TAIL DEFINE-EXPRESSION) (IL:LEFT (IL:DSPXPOSITION)) TEMPLATE TOP-LEVEL-P NEXT TYPE FORM NEWLINEP) (DECLARE (SPECIAL IL:TAIL IL:LEFT)) (IL:* IL:\; "For comment printer") (SETQ TOP-LEVEL-P (EQ IL:LEFT (IL:DSPLEFTMARGIN))) (IL:* IL:\; "Printing definition to file, etc.") (SETQ IL:LEFT (+ IL:LEFT (* 3 IL:SPACEWIDTH))) (IL:* IL:\; "Place we will indent body") (IL:PRIN1 "(") (IL:PRIN2 (CAR IL:TAIL)) (SETQ TEMPLATE (OR (GET (POP IL:TAIL) :DEFINITION-PRINT-TEMPLATE) (QUOTE (:NAME)))) (IL:* IL:|;;| "This code should, and doesn't, pay attention to the NAME function to determine where the name is to decide what should and shouldn't be bold. Right now, it always bolds the second thing. Fortunately, we currently don't have any definers that don't have either the second or CAR of the second as the definition name.") (IL:* IL:|;;| "Also, this code should be careful about calling the NAME function on the form.  Sometimes, the form is not really a call to the definer but instead a back-quoted expression in a macro.  In most such cases, the name is not really there; some comma-quoted expression is there instead.") (IL:WHILE (CONSP IL:TAIL) IL:DO (COND ((AND (LISTP (SETQ NEXT (CAR IL:TAIL))) (EQ (CAR NEXT) IL:COMMENTFLG) (IL:SEMI-COLON-COMMENT-P NEXT)) (IL:* IL:\; "Comments can appear anywhere, so print this one without consuming the template.  ENDLINE has side effect of printing comments") (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*) (SETQ NEWLINEP T)) ((OR (ATOM TEMPLATE) (EQ (SETQ TYPE (POP TEMPLATE)) :BODY)) (IL:* IL:\; "Once we hit the body, there's nothing more special to do.") (RETURN)) (T (IL:SPACES 1) (CASE TYPE (:NAME (IL:* IL:\; "Embolden the name of this thing") (SETQ NEWLINEP NIL) (COND ((NOT TOP-LEVEL-P) (IL:* IL:\; "Nothing special here--could even be a backquoted thing") (PPRINT-DEFINER-RECURSE)) (T (POP IL:TAIL) (COND ((CONSP NEXT) (IL:* IL:\; "Name is a list.  Assume the real name is the car and the rest is an options list or something") (UNLESS (EQ (IL:DSPYPOSITION) (PROGN (IL:PRIN1 "(") (IL:PRINTOUT NIL IL:.FONT IL:LAMBDAFONT IL:.P2 (CAR NEXT) IL:.FONT IL:DEFAULTFONT) (IL:SPACES 1) (IL:PRINTDEF (CDR NEXT) T T T IL:FNSLST) (IL:PRIN1 ")") (IL:DSPYPOSITION))) (IL:* IL:\; "This thing took more than one line to print, so go to new line") (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*) (SETQ NEWLINEP T))) (T (IL:* IL:\; "Atomic name is bold") (IL:PRINTOUT NIL IL:.FONT IL:LAMBDAFONT IL:.P2 NEXT IL:.FONT IL:DEFAULTFONT)))))) (:ARG-LIST (IL:* IL:\; "NEXT is some sort of argument list.  ") (COND ((NULL NEXT) (IL:* IL:\; "If NIL, be sure to print as ()") (IL:PRIN1 "()") (POP IL:TAIL)) (T (PPRINT-DEFINER-RECURSE))) (SETQ NEWLINEP NIL)) (T (IL:* IL:\; "Just print it, perhaps starting a new line") (UNLESS (OR NEWLINEP (PPRINT-DEFINER-FITP NEXT)) (IL:* IL:\; "Go to new line if getting crowded") (IL:PRINENDLINE IL:LEFT)) (PPRINT-DEFINER-RECURSE) (SETQ NEWLINEP NIL)))))) (IL:* IL:|;;| "We've now gotten to the end of stuff we know how to print.  Just prettyprint the rest") (UNLESS (NULL IL:TAIL) (COND (NEWLINEP (IL:* IL:\; "Already on new line")) ((OR (EQ TYPE :BODY) (NOT (PPRINT-DEFINER-FITP (CAR IL:TAIL)))) (IL:* IL:\; "Go to new line and indent a bit.  Always do this for the part matching &BODY, whether or not the prettyprinter thought that the remainder would \"fit\"") (IL:PRINENDLINE IL:LEFT NIL T)) (T (IL:SPACES 1))) (IL:WHILE (AND (CONSP IL:TAIL) (ATOM (SETQ FORM (CAR IL:TAIL)))) IL:DO (IL:* IL:|;;| "Print this doc string or whatever on its own line.  This is because otherwise the prettyprinter gets confused and tries to put the next thing after the string") (PPRINT-DEFINER-RECURSE) (WHEN (AND (KEYWORDP FORM) (CONSP IL:TAIL)) (IL:* IL:\; "Some sort of keyword-value pair stuff--print it on same line") (IL:SPACES 1) (PPRINT-DEFINER-RECURSE)) (WHEN (NULL IL:TAIL) (RETURN)) (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*)) (IL:PRINTDEF IL:TAIL T T T IL:FNSLST)) (IL:PRIN1 ")") NIL))))
-
-(DEFUN PPRINT-DEFINER-FITP (ITEM) (IL:* IL:|;;| "True if it won't look silly to try to print ITEM at current position instead of starting new line") (IF (CONSP ITEM) (OR (EQ (CAR ITEM) IL:COMMENTFLG) (AND (< (IL:COUNT ITEM) 20) (IL:FITP ITEM))) (< (+ (IL:DSPXPOSITION) (IL:STRINGWIDTH ITEM *STANDARD-OUTPUT*)) (IL:DSPRIGHTMARGIN))))
-
-(DEFUN PPRINT-DEFINER-RECURSE NIL (IL:* IL:|;;| "Print and pop the next element.  Prettyprinter uses the variable IL:TAIL for lookahead") (DECLARE (SPECIAL IL:TAIL)) (IL:SUPERPRINT (CAR IL:TAIL) IL:TAIL NIL *STANDARD-OUTPUT*) (SETQ IL:TAIL (CDR IL:TAIL)))
-
-(DEFVAR IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :WARN) "Either NIL (don't) T (always do) or :WARN (don't and warn)")
-
-
-
-(IL:* IL:\; "Share with xcl?")

-
-
-(DEFUN %DEFINE-TYPE-DELDEF (NAME TYPE) (IL:* IL:|;;| "DELETE definition of definer-defined NAME as TYPE ") (UNDOABLY-SETF (DOCUMENTATION NAME TYPE) NIL) (LET* ((HT (GETHASH TYPE *DEFINITION-HASH-TABLE*)) (DEFN (AND HT (GETHASH NAME HT)))) (AND HT (IL:/PUTHASH NAME NIL HT)) (DOLIST (FN (OR (GET TYPE (QUOTE :UNDEFINERS)) (GET TYPE (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) (DOLIST (FN (OR (GET (CAR DEFN) (QUOTE :UNDEFINERS)) (GET (CAR DEFN) (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) NAME))
-
-(DEFUN %DEFINE-TYPE-GETDEF (NAME TYPE OPTIONS) (IL:* IL:|;;| "GETDEF method for all definers.  The EDIT is so that when you say EDITDEF you get a copy & can know when you made edits.") (LET* ((HASH-TABLE (GETHASH TYPE *DEFINITION-HASH-TABLE*)) (DEFN (AND HASH-TABLE (GETHASH NAME HASH-TABLE)))) (IF (TYPECASE OPTIONS (CONS (MEMBER (QUOTE IL:EDIT) OPTIONS :TEST (FUNCTION EQ))) (T (EQ OPTIONS (QUOTE IL:EDIT)))) (COPY-TREE DEFN) DEFN)))
-
-(DEFUN %DEFINE-TYPE-FILE-DEFINITIONS (TYPE NAMES) (IL:* IL:|;;| "get the definitions for NAMES suitable for printing on a file. Like GETDEF but checks.") (MAPCAR (FUNCTION (LAMBDA (NAME) (LET ((DEF (%DEFINE-TYPE-GETDEF NAME TYPE (QUOTE (IL:NOCOPY))))) (IF (NULL DEF) (ERROR (QUOTE IL:NO-SUCH-DEFINITION) :NAME NAME :TYPE TYPE) DEF)))) NAMES))
-
-(DEFUN %DEFINE-TYPE-FILEGETDEF (NAME TYPE SOURCE OPTIONS NOTFOUND) (LET ((VAL (IL:LOADFNS NIL SOURCE (QUOTE IL:GETDEF) (IL:* IL:|;;| "The bletcherous lambda form is require by the interface to loadfns (can't pass a closure)") (IL:BQUOTE (IL:LAMBDA (FIRST SECOND) (AND (MEMBER FIRST (QUOTE (IL:\\\, (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))))) :TEST (FUNCTION EQ)) (LET ((NAMER (OR (GET FIRST (QUOTE :DEFINITION-NAME)) (GET FIRST (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)))) (IF (EQ NAMER (QUOTE SECOND)) (EQUAL SECOND (QUOTE (IL:\\\, NAME))) (EQUAL (FUNCALL NAMER (REMOVE-COMMENTS (IL:READ))) (QUOTE (IL:\\\, NAME))))))))))) (COND ((EQ (CAAR VAL) (QUOTE IL:NOT-FOUND\:)) NOTFOUND) ((CDR VAL) (CONS (QUOTE PROGN) VAL)) (T (CAR VAL)))))
-
-(DEFUN %DEFINE-TYPE-SAVE-DEFN (NAME TYPE DEFINITION) (SETQ TYPE (IL:GETFILEPKGTYPE TYPE (QUOTE TYPE))) (LET ((HASH-TABLE (GETHASH TYPE *DEFINITION-HASH-TABLE*))) (WHEN (NULL HASH-TABLE) (WARN "Couldn't find a hash-table for ~S definitions.~%One will be created." TYPE) (SETQ HASH-TABLE (SETF (GETHASH TYPE *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL) :SIZE 50 :REHASH-SIZE 50)))) (LET ((OLD-DEFINITION (GETHASH NAME HASH-TABLE))) (UNLESS (EQUAL DEFINITION OLD-DEFINITION) (WHEN (AND OLD-DEFINITION (NOT (EQ IL:DFNFLG T))) (FORMAT *TERMINAL-IO* "~&New ~A definition for ~S~:[~; (but not installed)~].~%" TYPE NAME (MEMBER IL:DFNFLG (QUOTE (IL:PROP IL:ALLPROP)) :TEST (FUNCTION EQ)))) (IL:/PUTHASH NAME DEFINITION HASH-TABLE) (IL:MARKASCHANGED NAME TYPE (IF OLD-DEFINITION (QUOTE IL:CHANGED) (QUOTE IL:DEFINED)))))))
-
-(DEFUN %DEFINE-TYPE-PUTDEF (NAME TYPE DEFINITION REASON) (IF (NULL DEFINITION) (%DEFINE-TYPE-DELDEF NAME TYPE) (LET ((DEFN-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION))) (UNLESS (AND (CONSP DEFN-WITHOUT-COMMENTS) (MEMBER (CAR DEFN-WITHOUT-COMMENTS) (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))) :TEST (FUNCTION EQ)) (EQUAL NAME (FUNCALL (OR (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE :DEFINITION-NAME)) (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)) DEFN-WITHOUT-COMMENTS))) (SIGNAL (QUOTE IL:DEFINER-MISMATCH) :NAME NAME :TYPE TYPE :DEFINITION DEFINITION)) (SETQ DEFINITION (COPY-TREE DEFINITION)) (EVAL (IF IL:LISPXHIST (MAKE-UNDOABLE DEFINITION) DEFINITION)))))
-
-
-
-(IL:* IL:\; "Compatibility with old cmldeffer")

-
-(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
-
-(IL:MOVD (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF))
-
-(IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF))
-
-(IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS))
-
-(IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF))
-
-(IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN))
-
-(IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF))
-
-(IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER))
-)
-(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
-
-(IL:* IL:|;;| "Set up fake definer prototype stuff for FNS")
-
-(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))))))
-
-(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))))))
-)
-
-
-
-(IL:* IL:\; "The groundwork for bootstrapping ")

-
-
-(DEF-DEFINE-TYPE IL:DEFINE-TYPES "Definition type")
-
-(DEF-DEFINE-TYPE IL:FUNCTIONS "Common Lisp functions/macros" :UNDEFINER IL:UNDOABLY-FMAKUNBOUND)
-
-(DEF-DEFINE-TYPE IL:VARIABLES "Common Lisp variables" :UNDEFINER UNDOABLY-MAKUNBOUND)
-
-
-
-(IL:* IL:\; "DefDefiner itself and friends")

-
-
-(DEFUN SI::EXPANSION-FUNCTION (NAME ARG-LIST BODY) (IL:* IL:|;;;| "Shared code between DEFMACRO and DEFDEFINER.  Takes the parts of a DEFMACRO and returns two values: a LAMBDA form for the expansion function, and the documentation string found, if any.") (MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING) (IL:PARSE-DEFMACRO ARG-LIST (QUOTE SI::$$MACRO-FORM) BODY NAME NIL :ENVIRONMENT (QUOTE SI::$$MACRO-ENVIRONMENT)) (VALUES (IL:BQUOTE (LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT) (IL:\\\,@ PARSED-DECLARATIONS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY)))) PARSED-DOCSTRING)))
-
-(DEFMACRO SI::MACRO-FUNCALL (EXPANSION-FUNCTION MACRO-CALL ENV) (IL:* IL:|;;;| "Used by DEFDEFINER as a mechanism for delaying macro-expansion until after checking the value of DFNFLG.  The arguments (unevaluated) are a macro-expansion function and a call on that macro.  The call to MACRO-FUNCALL should expand into the result of expanding the given macro-call.") (FUNCALL EXPANSION-FUNCTION MACRO-CALL ENV))
-
-(DEFMACRO WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (IL:\\\,@ BODY)) (EVAL-WHEN (EVAL) (UNLESS (OR (EQ IL:DFNFLG (QUOTE IL:PROP)) (EQ IL:DFNFLG (QUOTE IL:ALLPROP))) (LET ((IL:FILEPKGFLG NIL) (IL:DFNFLG T)) (IL:\\\,@ BODY)))))))
-
-
-
-(IL:* IL:\; "Compatibility with old cmldeffer")

-
-
-(DEFMACRO IL:WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (WITHOUT-FILEPKG (IL:\\\,@ BODY))))
-
-
-
-(IL:* IL:\; "Some special forms")

-
-
-(DEFMACRO DEFINER (TYPE NAME DEFINITION &OPTIONAL ENV) (LET* ((EXPANDER (GET NAME :DEFINITION-EXPANDER)) (DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME))))))
-
-(DEFMACRO DEFINER-VARIABLE-TYPE (NAME DEFINITION &OPTIONAL ENV) (LET* ((DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (TYPE (FUNCALL (GET NAME :TYPE-DISCRIMINATOR) DEFINITION-WITHOUT-COMMENTS)) (EXPANDER (GETF (GET NAME :DEFINITION-EXPANDER) TYPE)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME))))))
-
-(DEFMACRO NAMED-PROGN (DEFINER NAME &REST FORMS) (IL:* IL:|;;| "Used by the compiler when processing definers") (IL:BQUOTE (PROGN (IL:\\\,@ FORMS) (QUOTE (IL:\\\, NAME)))))
-
-
-
-(IL:* IL:\; "Auxiliary functions")

-
-
-(DEFUN GET-DEFINER-NAME (DEFINER STRING) (VALUES (INTERN (CONCATENATE (QUOTE STRING) STRING (STRING DEFINER)) (SYMBOL-PACKAGE DEFINER))))
-
-(DEFUN %DELETE-DEFINER (NAME) (AND (SYMBOLP NAME) (LET ((TYPE (OR (GET NAME (QUOTE :DEFINER-FOR)) (GET NAME (QUOTE IL:DEFINER-FOR))))) (IL:/REMPROP NAME (QUOTE :DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE IL:DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE :DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE IL:DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE :DEFINITION-EXPANDER)) (WHEN TYPE (IF (GET TYPE (QUOTE :DEFINED-BY)) (IL:/PUTPROP TYPE (QUOTE :DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE :DEFINED-BY)))) (IL:/PUTPROP TYPE (QUOTE IL:DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE IL:DEFINED-BY))))) (IL:* IL:|;;| "need to remove the prototype function!") (LET* ((LOOKUP-TYPE (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST (FUNCTION EQ)))) (IL:/RPLACD LOOKUP-TYPE (REMOVE NAME (CDR LOOKUP-TYPE) :KEY (FUNCTION CAR))))))))
-
-(DEFDEFINER (DEF-DEFINE-TYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEF-DEFINE-TYPE (IL:\\\, NAME) "Description string")))))) IL:DEFINE-TYPES (NAME DESCRIPTION &KEY UNDEFINER &AUX (CHANGELST (INTERN (CONCATENATE (QUOTE STRING) "CHANGED" (STRING NAME) "LST") (SYMBOL-PACKAGE NAME)))) "Define NAME as a new definition type" (IL:* IL:|;;| "This definition is a clean interface to a hokey implementation.  It works even before the file package is loaded.") (IL:BQUOTE (PROGN (SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE IL:DEFINE-TYPES)) (QUOTE (IL:\\\, DESCRIPTION))) (PUSHNEW (QUOTE ((IL:\\\, NAME) X (IL:P IL:* (%DEFINE-TYPE-FILE-DEFINITIONS (QUOTE (IL:\\\, NAME)) (QUOTE X))))) IL:PRETTYDEFMACROS :TEST (QUOTE EQUAL)) (IL:* IL:|;;| "the information about a type in the file package is split up into a number of different places. PRETTYTYPELST contains a random amount: the changelist is the variable whose top level value contains the list of changed items, and the description is a string used by files? This is duplicated in the CL:DOCUMENTATION mechanism") (PUSHNEW (QUOTE ((IL:\\\, CHANGELST) (IL:\\\, NAME) (IL:\\\, DESCRIPTION))) IL:PRETTYTYPELST :TEST (QUOTE EQUAL)) (DEFGLOBALVAR (IL:\\\, CHANGELST) NIL) (IL:* IL:|;;| "the definition hash table is where the definitions are really stored. Create an entry for this type. Note that definitions are compared using CL:EQUAL so that names can be strings, lists, etc.") (UNLESS (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (QUOTE EQUAL) :SIZE 50 :REHASH-SIZE 50))) (PUSHNEW (QUOTE (IL:\\\, NAME)) IL:FILEPKGTYPES) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:GETDEF)) (QUOTE %DEFINE-TYPE-GETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:DELDEF)) (QUOTE %DEFINE-TYPE-DELDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:PUTDEF)) (QUOTE %DEFINE-TYPE-PUTDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEGETDEF)) (QUOTE %DEFINE-TYPE-FILEGETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEPKGCONTENTS)) (QUOTE IL:NILL)) (IL:\\\,@ (WHEN UNDEFINER (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, UNDEFINER)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS))))))))))
-
-(DEFDEFINER (DEFDEFINER (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (QUOTE IL:SEDIT)) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPE ARG-LIST &BODY BODY) (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINER NIL) (PROTOTYPE-FN NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINER) (SETQ UNDEFINER (CADR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPE) (SETQ PROTOTYPE-FN (CADR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST BODY) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &BODY) ARG-LIST))) (IL:* IL:\; "Tell default prettyprinter where the body is") (SETQ TEMPLATE (NCONC (IL:FOR X IL:IN ARG-LIST IL:UNTIL (EQ X (QUOTE &BODY)) IL:UNLESS (MEMBER X LAMBDA-LIST-KEYWORDS) IL:COLLECT NIL) (LIST :BODY))) (WHEN (AND (NULL (CAR TEMPLATE)) (NULL NAME-FN)) (IL:* IL:\; "Name is in default place") (SETF (CAR TEMPLATE) :NAME))) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME "definition-expander-")) (NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-")))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPE))) (PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (AND UNDEFINER (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME "undefiner-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, UNDEFINER))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)))))))) (IL:\\\,@ (AND PROTOTYPE-FN (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME "prototype-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, PROTOTYPE-FN))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER (IL:\\\, (QUOTE (IL:\\\, TYPE))) (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV))))))))))
-
-(DEFDEFINER (DEFDEFINER-VARIABLE-TYPE (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER-VARIABLE-TYPE (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (INTERN "SEDIT" "SEDIT")) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPES ARG-LIST &BODY BODY) (IL:* IL:|;;| "An extension to the DEFDEFINER universe, this allows the creation of definers that map to multiple file-package types.  The test case, and the only case guaranteed to work, is DEFUN (which now must accept (DEFUN (SETF FOO)...), which needs to be stored as a SETFS file type).") (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINERS NIL) (PROTOTYPE-FNS NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (TYPE-DISCRIMINATOR NIL) (EXPANSION-FNS NIL) (DOCS NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINERS) (SETQ UNDEFINERS (CDR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPES) (SETQ PROTOTYPE-FNS (CDR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:TYPE-DISCRIMINATOR) (SETQ TYPE-DISCRIMINATOR (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (UNLESS TYPE-DISCRIMINATOR (ERROR "DEFDEFINER-VARIABLE-TYPE must have a TYPE-DISCRIMINATOR")) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (DOLIST (TYPE TYPES) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST (LET ((TB (GETF BODY TYPE))) (IF TB (LIST TB) (ERROR "No expansion-function for ~A" TYPE)))) (SETF (GETF EXPANSION-FNS TYPE) EXPANSION-FN) (WHEN DOC (SETQ DOCS (CONCATENATE (QUOTE STRING) DOCS (OR DOCS "
-") (SYMBOL-NAME TYPE) ": " DOC))))) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &BODY) ARG-LIST))) (IL:* IL:\; "Tell default prettyprinter where the body is") (SETQ TEMPLATE (NCONC (IL:FOR X IL:IN ARG-LIST IL:UNTIL (EQ X (QUOTE &BODY)) IL:UNLESS (MEMBER X LAMBDA-LIST-KEYWORDS) IL:COLLECT NIL) (LIST :BODY))) (WHEN (AND (NULL (CAR TEMPLATE)) (NULL NAME-FN)) (IL:* IL:\; "Name is in default place") (SETF (CAR TEMPLATE) :NAME))) (LET ((NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-"))) (TYPE-DISCRIMINATOR-NAME (GET-DEFINER-NAME NAME "type-discriminator-fn-"))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPES))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (FUNCTION (IL:\\\, TYPE-DISCRIMINATOR))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :TYPE-DISCRIMINATOR)) (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (IL:\\\,@ (AND PROTOTYPE-FNS (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-prototype-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, (GETF PROTOTYPE-FNS TYPE)))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) TYPES))) (IL:\\\,@ (AND DOCS (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCS)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-definition-expander-"))) (EXPANSION-FN (GETF EXPANSION-FNS TYPE))) (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, TYPE))) (QUOTE (IL:\\\, EXPANDER-NAME)))))))) TYPES)) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (IL:\\\,@ (AND UNDEFINERS (MAPCAN (FUNCTION (LAMBDA (TYPE) (WHEN (GETF UNDEFINERS TYPE) (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-undefiner-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, (GETF UNDEFINERS TYPE)))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)) (QUOTE (IL:\\\, TYPE)))))))))) TYPES))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER-VARIABLE-TYPE (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV)))))))))
-
-(DEFUN %EXPAND-DEFINER (DEFINER DEFINITION-WITHOUT-COMMENTS &OPTIONAL ENV) (FUNCALL (GET DEFINER :DEFINITION-EXPANDER) DEFINITION-WITHOUT-COMMENTS ENV))
-
-(DEFUN %DEFINER-NAME (DEFINER DEFINITION-WITHOUT-COMMENTS) (FUNCALL (GET DEFINER :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))
-
-
-
-(IL:* IL:\; "The most commonly-used definers")

-
-
-(DEFDEFINER-VARIABLE-TYPE (DEFUN (:TYPE-DISCRIMINATOR (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) (QUOTE IL:FUNCTIONS)) ((CL::SETF-NAME-P NAME) (QUOTE IL:SETFS)) (T (ERROR "Can't determine type for DEFUN: ~s" NAME)))))) (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) NAME) ((CL::SETF-NAME-P NAME) (CADR NAME)) (T (ERROR "Bad function-name for DEFUN: ~s" NAME)))))) (:PROTOTYPES IL:FUNCTIONS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))) IL:SETFS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (SETF (IL:\\\, NAME)) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))) (:TEMPLATE (:NAME :ARG-LIST :BODY)) (:EDITDATE-OFFSET 3)) (IL:FUNCTIONS IL:SETFS) (NAME ARGS &BODY (BODY DECLS DOCUMENTATION) &ENVIRONMENT ENV) IL:FUNCTIONS (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ BODY))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCUMENTATION)))))))) IL:SETFS (IL:* IL:|;;| "The form is (defun (setf foo) (store-var &rest args) body)") (IL:* IL:|;;| "Strategy is to give the code a name with DEFUN-SETF-NAME.  The name is stored on the :SETF-DEFUN property of the accessor.  This name is there for convenience/documentation only; the name can't be reliably changed by smashing this property (i.e. (SETF (FDEFINITION '(SETF FOO)) #'BAR) essentially does (SETF (SYMBOL-FUNCTION (DEFUN-SETF-NAME 'FOO)) #'BAR); it does NOT change the :SETF-DEFUN property on FOO).") (LET* ((REAL-NAME (SECOND NAME)) (DEFUN-SETF-NAME (DEFUN-SETF-NAME REAL-NAME))) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, REAL-NAME) (IL:\\\,@ BODY))))) (SET-DEFUN-SETF (QUOTE (IL:\\\, REAL-NAME)) (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, REAL-NAME)) (QUOTE SETF)) (IL:\\\, DOCUMENTATION))))))))))
-
-(DEFDEFINER (DEFINLINE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINLINE (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:FUNCTIONS (NAME ARG-LIST &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is an INTERIM version of DEFINLINE.  Eventually, this will just turn into a DEFUN and a PROCLAIM INLINE.  (It says so right here.)  If you're using this one, DO NOT make any recursive calls in the body of the DEFINLINE.  If you do, the compiler will run forever trying to expand the optimizer...  Once the INLINE version gets working (in the PavCompiler only) that restriction will be lifted.") (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (PARSE-BODY BODY ENV T) (LET ((NEW-LAMBDA (IL:BQUOTE ((IL:\\\, (QUOTE LAMBDA)) (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ CODE)))))) (IL:BQUOTE (PROGN (DEFUN (IL:\\\, NAME) (IL:\\\, ARG-LIST) (IL:\\\,@ BODY)) (DEFOPTIMIZER (IL:\\\, NAME) (IL:\\\, (PACK (LIST "definline-" NAME) (SYMBOL-PACKAGE NAME))) (&REST ARGS) (CONS (QUOTE (IL:\\\, NEW-LAMBDA)) ARGS)))))))
-
-(DEFDEFINER (DEFMACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER (LAMBDA (NAME) (REMPROP NAME (QUOTE IL:ARGNAMES)))) (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:FUNCTIONS (NAME DEFMACRO-ARGS &BODY DEFMACRO-BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFMACRO: ~S" NAME)) (LET ((CMACRONAME (PACK (LIST "expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC-STRING) (SI::EXPANSION-FUNCTION NAME DEFMACRO-ARGS DEFMACRO-BODY) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, CMACRONAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (MACRO-FUNCTION (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, CMACRONAME))) (IL:\\\,@ (AND DOC-STRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC-STRING)))))) (IL:\\\,@ (WHEN COMPILER::*NEW-COMPILER-IS-EXPANDING* (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:ARGNAMES)) (QUOTE (IL:\\\, (MAPCAR (FUNCTION (LAMBDA (ARG) (IF (MEMBER ARG LAMBDA-LIST-KEYWORDS) ARG (PRIN1-TO-STRING ARG)))) (IL:\\SIMPLIFY.CL.ARGLIST DEFMACRO-ARGS))))))))))))))
-
-(DEFDEFINER (DEFVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
-
-(DEFDEFINER (DEFPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
-
-(DEFDEFINER (DEFCONSTANT (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFCONSTANT (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (IL:\\\,@ (IF (CONSTANTP NAME) (IL:BQUOTE ((SET-CONSTANTP (QUOTE (IL:\\\, NAME)) NIL))))) (SETQ (IL:\\\, NAME) (IL:\\\, VALUE)) (PROCLAIM (QUOTE (SI::CONSTANT (IL:\\\, NAME)))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
-
-(DEFDEFINER (DEFGLOBALVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:* IL:|;;| "Use IL:SETQ here or the INIT dies.") (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
-
-(DEFDEFINER (DEFGLOBALPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
-
-
-
-(IL:* IL:\; "Here so that the evaluator can be in the init without definers being in the init.")

-
-
-(DEF-DEFINE-TYPE IL:SPECIAL-FORMS "Common Lisp special forms" :UNDEFINER %REMOVE-SPECIAL-FORM)
-
-(DEFUN %REMOVE-SPECIAL-FORM (X) (IL:/REMPROP X (QUOTE IL:SPECIAL-FORM)))
-
-(DEFDEFINER (DEFINE-SPECIAL-FORM (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:SPECIAL-FORMS (NAME ARGS &REST BODY) (COND ((NULL BODY) (ASSERT (SYMBOLP NAME) NIL "Ill-formed short DEFINE-SPECIAL-FORM; ~S is not a symbol." ARGS) (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, ARGS))))) (T (LET ((SF (INTERN (CONCATENATE (QUOTE STRING) "interpret-" (STRING NAME)) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOC) (IL:PARSE-DEFMACRO ARGS (QUOTE $$TAIL) BODY NAME NIL :PATH (QUOTE $$TAIL) :ENVIRONMENT (QUOTE $$ENV)) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, SF))) (FUNCTION (LAMBDA ($$TAIL $$ENV) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, SF))))))))))
-
-
-
-(IL:* IL:\; "Form for defining interpreters of special forms")

-
-
-
-
-(IL:* IL:\; "Don't note changes to these properties/variables")

-
-
-(IL:PUTPROPS IL:MACRO-FN IL:PROPTYPE IL:FUNCTIONS)
-
-(IL:PUTPROPS :UNDEFINERS IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS IL:UNDEFINERS IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS :DEFINER-FOR IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS IL:DEFINER-FOR IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS :DEFINED-BY IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS IL:DEFINED-BY IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS :DEFINITION-NAME IL:PROPTYPE IGNORE)
-
-(IL:PUTPROPS IL:DEFINITION-NAME IL:PROPTYPE IGNORE)
-
-
-
-(IL:* IL:\; 
-"Templates for definers not defined here.  These should really be where they're defined.")

-
-
-(IL:PUTPROPS DEFCOMMAND :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY))
-
-(IL:PUTPROPS DEFINE-CONDITION :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE :BODY))
-
-(IL:PUTPROPS DEFINE-MODIFY-MACRO :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST))
-
-(IL:PUTPROPS DEFINE-SETF-METHOD :DEFINITION-PRINT-TEMPLATE (:NAME NIL NIL :BODY))
-
-(IL:PUTPROPS DEFSETF :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :ARG-LIST :BODY))
-
-(IL:PUTPROPS DEFSTRUCT :DEFINITION-PRINT-TEMPLATE (:NAME :BODY))
-
-(IL:PUTPROPS DEFTYPE :DEFINITION-PRINT-TEMPLATE (:NAME NIL :BODY))
-
-
-
-(IL:* IL:|;;| "Arrange for the correct compiler to be used.")

-
-
-(IL:PUTPROPS IL:CMLDEFFER IL:FILETYPE :COMPILE-FILE)
-
-(IL:PUTPROPS IL:CMLDEFFER IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
-(IL:PUTPROPS IL:CMLDEFFER IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1900 1987 1988 1990 1992))
-(IL:DECLARE\: IL:DONTCOPY
-  (IL:FILEMAP (NIL)))
-IL:STOP

Dockerfile

@@ -1,24 +1,25 @@
 FROM ubuntu:focal
-ENV DEBIAN_FRONTEND=noninteractive
+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
+ENV BUILD_DATE=$build_date
+ENV MEDLEY_RELEASE=$medley_release
+ENV MAIKO_RELEASE=$maiko_release
 
-RUN apt-get update && apt-get install -y build-essential clang libx11-dev
-COPY maiko /build/
-WORKDIR /build/bin
-RUN rm -rf /build/linux*
-RUN ./makeright x
-
-
-FROM ubuntu:focal
-ENV DEBIAN_FRONTEND=noninteractive
+RUN apt-get update && apt-get install -y tightvncserver
 
 EXPOSE 5900
 
-RUN apt-get update && apt-get install -y tightvncserver
-RUN mkdir /app
-WORKDIR /app
-COPY basics ./
-COPY --from=0 /build/linux.x86_64/* ./
+# Copy and uncompress loadup and required source files.
+ADD *.tgz /home
+
+WORKDIR /home/medley
 
 RUN adduser --disabled-password --gecos "" medley
 USER medley
-ENTRYPOINT USER=medley Xvnc -geometry 1270x720 :0 & DISPLAY=:0 /app/ldex -g 1280x720 full.sysout
+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 [Documentation links](https://github.com/Interlisp/medley/wiki/Documentation) for an overview and pointers to documentation.
+In particular [Running](https://github.com/Interlisp/medley/wiki/Running) explains other methods of getting Medley Interlisp.
 
-See [Medley Interlisp Wiki](https://github.com/Interlisp/medley/wiki/) for an overview, and other pointers.
+[Interlisp/maiko](https://github.com/Interlisp/maiko), is the repo for 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.
 
-## Instructions for Building and Running
+### Getting releases
+
+Get the Maiko release [here](https://github.com/Interlisp/maiko/releases). You'll need the .tgz file 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, but you'll still need the "loadups" release.
+
+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) below 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
+