Format implementation functions set a known variable *BYTECOUNTER* (#402)

* Format implementation functions set a known variable *BYTECOUNTER*

The generic functions deal with updating the application variable.
\INCHAR eliminated in favor of \INCCODE.EOLC to make clear what it does.
OPENSTRINGSTREAM streams have their own format, and the string is always fattened.
READBITMAP doesn't mix character and byte reading

* AOFD: Don't execute \STRINGSTREAM.INIT

This creates a file device that is not used anywhere.  The function OPENSTRINGSTREAM provides the functionality that this file device suggests that it would provide, but that functionality seems suspect at best.  The function is left in the system for now, probably should be deleted at some point in the future so we don't try to maintain it if we trip over it.

* TTYIN:  Fix an ancient coding error

but still doesn't solve the  (DIRECTORY ?=  problem #402

* LLREAD, FILEIO, XCCS:  Improve charcode backing, copychars

Added \BACKCCODE.EOLC that backs up over EOL encoding bytes, simplifies \RSTRING2.
\XCCSBACKCCODE returns T/NIL according to whether it succeeded.
\XCCSOUTCHAR uses IPLUS16 for CHARPOSITION
COPYCHARS makes no assumptions about EOL encoding
But still no solution for #402

* LLREAD, TTYIN.LCOM    fix #402

The bug showed up in TTYIN, but it was actually a bad edit in the generic backccode.

TTYIN.LCOM is just a recompile--that had never been done with various new declarations.

.github/workflows/build.yml

@@ -0,0 +1,82 @@
+#  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 }}

.gitignore

@@ -27,3 +27,4 @@ core
 
 # set up by install-diff-filter.sh script
 .gitattributes
+sources/LLREAD.LCOM.~1~

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,19 @@
-FROM ubuntu:focal
-ENV DEBIAN_FRONTEND=noninteractive
+FROM interlisp/maiko:latest
+ARG BUILD_DATE
+LABEL name="Medley"
+LABEL description="The Medley Interlisp environment"
+LABEL url="https://github.com/Interlisp/medley"
+LABEL build-time=$BUILD_DATE
 
-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/* ./
+# Need to refine this down to only needed directories.
+COPY . /app/medley
+
+WORKDIR /app/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

greetfiles/LOCAL-INIT.~32~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "22-Jun-2017 22:48:46" {DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;32
 9225   
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "15-Jun-2017 22:06:37" 
-{DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;31)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
-                  \CURRENTKEYACTION)
-           (KEYACTION 'BLANK-TOP '(METADOWN . METAUP))
-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers")
-                                          (CONCAT MEDLEYDIR "/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources")))
-              (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASLs)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              (DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/displayfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
-                                           (SETQ USERNAME (UNIX-GETENV "USER")))
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-
-(* ;; "Local (Mac)  system greeting file")

-
-(DEFINEQ

greetfiles/LOCAL-INIT.~36~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED " 2-Jul-2017 17:13:31" {DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;36
 9762   
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "26-Jun-2017 13:36:35" 
-{DSK}<Volumes>Personal>local>medley3.5>current>LOCAL-INIT.;35)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
-        (P (FIXMETA))
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispusers")
-                                          (CONCAT MEDLEYDIR "/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/sources")))
-              (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASLs)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
-                                           (SETQ USERNAME (UNIX-GETENV "USER")))
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-
-(* ;; "Local (Mac)  system greeting file")

-

greetfiles/LOCAL-INIT.~39~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED " 4-Apr-2018 11:06:31" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;39
 10035  
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "27-Mar-2018 07:18:26" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;38
-)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
-        (P (FIXMETA))
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
-                                          (CONCAT MEDLEYDIR "/lispcore/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
-              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
-                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASLs)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
-                                           (SETQ USERNAME (UNIX-GETENV "USER")))
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-
-(* ;; "Local (Mac)  system greeting file")

greetfiles/LOCAL-INIT.~41~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "26-Apr-2018 13:24:14" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;41
 10332  
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "23-Apr-2018 22:12:02" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;40
-)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES FIXMETA)
-        (P (FIXMETA))
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
-                                          (CONCAT MEDLEYDIR "/lispcore/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
-              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
-                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASLs)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
-                                                             (* ; 
-
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")

-                                           )
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-

greetfiles/LOCAL-INIT.~42~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "22-Dec-2018 17:13:47" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;42
 10043  
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "26-Apr-2018 13:24:14" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;41
-)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
-                                          (CONCAT MEDLEYDIR "/lispcore/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
-              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
-                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASLs)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
-                                                             (* ; 
-
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")

-                                           )
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-

greetfiles/LOCAL-INIT.~43~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "22-Dec-2018 17:13:47" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;42
 10043  
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "26-Apr-2018 13:24:14" {DSK}<Users>kaplan>Local>medley3.5>current>LOCAL-INIT.;41
-)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
-                                          (CONCAT MEDLEYDIR "/lispcore/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
-              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
-                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASLs)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (LOCAL-INIT)
-                                                             (* ; 
-
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")

-                                           )
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-

greetfiles/LOCAL-INIT.~44~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "19-Oct-2020 15:15:23" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>current>LOCAL-INIT.;44
 10136  
-
-      changes to%:  (VARS LOCAL-INITCOMS)
-
-      previous date%: "22-Dec-2018 17:13:47" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>current>LOCAL-INIT.;43)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
-                                          (CONCAT MEDLEYDIR "/lispcore/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
-              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
-                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASL)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
-               (P (LOCAL-INIT)
-                                                             (* ; 
-
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")

-                  )
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-

greetfiles/LOCAL-INIT.~45~

@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
(FILECREATED "19-Oct-2020 15:19:00" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>greetfiles>LOCAL-INIT.;45
 10099  
-
-      previous date%: "19-Oct-2020 15:15:23" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>greetfiles>LOCAL-INIT.;44)
-
-
-(PRETTYCOMPRINT LOCAL-INITCOMS)
-
-(RPAQQ LOCAL-INITCOMS

-       [
-        (* ;; "Local (Mac)  system greeting file")

-
-        (FNS INTERLISPMODE)
-        (VARS (COMPILEIGNOREDECL T)
-              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
-              (SITE 'LOCAL-MAC))
-        (P (BKSYSBUF " ")
-                                                             (* ; 
-
                                                       "So tty window doesn't hang during greeting")

-           (INTERLISPMODE)
-           (DEFCOMMAND ("show" :QUIET)
-                  (&REST EVENTSPEC)
-                  (CL:PPRINT (VALUOF EVENTSPEC T)
-                         T)))
-        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
-        (FUNCTIONS WITHOUT.PAGEHOLD)
-        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
-                                          (CONCAT MEDLEYDIR "/lispcore/library")))
-              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
-              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
-                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
-              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
-        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
-                                ({DSK}/Users/ USER /Lisp/INIT.DFASL)
-                                ({DSK}/Users/ USER /Lisp/INIT]
-        [VARS (*USEOLDFONTDIRECTORIES* NIL)
-              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
-                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
-              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
-              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
-               (P (LOCAL-INIT)
-                                                             (* ; 
-
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")

-                  )
-                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")

-               )
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-

greetfiles/SIMPLE-INIT

@@ -1 +1,65 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED " 6-Feb-2021 16:44:35" {DSK}<home>larry>ilisp>medley>greetfiles>SIMPLE-INIT.;4
 2208   
+
+      changes to%:  (VARS SIMPLE-INITCOMS)
+
+      previous date%: " 5-Feb-2021 12:57:29" {DSK}<home>larry>ilisp>medley>greetfiles>SIMPLE-INIT.;3
+)
+
+
+(PRETTYCOMPRINT SIMPLE-INITCOMS)
+
+(RPAQQ SIMPLE-INITCOMS

+       (
+
+(* ;;; " Previous content moved into SYNCLISPFILES ")

+
+        (VARS (FILING.ENUMERATION.DEPTH 1)
+              [LOGINDIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
+                                           (UNIX-GETENV "HOME"]
+              [USERGREETFILES `((,LOGINDIR "INIT" COM)
+                                (,LOGINDIR "INIT"]
+              (COPYRIGHTSRESERVED NIL))
+        [P (SETQ MEDLEYDIR NIL)
+           (MEDLEY-INIT-VARS)
+           (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
+        (FNS INTERLISPMODE)))
+
+
+
+(* ;;; " Previous content moved into SYNCLISPFILES ")

+
+
+(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)
+
+(SETQ MEDLEYDIR NIL)
+
+(MEDLEY-INIT-VARS)
+
+(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE))
+(DEFINEQ
+
+(INTERLISPMODE

+  [LAMBDA (OLD?)                                             (* N.H.Briggs " 2-Feb-88 14:26")

+    (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if
 OLD?
+                                                      then
 "OLD-INTERLISP-T"
+                                                    else
 "INTERLISP")))
+    (XCL:SET-DEFAULT-EXEC-TYPE (if
 OLD?
+                                   then
 "OLD-INTERLISP-T"
+                                 else
 "INTERLISP"))
+    (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if
 OLD?
+                                                              then
 "OLD-INTERLISP-FILE"
+                                                            else
 "INTERLISP")
+                                               :PACKAGE "INTERLISP"])
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1360 2185 (INTERLISPMODE 1370 . 2183)))))
+STOP

greetfiles/SIMPLE-INIT.~2~

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

internal/library/ABC

@@ -1 +1,62 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Mar-88 16:09:05" {ERIS}<LISPCORE>INTERNAL>LIBRARY>ABC.;4
 2101   
+
+      changes to%:  (VARS ABCCOMS)
+
+      previous date%: "29-Jul-87 12:04:16" {ERIS}<LISPCORE>INTERNAL>LIBRARY>ABC.;3)
+
+
+(* "
+Copyright (c) 1986, 1987, 1988 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT ABCCOMS)
+
+(RPAQQ ABCCOMS
 ((VARS (MSRECORDTRANFLG T)
+                          (DWIMIFYCOMPFLG)
+                          (MSMACROPROPS COMPILERMACROPROPS)
+                          (CLEANUPOPTIONS '(RC F))
+                          (CROSSCOMPILING T)
+                          (ASKEDITHIST T)
+                          (RECOMPILEDEFAULT 'CHANGES)
+                          (CROSSCOMPILING 'ASK))
+                    (FILES (SOURCE)
+                           FILESETS)
+                    (P (MOVD? 'APPLY* 'SPREADAPPLY*)
+                       [RESETVARS ((CROSSCOMPILING T))
+                              (FILESLOAD EXPORTS.ALL)
+                              (AND (EQ (ASKUSER DWIMWAIT 'N "Check imports? " NIL T)
+                                       'Y)
+                                   (ERSETQ (CHECKIMPORTS EXPORTFILES T]
+                       (PRIN1 
+             "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" 
+                              T))))
+
+(RPAQQ MSRECORDTRANFLG
 T)
+
+(RPAQQ DWIMIFYCOMPFLG
 NIL)
+
+(RPAQ MSMACROPROPS
 COMPILERMACROPROPS)
+
+(RPAQQ CLEANUPOPTIONS
 (RC F))
+
+(RPAQQ CROSSCOMPILING
 T)
+
+(RPAQQ ASKEDITHIST
 T)
+
+(RPAQQ RECOMPILEDEFAULT
 CHANGES)
+
+(RPAQQ CROSSCOMPILING
 ASK)
+(FILESLOAD (SOURCE)
+       FILESETS)
+(MOVD? 'APPLY* 'SPREADAPPLY*)
+[RESETVARS ((CROSSCOMPILING T))
+       (FILESLOAD EXPORTS.ALL)
+       (AND (EQ (ASKUSER DWIMWAIT 'N "Check imports? " NIL T)
+                'Y)
+            (ERSETQ (CHECKIMPORTS EXPORTFILES T]
+(PRIN1 "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" T)
+(PUTPROPS ABC COPYRIGHT ("Xerox Corporation" 1986 1987 1988))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

internal/library/CALENDARHACKS

@@ -41,11 +41,34 @@
 
 (DEFINEQ
 
-(PRINT-LAND-MONTH

+(PRINT-LAND-MONTH

+  (LAMBDA (MONTH YEAR STREAM)
                                (* \; "Edited 17-Oct-87 17:45 by jds")

+          
+          (* |;;| "Print a single month's calendar landscape on letter paper.")

 
-          
+    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T)))))
+         (PRINT-SCALED-MONTH
 MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6)
+         (CLOSEF PRINTSTREAM))))
 
-
+(PRINT-LAND-YEAR

+  (LAMBDA (YEAR STREAM)
                                      (* \; "Edited 17-Oct-87 17:49 by jds")

+          
+          (* |;;| "Print a single month's calendar landscape on letter paper.")

+
+    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T)))))
+         (|for|
 MONTH |from|
 1 |to|
 12
+            |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6)
+                 (DSPNEWPAGE PRINTSTREAM))
+         (CLOSEF PRINTSTREAM))))
+
+(PRINT-NOTEBOOK-MONTH

+  (LAMBDA (MONTH YEAR STREAM)
                                (* \; "Edited 17-Sep-87 21:55 by jds")

+          
+          (* |;;| "Print a single month's calendar on a half-sheet, suitable for punching and putting in a Time-Design notebook or a 5 1/2 x 8 1/2\" reminder book.")

+          
+          (* |;;| "If you leave STREAM NIL, you'll get one page on the printer.")

+
+    (PRINT-SCALED-MONTH
 MONTH YEAR 0 0 0.75 0.6 STREAM)))
 
 (PRINT-NOTEBOOK-YEAR

   (LAMBDA (YEAR STREAM)
                       (* \; "Edited 23-Mar-94 17:22 by turpiN:mv:envos")

@@ -78,7 +101,10 @@
             |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 50627 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
          (CLOSEF PRINTSTREAM))))
 
-                                                                      ((EVENP MONTH 2)
+(PRINT-NARROW-MONTH

+  (LAMBDA (MONTH YEAR STREAM)
                                (* \; "Edited 17-Sep-87 22:32 by jds")

+
+    (PRINT-SCALED-MONTH
 MONTH YEAR 0 0 0.45 0.95 STREAM NIL NIL NIL '(LANDSCAPE T))))
 )
 
 

internal/library/CALENDARHACKS.~3~

@@ -1,222 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-
(FILECREATED "23-Mar-94 17:45:59" |{DSK}<king>export>lispcore>internal>library>CALENDARHACKS.;3|
 11258  
-
-      |changes| |to:|  (FNS PRINTMONTHIMAGE PRINT-NOTEBOOK-YEAR PRINT-SUMMARY-YEAR PRINT-SCALED-MONTH
-                            )
-
-      |previous| |date:| "15-Jun-90 11:46:01" 
-|{DSK}<king>export>lispcore>internal>library>CALENDARHACKS.;1|)
-
-
-; Copyright (c) 1987, 1990, 1994 by Venue & Xerox Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT CALENDARHACKSCOMS)
-
-(RPAQQ CALENDARHACKSCOMS

-       (
-        (* |;;| "Hacks for making reminder-book pages for calendars.")

-
-        (FILES CALENDAR)
-        (COMS 
-              (* |;;| "User level functions")

-
-              (FNS PRINT-LAND-MONTH PRINT-LAND-YEAR PRINT-NOTEBOOK-MONTH PRINT-NOTEBOOK-YEAR 
-                   PRINT-SUMMARY-YEAR PRINT-NARROW-MONTH))
-        (COMS 
-              (* |;;| "Internal functions and macros")

-
-              (FNS PRINT-SCALED-MONTH PRINTMONTHIMAGE)
-              (FUNCTIONS CAL-X CAL-Y))))
-
-
-
-(* |;;| "Hacks for making reminder-book pages for calendars.")

-
-
-(FILESLOAD CALENDAR)
-
-
-
-(* |;;| "User level functions")

-
-(DEFINEQ
-
-(PRINT-LAND-MONTH

-  (LAMBDA (MONTH YEAR STREAM)
                                (* \; "Edited 17-Oct-87 17:45 by jds")

-          
-          (* |;;| "Print a single month's calendar landscape on letter paper.")

-
-    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T)))))
-         (PRINT-SCALED-MONTH
 MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6)
-         (CLOSEF PRINTSTREAM))))
-
-(PRINT-LAND-YEAR

-  (LAMBDA (YEAR STREAM)
                                      (* \; "Edited 17-Oct-87 17:49 by jds")

-          
-          (* |;;| "Print a single month's calendar landscape on letter paper.")

-
-    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T)))))
-         (|for|
 MONTH |from|
 1 |to|
 12
-            |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6)
-                 (DSPNEWPAGE PRINTSTREAM))
-         (CLOSEF PRINTSTREAM))))
-
-(PRINT-NOTEBOOK-MONTH

-  (LAMBDA (MONTH YEAR STREAM)
                                (* \; "Edited 17-Sep-87 21:55 by jds")

-          
-          (* |;;| "Print a single month's calendar on a half-sheet, suitable for punching and putting in a Time-Design notebook or a 5 1/2 x 8 1/2\" reminder book.")

-          
-          (* |;;| "If you leave STREAM NIL, you'll get one page on the printer.")

-
-    (PRINT-SCALED-MONTH
 MONTH YEAR 0 0 0.75 0.6 STREAM)))
-
-(PRINT-NOTEBOOK-YEAR

-  (LAMBDA (YEAR STREAM)
                       (* \; "Edited 23-Mar-94 17:22 by turpiN:mv:envos")

-
-    (* |;;| "Print a year's worth of month-calendar pages in half-sheet size.")

-
-    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT))))
-         (|for|
 MONTH |from|
 1 |to|
 12 |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 0
-                                                                   (COND
-                                                                      ((EVENP MONTH 2)
-                                                                       13970)
-                                                                      (T 0))
-                                                                   0.75 0.6 PRINTSTREAM)
-                                                         (COND
-                                                            ((EVENP MONTH 2)
-                                                             (DSPNEWPAGE PRINTSTREAM))))
-         (CLOSEF PRINTSTREAM))))
-
-(PRINT-SUMMARY-YEAR

-  (LAMBDA (YEAR STREAM)
                       (* \; "Edited 23-Mar-94 17:36 by turpiN:mv:envos")

-
-    (* |;;| "Print a year's worth of small months on 1 sheet of paper that will fit into a 8.25 x 10.5 format (for Time-Design books).")

-
-    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT '(LANDSCAPE T)))))
-         (|for|
 MONTH |from|
 1 |to|
 4 |as|
 YOFFSET |from|
 44500 |by|
 -14800
-            |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 227 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
-         (|for|
 MONTH |from|
 5 |to|
 8 |as|
 YOFFSET |from|
 44500 |by|
 -14800
-            |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 25427 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
-         (|for|
 MONTH |from|
 9 |to|
 12 |as|
 YOFFSET |from|
 44500 |by|
 -14800
-            |do|
 (PRINT-SCALED-MONTH
 MONTH YEAR 50627 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
-         (CLOSEF PRINTSTREAM))))
-
-(PRINT-NARROW-MONTH

-  (LAMBDA (MONTH YEAR STREAM)
                                (* \; "Edited 17-Sep-87 22:32 by jds")

-
-    (PRINT-SCALED-MONTH
 MONTH YEAR 0 0 0.45 0.95 STREAM NIL NIL NIL '(LANDSCAPE T))))
-)
-
-
-
-(* |;;| "Internal functions and macros")

-
-(DEFINEQ
-
-(PRINT-SCALED-MONTH

-  (LAMBDA (MONTH YEAR X-OFFSET Y-OFFSET X-SCALE Y-SCALE STREAM DAYSIZE DATESIZE TINYSIZE OPTIONS)

-                                                  (* \; "Edited 23-Mar-94 17:24 by turpiN:mv:envos")

-
-    (* |;;| 
-
  "Print a month's calendar on STREAM. MONTH is a number 1-12, Year is the year, 19-- and all.")

-
-    (PROG ((STREAM-EXISTED STREAM)
-           PBIGFONT PCALFONT PLITTLEFONT)
-          (SETCURSOR WAITINGCURSOR)
-          (PRINTOUT PROMPTWINDOW T "Formatting for print...")
-          (SETQ STREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT OPTIONS)))
-          (SETQ PBIGFONT (FONTCREATE 'MODERN (OR DAYSIZE 8)
-                                NIL 0 STREAM))
-          (SETQ PCALFONT (FONTCREATE 'CLASSIC (OR DATESIZE 12)
-                                NIL 0 STREAM))
-          (SETQ PLITTLEFONT (FONTCREATE 'MODERN (OR TINYSIZE 6)
-                                   NIL 0 STREAM))
-          (PRINTMONTHIMAGE
 MONTH YEAR STREAM X-OFFSET Y-OFFSET X-SCALE (OR Y-SCALE X-SCALE)
-                 PBIGFONT PCALFONT PLITTLEFONT)              (* \; "Print horizontal lines")

-          (OR STREAM-EXISTED (CLOSEF STREAM))
-          (PRINTOUT PROMPTWINDOW "done." T)
-          (CURSOR T))))
-
-(PRINTMONTHIMAGE

-  (LAMBDA (MONTH YEAR STREAM XOFFSET YOFFSET X-SCALE Y-SCALE DAYFONT DATEFONT TINYDATEFONT)

-                                                  (* \; "Edited 23-Mar-94 17:42 by turpiN:mv:envos")

-
-    (* |;;| 
-
  "Print a month's calendar on STREAM. MONTH is a number 1-12, Year is the year, 19-- and all.")

-
-    (* |;;| 
-
  " X-SCALE & XOFFSET,  and Y-SCALE & YOFFSET are used in the CAL-X and CAL-Y macros, resp.")

-
-    (* |;;| "DAYFONT and DATEFONT are used for printing the day names and dates/month title resp.")

-
-    (DSPRESET STREAM)
-    (DSPRIGHTMARGIN 65535 STREAM)
-    (LET ((TITLESTRING (CONCAT (MONTHNAME MONTH)
-                              "   " YEAR)))
-         (MOVETO (- (CAL-X
 37559)
-                    (IQUOTIENT (STRINGWIDTH TITLESTRING DATEFONT)
-                           2))
-                (CAL-Y
 57827)
-                STREAM))
-    (DSPFONT DATEFONT STREAM)
-    (PRINTOUT STREAM (MONTHNAME MONTH)
-           "   " YEAR)
-    (LET ((DAYLABELS (APPEND (|for|
 N |from|
 1 |to|
 (DAYOF MONTH 1 YEAR)
-                                |collect|
 '\ )
-                            (|for|
 N |from|
 1 |to|
 (DAYSIN MONTH YEAR) |collect|

-                                                                                   N)))
-          (X 1559)
-          (Y 47339)
-          (CT 0))
-         (|for|
 I |in|
 DAYLABELS |do|
 
-
-                                              (* |;;| "Print blanks up to the first day of the month (to allow for not starting on Sunday), then print the dates.")

-
-                                               (MOVETO (CAL-X
 X)
-                                                      (CAL-Y
 Y)
-                                                      STREAM)
-                                               (PRIN1 I STREAM)
-                                               (|add|
 X 10630)
-                                               (|add|
 CT 1)
-                                               (COND
-                                                  ((EQ (IREMAINDER CT 7)
-                                                       0)
-                                                   (SETQ X 1701)
-                                                   (|add|
 Y -8974)))))
-    (|for|
 X |from|
 850 |to|
 75968 |by|
 10630 |do|
 
-
-                                                                    (* |;;| "Print vertical lines")

-
-                                                                    (DRAWLINE (CAL-X
 X)
-                                                                           (CAL-Y
 1701)
-                                                                           (CAL-X
 X)
-                                                                           (CAL-Y
 55559)
-                                                                           40
-                                                                           'PAINT STREAM))
-    (|for|
 Y |from|
 1701 |to|
 55559 |by|
 8974 |do|
 
-
-                                                                    (* |;;| 
-
                                                                  "Print horizontal lines")

-
-                                                                    (DRAWLINE (CAL-X
 850)
-                                                                           (CAL-Y
 Y)
-                                                                           (CAL-X
 75260)
-                                                                           (CAL-Y
 Y)
-                                                                           40
-                                                                           'PAINT STREAM))
-    (DSPFONT DAYFONT STREAM)
-    (|for|
 X |from|
 2268 |to|
 72567 |by|
 10630 |as|
 D |from|
 0 |to|

-                                                                                       6
-       |do|
 
-
-             (* |;;| "Print day names")

-
-             (MOVETO (CAL-X
 X)
-                    (CAL-Y
 56126)
-                    STREAM)
-             (PRIN1 (DAYNAME D)
-                    STREAM))
-    (COND
-       ((>= X-SCALE 0.7)
-        (DSPFONT PLITTLEFONT STREAM)
-        (SHOWMONTHSMALL (MONTHPLUS MONTH -1)

internal/library/FASL-DEBUG

@@ -1 +1,71 @@
-(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
+(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
+
(FILECREATED " 3-Dec-86 12:01:43" {ERIS}<LISPCORE>INTERNAL>LIBRARY>FASL-DEBUG.;3
 3296   
+
+      changes to%:  (VARS FASL-DEBUGCOMS)
+                    (FUNCTIONS FASL-LOAD DUMP-SOME-TEXT TEST-FASL-OUT DUMP-SOME-VALUES READ-BACK-FASL 
+                           PROCESS-TEXT PROCESS-ITEM MAKE-FASL-TRACE-WINDOW)
+
+      previous date%: "19-Sep-86 13:32:53" {ERIS}<LISPCORE>INTERNAL>LIBRARY>FASL-DEBUG.;1)
+
+
+(* "
+Copyright (c) 1986 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT FASL-DEBUGCOMS)
+
+(RPAQQ FASL-DEBUGCOMS
 ((FUNCTIONS FASL-LOAD TEST-FASL-OUT DUMP-SOME-TEXT DUMP-SOME-VALUES 
+                              READ-BACK-FASL PROCESS-TEXT PROCESS-ITEM MAKE-FASL-TRACE-WINDOW)
+                       (PROP FILETYPE FASL-DEBUG)))
+
+(CL:DEFUN FASL-LOAD
 (NAME) (CL:WITH-OPEN-FILE (S NAME :DIRECTION :INPUT)
+                                  (FASL:PROCESS-FILE S)))
+
+
+(CL:DEFUN TEST-FASL-OUT
 NIL (FASL:WITH-OPEN-HANDLE (HANDLE "test.dfasl;1" :IF-EXISTS :OVERWRITE)
+                                   (DUMP-SOME-TEXT HANDLE "This is a test.")
+                                   (DUMP-SOME-VALUES HANDLE)))
+
+
+(CL:DEFUN DUMP-SOME-TEXT
 (HANDLE STRING) (CL:PRINC STRING (FASL:BEGIN-TEXT HANDLE)))
+
+
+(CL:DEFUN DUMP-SOME-VALUES
 (HANDLE) (FASL:BEGIN-BLOCK HANDLE)
+                                    (FASL:DUMP-VALUE HANDLE 1.1)
+                                    (FASL:DUMP-VALUE HANDLE -1.1)
+                                    (FASL:DUMP-VALUE HANDLE 0.11)
+                                    (FASL:DUMP-VALUE HANDLE -0.11))
+
+
+(CL:DEFUN READ-BACK-FASL
 (&OPTIONAL (NAME "test.dfasl")) [WITH-OPEN-FILE (S NAME :DIRECTION :INPUT)
+                                                                (CL:UNLESS (EQL (BIN S)
+                                                                                FASL:SIGNATURE)
+                                                                       (CL:ERROR 
+                                                                              "Incorrect signature.")
+                                                                       )
+                                                                (FASL:CHECK-VERSION S)
+                                                                (CL:LOOP (CL:WHEN (EOFP S)
+                                                                                (RETURN))
+                                                                       (FASL:PROCESS-SEGMENT
+                                                                        S
+                                                                        #'PROCESS-TEXT
+                                                                        #'PROCESS-ITEM])
+
+
+(CL:DEFUN PROCESS-TEXT
 (S) (CL:PRINC S)
+                           (CL:TERPRI))
+
+
+(CL:DEFUN PROCESS-ITEM
 (X) (CL:FORMAT T "Value: ~S~%%" X))
+
+
+(CL:DEFUN MAKE-FASL-TRACE-WINDOW
 NIL (LET ((W (CREATEW NIL "FASL trace")))
+                                          (DSPSCROLL 'ON W)
+                                          (CL:SETF FASL::DEBUG-STREAM (GETSTREAM W))))
+
+
+(PUTPROPS FASL-DEBUG FILETYPE
 CL:COMPILE-FILE)
+(PUTPROPS FASL-DEBUG COPYRIGHT ("Xerox Corporation" 1986))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

internal/library/MAKE-EXPORTS-ALL

@@ -1 +1,56 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED " 3-May-2018 15:37:56" 
+{DSK}<Users>kaplan>Local>medley3.5>lispcore>internal>library>MAKE-EXPORTS-ALL.;1
 1800   
+
+      changes to%:  (VARS MAKE-EXPORTS-ALLCOMS))
+
+
+(PRETTYCOMPRINT MAKE-EXPORTS-ALLCOMS)
+
+(RPAQQ MAKE-EXPORTS-ALLCOMS

+       ((* "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."
+           )
+        (* "Edited July 5, 1990 by Sybalsky -- point it to Pele as the truth directory.")
+        (* "Edited September 29, 1986 by van Melle")
+        (P (BKSYSBUF '(PROGN (CNDIR (CONCAT (UNIX-GETENV "MEDLEYDIR")
+                                           '/lispcore/sources/))
+                             (LOAD 'FILESETS)
+                             (RENAMEFILE (GATHEREXPORTS EXPORTFILES '{CORE}EXPORTS.ALL)
+                                    '../library/EXPORTS.ALL))
+                  T))))
+
+
+
+(* 
+"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.")

+
+
+
+
+(* "Edited July 5, 1990 by Sybalsky -- point it to Pele as the truth directory.")

+
+
+
+
+(* "Edited September 29, 1986 by van Melle")

+
+
+(BKSYSBUF '(PROGN (CNDIR (CONCAT (UNIX-GETENV "MEDLEYDIR")
+                                '/lispcore/sources/))
+                  (LOAD 'FILESETS)
+                  (RENAMEFILE (GATHEREXPORTS EXPORTFILES '{CORE}EXPORTS.ALL)
+                         '../library/EXPORTS.ALL))
+       T)
+(PUTPROPS MAKE-EXPORTS-ALL COPYRIGHT (NONE))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

internal/library/MAKE-TCP-EXPORTS

@@ -1 +1,28 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+
(FILECREATED "15-Jun-90 10:32:43" 
+|{DSK}<usr>local>lde>lispcore>internal>library>MAKE-TCP-EXPORTS.;2|
 1356   
+
+      |changes| |to:|  (VARS MAKE-TCP-EXPORTSCOMS)
+
+      |previous| |date:| "14-Jul-88 19:44:17" 
+|{DSK}<usr>local>lde>lispcore>internal>library>MAKE-TCP-EXPORTS.;1|)
+
+
+; Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT MAKE-TCP-EXPORTSCOMS)
+
+(RPAQQ MAKE-TCP-EXPORTSCOMS
 ((VARIABLES XCL-USER::*TCP-EXPORT-LIST*)))
+
+(DEFGLOBALVAR XCL-USER::*TCP-EXPORT-LIST*

+   '(XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCP XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPCHAT 
+           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPCONFIG XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPDEBUG 
+           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPDOMAIN XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPFTP 
+           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPFTPSRV XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPHTE 
+           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPLLAR XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPLLICMP 
+           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPLLIP XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPNAMES 
+           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPTFTP XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPUDP))
+(PUTPROPS MAKE-TCP-EXPORTS COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

internal/library/MULTI-COMPILE

@@ -162,17 +162,166 @@
 
 (DEFINEQ
 
-(NEWERDCOMS?

+(NEWERDCOMS?

+  (LAMBDA (DIRPAIRS EXTENSIONS FILTER)
                   (* \; "Edited  9-Dec-86 21:39 by bvm")

+    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
+                                  ({ERIS}<LISPCORE>NEWSTRING>LIBRARY> {ERIS}<LISPCORE>LIBRARY>)
+                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
+                                         {ERIS}<LISPCORE>INTERNAL>LIBRARY>))))
+    (OR EXTENSIONS (SETQ EXTENSIONS '(LCOM DCOM)))
+    (|for|
 PAIR |in|
 DIRPAIRS
+       |join|
 (RESETLST
+                      (LET ((THISDIR (CAR PAIR))
+                            (OTHERDIR (CADR PAIR))
+                            (THISEXT (CAR EXTENSIONS))
+                            (OTHEREXT (CADR EXTENSIONS))
+                            NEXT DT OTHERFILE OTHERDT OTHERWDT THISAUTHOR DIRPRINTED GEN)
+                           (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY THISDIR
+                                                             'NAME "*" 'EXTENSION THISEXT
+                                                             'VERSION "")
+                                            '(ICREATIONDATE)
+                                            '(RESETLST)))
+                           (|while|
 (SETQ NEXT (\\GENERATENEXTFILE GEN)) |eachtime|

+                                                                             (SETQ OTHERWDT NIL)
+                              |when|
 (AND (SETQ OTHERFILE (INFILEP (PACKFILENAME.STRING
+                                                                        'DIRECTORY OTHERDIR
+                                                                        'EXTENSION OTHEREXT
+                                                                        'VERSION NIL 'BODY NEXT)))
+                                              (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE))
+                                              (OR (AND (SETQ OTHERDT (GETFILEINFO OTHERFILE
+                                                                            'ICREATIONDATE))
+                                                       (< DT OTHERDT))
+                                                  (AND (SETQ OTHERWDT (GETFILEINFO OTHERFILE
+                                                                             'IWRITEDATE))
+                                                       (< DT OTHERWDT)))
+                                              (OR (NULL FILTER)
+                                                  (CL:FUNCALL FILTER NEXT OTHERFILE DT OTHERDT 
+                                                         OTHERWDT GEN)))
+                              |collect|
 (|if|
 (NOT DIRPRINTED)
+                                                |then|
 (|printout| T T "   " THISDIR 18 
+                                                                  "This Date" 38 "Other Date" 58 
+                                                                  "Author" T)
+                                                      (SETQ DIRPRINTED T))
+                                    (|printout| T (SUBSTRING NEXT
+                                                         (STRPOS THISDIR NEXT 1 NIL T T 
+                                                                UPPERCASEARRAY))
+                                           18
+                                           (GDATE DT)
+                                           38
+                                           (GDATE OTHERDT)
+                                           58)
+                                    (|if|
 OTHERWDT
+                                        |then|
 (|printout| T (GDATE OTHERWDT)
+                                                          " "))
+                                    (|printout| T (GETFILEINFO OTHERFILE 'AUTHOR)
+                                           T)
+                                    (FILENAMEFIELD NEXT 'NAME)))))))
 
-    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
+(NEWERSOURCES?

+  (LAMBDA (DIRPAIRS FILTER)
                              (* \; "Edited  9-Dec-86 23:07 by bvm")

+    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
+                                  ({ERIS}<LISPCORE>NEWSTRING>LIBRARY> {ERIS}<LISPCORE>LIBRARY>)
+                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
+                                         {ERIS}<LISPCORE>INTERNAL>LIBRARY>))))
+    (|for|
 PAIR |in|
 DIRPAIRS
+       |do|
 (RESETLST
+                    (LET ((THISDIR (CAR PAIR))
+                          (OTHERDIR (CADR PAIR))
+                          NEXT DT THISFILE THISDT WDT DIRPRINTED GEN)
+                         (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY OTHERDIR
+                                                           'NAME "*" 'VERSION "")
+                                          '(ICREATIONDATE IWRITEDATE AUTHOR)
+                                          '(RESETLST)))
+                         (|while|
 (SETQ NEXT (\\GENERATENEXTFILE GEN))
+                            |eachtime|
 (SETQ THISDT (SETQ WDT (SETQ DT NIL)))
+                            |when|
 (AND (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE))
+                                            (OR (NULL (SETQ THISFILE (INFILEP (PACKFILENAME.STRING
+                                                                               'DIRECTORY THISDIR
+                                                                               'EXTENSION COMPILE.EXT
+                                                                               'VERSION NIL
+                                                                               'BODY NEXT))))
+                                                (AND (SETQ THISDT (GETFILEINFO THISFILE 
+                                                                         'ICREATIONDATE))
+                                                     (OR (> DT THISDT)
+                                                         (AND (SETQ WDT (\\GENERATEFILEINFO
+                                                                         GEN
+                                                                         'IWRITEDATE))
+                                                              (> WDT THISDT)))))
+                                            (OR (NULL FILTER)
+                                                (CL:FUNCALL FILTER NEXT THISFILE DT WDT THISDT GEN)))
+                            |do|
 (|if|
 (NOT DIRPRINTED)
+                                         |then|
 (|printout| T T "   " OTHERDIR 18 " Its Date" 38
+                                                           " Other Date" 58 "Author" T)
+                                               (SETQ DIRPRINTED T))
+                                  (OR (GET (NAMEFIELD NEXT)
+                                           'FILEDATES)
+                                      (PRIN1 "+" T))
+                                  (|printout| T (SUBSTRING NEXT
+                                                       (STRPOS OTHERDIR NEXT 1 NIL T T UPPERCASEARRAY
+                                                              ))
+                                         18
+                                         (GDATE DT)
+                                         38
+                                         (|if|
 THISDT
+                                             |then|
 (GDATE THISDT)
+                                           |else|
 " - - -")
+                                         58)
+                                  (|if|
 WDT
+                                      |then|
 (|printout| T (GDATE WDT)
+                                                        " "))
+                                  (|printout| T (\\GENERATEFILEINFO GEN 'AUTHOR)
+                                         T)))))))
 
-                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
+(SETUP-FOR-RECOMPILE

+  (LAMBDA NIL
                                            (* \; "Edited  8-Dec-86 21:23 by jop:")

+                                                             (* \; 
+
                                                           "So we don't get alot of warnings")

+    (SETQ *REMOVE-INTERLISP-COMMENTS* NIL)                   (* \; 
+
                                                           "So we don't get asked stupid questions")

+    (SETQ CROSSCOMPILING T)                                  (* \; 
+
                                                           "setup up new compiled file version")

+    (PUTPROP ':D4 'CODEREADER (COPYALL (GETPROP 'D1 'CODEREADER)))
+    (RPAQQ CODEINDICATOR
 :D4)
+    (RPAQQ COMPILE.EXT
 LCOM)                             (* \; 
+
                                                           "Smash garbage collectable opcodes")

+    (SMASH-OPCODES
 GARBAGE-OPCODES)                      (* \; "Setup for unwind recompile")

+    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>UNWINDMACROS 'SYSLOAD)
+                                                             (* \; "may not be necessary")

+    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>PROC 'PROP)     (* \; "Setup for new string recompile")

+    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>LLCHAR 'PROP)
+    (REMPROP 'STRINGP 'DOPVAL)                               (* \; "to get correct record def's")

+    (LOAD '{ERIS}<LISPCORE>SOURCES>CMLARRAY 'PROP)           (* \; "Setup for new stream record")

+    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>FILEIO 'PROP)   (* \; 
+
                                                     "To setup packagified global type number vars")

+    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>DTDECLARE.DCOM 'SYSLOAD)
+                                                             (* \; 
+
                                              "hack for typep - not needed if makesysdate > Nov 23")

+    (CL:DEFTYPE :DATATYPE (OBJECT)
+       `(DATATYPE ,OBJECT))                                  (* \; "dribble hack")

+    (WBREAK NIL)                                             (* \; "So the debuuger will compile")

+    (LOAD '{ERIS}<LISPCORE>SOURCES>XCL-PACKAGE.DCOM)         (* \; "To fix the broken FP printer")

+    (LOADFNS '\\CONVERT.FLOATING.NUMBER '{ERIS}<LISPCORE>SOURCES>LLFLOAT.DCOM)))
 
-    (OR EXTENSIONS (SETQ EXTENSIONS '(LCOM DCOM)))
+(SMASH-OPCODES

+  (LAMBDA (OPCODE-ALIST)
                                 (* \; "Edited 24-Nov-86 17:56 by jop:")

+    (LET (OPNUMBER)
+         (CL:DOLIST (OPCODE OPCODE-ALIST)
+             (SETQ OPNUMBER (CADR OPCODE))
+             (CL:NSUBSTITUTE-IF (LIST OPNUMBER ':UNUSED)
+                    (FUNCTION (CL:LAMBDA (OP)
+                                     (EQL (CAR OP)
+                                          OPNUMBER)))
+                    \\OPCODES :COUNT 1)
+             (SETQ \\OPCODEARRAY NIL)))))
 
-       |join|
 (RESETLST
+(GET-DIRECTORY-LISTING

+  (LAMBDA (DIRECTORY EXTENSION)
                          (* \; "Edited 24-Nov-86 18:14 by jop:")

+    (|for|
 X |infiles|
 (DIRECTORY.FILL.PATTERN DIRECTORY (OR EXTENSION "")
+                                      "") |collect|
 (FILENAMEFIELD X 'NAME))))
 
-                            (OTHERDIR (CADR PAIR))
+(GET-OPEN-FILES

+  (LAMBDA (DEVICE-NAME)
                                  (* \; "Edited 25-Nov-86 18:16 by jop:")

+    (FETCH
 (FDEV OPENFILELST) OF
 (CDR (ASSOC DEVICE-NAME \\DEVICENAMETODEVICE)))))
 )
 
 
@@ -326,19 +475,108 @@
 
 (DEFINEQ
 
-(* |;;| "Control variables")

+(FIX-FILES

+  (CL:LAMBDA (FILENAMES SOURCEDIR DESTDIR &OPTIONAL (DRIBBLE-FILE '{DSK6}BIGCOMP.DRIBBLE)
+                    DELETE-DRIBBLE? RECORDS-TO-FIX)
      (* \; "Edited 15-Aug-90 12:02 by jds")

 
-
+         (* |;;| "Make large-scale fix-ups to a bunch of files.")

 
-       (PACKAGE-STARTUP LLPACKAGE LLSYMBOL CMLARRAY CMLLIST CMLMACROS DMISC COMPATIBILITY APUTDQ 
+         (CL:BLOCK FIX-FILES
+             (LET ((COMPLETION 'ERROR)
+                   (NUM-FILES (LENGTH FILENAMES)))
+                  (IDLE.SET.OPTION 'TIMEOUT T)
+                  (SETQ NOSPELLFLG T)
+                  (SETQ DWIMIFYCOMPFLG NIL)
+                  (CL:UNWIND-PROTECT
+                      (PROGN (DRIBBLE DRIBBLE-FILE)
+                             (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
+                                    'PAGEFULLFN
+                                    'NILL)
+                             (CNDIR DESTDIR)
+                             (PRINTOUT NIL "= = = = = Setting up for large-scale fix-up run on "
+                                    (DATE)
+                                    " = = = = =" T T)
+                             (|for|
 FILE |in|
 FILENAMES |as|
 FILE-NUM |from|
 1
+                                |do|
 (DSPNEWPAGE (GETSTREAM NIL 'OUTPUT))
+                                      (LET* ((SOURCEFILE (PACKFILENAME 'BODY FILE 'DIRECTORY 
+                                                                SOURCEDIR))
+                                             (DESTFILE (PACKFILENAME 'BODY FILE 'DIRECTORY DESTDIR)))
+                                            (RESETLST
+                                                (PRINTOUT NIL T "Fixing file " SOURCEFILE " at "
+                                                       (DATE)
+                                                       " - - -" T)
+                                                (PRINTOUT NIL T "(File number " FILE-NUM " of " 
+                                                       NUM-FILES ": " (- NUM-FILES FILE-NUM)
+                                                       " left)" T T)
+                                                (PRINT (FIX-FILE
 FILE RECORDS-TO-FIX)
+                                                       T)
+                                                (PRINTOUT NIL T T "- - - End of " FILE 
+                                                       " fix-up - - -" T))))
+                             (PRINTOUT NIL T T T "= = = = = END OF CLEANUP RUN = = = = =")
+                             (SETQ COMPLETION 'SUCCESS))
+                      (PRINTOUT NIL T "Fix-up status: " COMPLETION T T)
+                      (DRIBBLE)
+                      (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
+                             'PAGEFULLFN NIL))
+                  (SEND.FILE.TO.PRINTER DRIBBLE-FILE)
+                  (AND DELETE-DRIBBLE? (DELFILE DRIBBLE-FILE))))))
 
-              BOOTSTRAP MISC AINTERRUPT AERROR ABASIC APRINT ATERM MOD44IO VANILLADISK PMAP ADIR AOFD
+(FIX-FILE

+  (LAMBDA (FILE RECORD-NAMES MAKEFILE-ONLY?)
             (* \; "Edited 21-Jan-93 16:30 by jds")

 
-              LLBIGNUM LLFLOAT LLARITH LLARRAYELT LLMVS LLINTERP LLGC LLBASIC IMAGEIO FILEIO LLNEW 
+    (* |;;| "Perform cleanup tasks on FILE.")

 
-              DEFPACKAGE-IMPORT XCL-PACKAGE LISP-PACKAGE FASL-PACKAGE COMPILER-PACKAGE BSP DPUPFTP 
+    (LOAD FILE 'PROP)
+    (LOADCOMP FILE 'PROP)
 
-              CMLPROGV CMLEVAL COMMON CMLSPECIALFORMS CONDITION-HIERARCHY XCLC-RUNTIME CMLTYPES 
+    (* |;;| "(FIX-COPYRIGHT FILE)")

+
+    (AND (FILEFNSLST FILE)
+         (|for|
 RECNAME |in|
 (APPEND (FILECOMSLST FILE 'RECORDS)
+                                            RECORD-NAMES) |do|
 (QUALIFY-FIELDS
 RECNAME FILE))
+         )
+    (MARKASCHANGED FILE 'FILES)
+    (COND
+       (MAKEFILE-ONLY? (MAKEFILE FILE))
+       (T (APPLY* 'CLEANUP FILE)))))
+
+(FIX-COPYRIGHT

+  (LAMBDA (FILENAME)
+    (LET ((CR (GETPROP FILENAME 'COPYRIGHT)))
+         (COND
+            (CR (RPLACA CR "Venue & Xerox Corporation"))
+            (T (PUTPROP FILENAME 'COPYRIGHT (LIST "Venue" 1990)))))))
+
+(FIX-FILE-COPYRIGHT

+  (LAMBDA (FILE)
+    (LOADFROM FILE NIL 'PROP)
+    (FIX-COPYRIGHT
 FILE)
+    (MARKASCHANGED FILE 'FILES)
+    (APPLY* 'CLEANUP FILE)))
+
+(QUALIFY-FIELDS

+  (LAMBDA (RECNAME FILE)
                                 (* \; "Edited 28-Sep-87 14:41 by bvm:")

+    (APPLY* 'EDITFNS FILE `(LPQ F ((*ANY* FETCH |fetch| REPLACE |replace| FFETCH |ffetch| FREPLACE 
+                                          |freplace| /REPLACE |/replace|)
+                                   (*ANY* ,@(APPEND (RECORDFIELDNAMES RECNAME)))
+                                   --)
+                                2
+                                (MBD ,RECNAME)
+                                0 P))))
+
+(FIX-TEDIT

+  (LAMBDA (FILE)
                                         (* \; "Edited 17-Aug-90 16:07 by jds")

+    (LET ((STRM (OPENTEXTSTREAM (MKATOM FILE))))
+         (TEDIT.SUBLOOKS STRM '(FAMILY OPTIMA)
+                '(FAMILY CLASSIC))
+         (TEDIT.PUT STRM FILE)
+         (CLOSEF STRM))))
+
+(FIX-DOCS

+  (LAMBDA (DIRECTORY)
+    (LET ((FILES (|for|
 FILE |in|
 (DIRECTORY (CONCAT DIRECTORY "*.TEDIT;"))
+                    |collect|
 (PACKFILENAME.STRING 'VERSION NIL 'BODY FILE))))
+         (|for|
 FILE |in|
 FILES |do|
 (FIX-TEDIT
 FILE)))))
 )
 
 

internal/library/MULTI-COMPILE.~4~

@@ -1,374 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
(FILECREATED "16-Nov-94 16:28:04" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;4|
 37236  
-
-      |changes| |to:|  (VARS MULTI-COMPILECOMS)
-                       (FNS FIND-UNCOMPILED-FILES)
-
-      |previous| |date:| " 9-Sep-94 13:03:19" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;3|)
-
-
-; Copyright (c) 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT MULTI-COMPILECOMS)
-
-(RPAQQ MULTI-COMPILECOMS

-       (
-        (* |;;| "Support for compiling multiple files in one pass, for a bulk recompilation of the system (or some part of it).")

-
-        (COMS                                                (* \; "Function to compile multiple files without having one step on the next (so you could compile all the system with it).")

-              (FUNCTIONS BIGCOMP))
-        (COMS                                                (* \; "Function to identify all the source files on a given directory (useful for creating lists of things to compile)")

-              (FUNCTIONS FIND-ALL-SOURCE-FILES)
-              (FNS FIND-UNCOMPILED-FILES))
-        (COMS                                                (* \; 
-
                                            "Misc utility functions from the big Lyric recompiles.")

-              (FNS NEWERDCOMS? NEWERSOURCES? SETUP-FOR-RECOMPILE SMASH-OPCODES GET-DIRECTORY-LISTING
-                   GET-OPEN-FILES)
-              
-              (* |;;| "Control variables")

-
-              (VARS FILES-IN-FULL.SYSOUT FILES-IN-LIBRARY FILES-IN-LISP.SYSOUT FILES-IN-SOURCES 
-                    FORKED-FILES GARBAGE-OPCODES))
-        (COMS                                                (* \; 
-
                                    "Utilities for making mass-scale fixups to a library of files.")

-              (FNS FIX-FILES FIX-FILE FIX-COPYRIGHT FIX-FILE-COPYRIGHT QUALIFY-FIELDS FIX-TEDIT 
-                   FIX-DOCS))
-        
-        (* |;;| "Removes bogus (CLISP  <clisp xlation> <real-code>) translations that result from CLISPARRAY being NIL.")

-
-        (FNS CLFIX)
-        (PROP FILETYPE MULTI-COMPILE)
-        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA FIX-FILES)))))
-
-
-
-(* |;;| 
-"Support for compiling multiple files in one pass, for a bulk recompilation of the system (or some part of it)."
-)

-
-
-
-
-(* \; 
-"Function to compile multiple files without having one step on the next (so you could compile all the system with it)."
-)

-
-
-(CL:DEFUN BIGCOMP
 (FILENAMES SOURCEDIRS DESTDIR &OPTIONAL (DRIBBLE-FILE '"{DSK}BIGCOMP.DRIBBLE")
-                             DELETE-DCOMS? DELETE-DRIBBLE?)
-
-   (* |;;| "Compile all the files in the system.")

-
-   (LET ((COMPLETION 'ERROR)
-         (NUM-FILES (LENGTH FILENAMES)))
-        (IDLE.SET.OPTION 'TIMEOUT T)                         (* \; "never idle")

-        (SETQ NOSPELLFLG T)                                  (* \; "death to DWIM!")

-        (SETQ DWIMIFYCOMPFLG NIL)                            (* \; "I mean it")

-
-        (* |;;| "do it")

-
-        (CL:UNWIND-PROTECT
-            (PROGN (DRIBBLE DRIBBLE-FILE)
-                   (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
-                          'PAGEFULLFN
-                          'NILL)
-                   (PRINTOUT NIL "= = = = = Setting up for full-system compilation run on " (DATE)
-                          " = = = = =" T T)
-                   (|for|
 FILE |in|
 FILENAMES |as|
 FILE-NUM |from|
 1
-                      |do|
 (DSPNEWPAGE (GETSTREAM NIL 'OUTPUT)) 
-
-                            (* |;;| "changed the destfile so it has the proper extension.  It was compiling everything correctly, but naming all the files .lcom.")

-
-                            (LET* ((CF (COMPILE-FILE? FILE))
-                                   (SOURCEFILE (FINDFILE FILE NIL SOURCEDIRS))
-                                   (DESTFILE (PACKFILENAME 'BODY FILE 'DIRECTORY DESTDIR 'EXTENSION
-                                                    (SELECTQ CF
-                                                        (CL:COMPILE-FILE 
-                                                             'DFASL)
-                                                        'LCOM))))
-                                  (RESETLST
-                                      (RESETSAVE (RESETUNDO))
-                                      (PRINTOUT NIL T "- - - " (OR CF 'BCOMPL)
-                                             "'ing file " SOURCEFILE " to " DESTFILE " at " (DATE)
-                                             " - - -" T)
-                                      (PRINTOUT NIL T "(File number " FILE-NUM " of " NUM-FILES ": "
-                                             (- NUM-FILES FILE-NUM)
-                                             " left)" T T)
-                                      (PRINT (SELECTQ CF
-                                                 ((BCOMPL TCOMPL NIL) 
-                                                      (LISPXUNREAD '(F))
-                                                      (CL:FUNCALL (OR CF 'BCOMPL)
-                                                             SOURCEFILE DESTFILE))
-                                                 (CL:FUNCALL CF SOURCEFILE :OUTPUT-FILE DESTFILE))
-                                             T)
-                                      (PRINTOUT NIL T T "- - - End of " FILE " compilation - - -" T))
-                                  (AND DELETE-DCOMS? (DELFILE DESTFILE))))
-                   (PRINTOUT NIL T T T "= = = = = END OF FULL-SYSTEM COMPILATION RUN = = = = =")
-                   (SETQ COMPLETION 'SUCCESS))
-
-            (* |;;| "cleanup forms")

-
-            (PRINTOUT NIL T "Compilation status: " COMPLETION T T)
-            (DRIBBLE)
-            (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
-                   'PAGEFULLFN NIL))
-        (SEND.FILE.TO.PRINTER DRIBBLE-FILE)
-        (AND DELETE-DRIBBLE? (DELFILE DRIBBLE-FILE))))
-
-
-
-(* \; 
-"Function to identify all the source files on a given directory (useful for creating lists of things to compile)"
-)

-
-
-(CL:DEFUN FIND-ALL-SOURCE-FILES
 (DIRECTORY)
-
-   (* |;;| "Return a list of every file that has a compiled equivalent on DIRECTORY.  This is a way of finding out what needs to be recompiled for a bulk compile.")

-
-   (LET ((DFASLS (FOR
 FILENAME IN
 (DIRECTORY (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY 
-                                                            "*.DFASL;"))
-                    COLLECT
 (UNPACKFILENAME FILENAME 'NAME)))
-         (LCOMS (FOR
 FILENAME IN
 (DIRECTORY (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY 
-                                                           "*.LCOM;"))
-                   COLLECT
 (UNPACKFILENAME FILENAME 'NAME))))
-        (UNION (INTERSECTION DFASLS DFASLS)
-               (INTERSECTION LCOMS LCOMS))))
-(DEFINEQ
-
-(FIND-UNCOMPILED-FILES

-  (LAMBDA (SRCDIR DESTDIR)
                               (* \; "Edited 16-Nov-94 16:23 by jds")

-    (LET ((SRCFILES (DIRECTORY (PACKFILENAME 'DIRECTORY SRCDIR 'BODY '*.\;)))
-          SFILE DFILE)
-         (|for|
 FILE |in|
 SRCFILES |do|
 (SETQ SFILE (UNPACKFILENAME FILE 'NAME))
-                                                 (COND
-                                                    ((AND (SETQ DFILE (FINDFILE-WITH-EXTENSIONS
-                                                                       SFILE
-                                                                       (LIST DESTDIR)
-                                                                       '(DFASL LCOM)))
-                                                          (ILESSP (GETFILEINFO DFILE 'ICREATIONDATE)
-                                                                 (GETFILEINFO FILE 'ICREATIONDATE)))
-                                                     (PRINTOUT T FILE " needs compiling." T))
-                                                    ((NOT DFILE)
-                                                     (PRINTOUT T FILE " has no compiled version." T))
-                                                    )))))
-)
-
-
-
-(* \; "Misc utility functions from the big Lyric recompiles.")

-
-(DEFINEQ
-
-(NEWERDCOMS?

-  (LAMBDA (DIRPAIRS EXTENSIONS FILTER)
                   (* \; "Edited  9-Dec-86 21:39 by bvm")

-    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
-                                  ({ERIS}<LISPCORE>NEWSTRING>LIBRARY> {ERIS}<LISPCORE>LIBRARY>)
-                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
-                                         {ERIS}<LISPCORE>INTERNAL>LIBRARY>))))
-    (OR EXTENSIONS (SETQ EXTENSIONS '(LCOM DCOM)))
-    (|for|
 PAIR |in|
 DIRPAIRS
-       |join|
 (RESETLST
-                      (LET ((THISDIR (CAR PAIR))
-                            (OTHERDIR (CADR PAIR))
-                            (THISEXT (CAR EXTENSIONS))
-                            (OTHEREXT (CADR EXTENSIONS))
-                            NEXT DT OTHERFILE OTHERDT OTHERWDT THISAUTHOR DIRPRINTED GEN)
-                           (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY THISDIR
-                                                             'NAME "*" 'EXTENSION THISEXT
-                                                             'VERSION "")
-                                            '(ICREATIONDATE)
-                                            '(RESETLST)))
-                           (|while|
 (SETQ NEXT (\\GENERATENEXTFILE GEN)) |eachtime|

-                                                                             (SETQ OTHERWDT NIL)
-                              |when|
 (AND (SETQ OTHERFILE (INFILEP (PACKFILENAME.STRING
-                                                                        'DIRECTORY OTHERDIR
-                                                                        'EXTENSION OTHEREXT
-                                                                        'VERSION NIL 'BODY NEXT)))
-                                              (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE))
-                                              (OR (AND (SETQ OTHERDT (GETFILEINFO OTHERFILE
-                                                                            'ICREATIONDATE))
-                                                       (< DT OTHERDT))
-                                                  (AND (SETQ OTHERWDT (GETFILEINFO OTHERFILE
-                                                                             'IWRITEDATE))
-                                                       (< DT OTHERWDT)))
-                                              (OR (NULL FILTER)
-                                                  (CL:FUNCALL FILTER NEXT OTHERFILE DT OTHERDT 
-                                                         OTHERWDT GEN)))
-                              |collect|
 (|if|
 (NOT DIRPRINTED)
-                                                |then|
 (|printout| T T "   " THISDIR 18 
-                                                                  "This Date" 38 "Other Date" 58 
-                                                                  "Author" T)
-                                                      (SETQ DIRPRINTED T))
-                                    (|printout| T (SUBSTRING NEXT
-                                                         (STRPOS THISDIR NEXT 1 NIL T T 
-                                                                UPPERCASEARRAY))
-                                           18
-                                           (GDATE DT)
-                                           38
-                                           (GDATE OTHERDT)
-                                           58)
-                                    (|if|
 OTHERWDT
-                                        |then|
 (|printout| T (GDATE OTHERWDT)
-                                                          " "))
-                                    (|printout| T (GETFILEINFO OTHERFILE 'AUTHOR)
-                                           T)
-                                    (FILENAMEFIELD NEXT 'NAME)))))))
-
-(NEWERSOURCES?

-  (LAMBDA (DIRPAIRS FILTER)
                              (* \; "Edited  9-Dec-86 23:07 by bvm")

-    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
-                                  ({ERIS}<LISPCORE>NEWSTRING>LIBRARY> {ERIS}<LISPCORE>LIBRARY>)
-                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
-                                         {ERIS}<LISPCORE>INTERNAL>LIBRARY>))))
-    (|for|
 PAIR |in|
 DIRPAIRS
-       |do|
 (RESETLST
-                    (LET ((THISDIR (CAR PAIR))
-                          (OTHERDIR (CADR PAIR))
-                          NEXT DT THISFILE THISDT WDT DIRPRINTED GEN)
-                         (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY OTHERDIR
-                                                           'NAME "*" 'VERSION "")
-                                          '(ICREATIONDATE IWRITEDATE AUTHOR)
-                                          '(RESETLST)))
-                         (|while|
 (SETQ NEXT (\\GENERATENEXTFILE GEN))
-                            |eachtime|
 (SETQ THISDT (SETQ WDT (SETQ DT NIL)))
-                            |when|
 (AND (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE))
-                                            (OR (NULL (SETQ THISFILE (INFILEP (PACKFILENAME.STRING
-                                                                               'DIRECTORY THISDIR
-                                                                               'EXTENSION COMPILE.EXT
-                                                                               'VERSION NIL
-                                                                               'BODY NEXT))))
-                                                (AND (SETQ THISDT (GETFILEINFO THISFILE 
-                                                                         'ICREATIONDATE))
-                                                     (OR (> DT THISDT)
-                                                         (AND (SETQ WDT (\\GENERATEFILEINFO
-                                                                         GEN
-                                                                         'IWRITEDATE))
-                                                              (> WDT THISDT)))))
-                                            (OR (NULL FILTER)
-                                                (CL:FUNCALL FILTER NEXT THISFILE DT WDT THISDT GEN)))
-                            |do|
 (|if|
 (NOT DIRPRINTED)
-                                         |then|
 (|printout| T T "   " OTHERDIR 18 " Its Date" 38
-                                                           " Other Date" 58 "Author" T)
-                                               (SETQ DIRPRINTED T))
-                                  (OR (GET (NAMEFIELD NEXT)
-                                           'FILEDATES)
-                                      (PRIN1 "+" T))
-                                  (|printout| T (SUBSTRING NEXT
-                                                       (STRPOS OTHERDIR NEXT 1 NIL T T UPPERCASEARRAY
-                                                              ))
-                                         18
-                                         (GDATE DT)
-                                         38
-                                         (|if|
 THISDT
-                                             |then|
 (GDATE THISDT)
-                                           |else|
 " - - -")
-                                         58)
-                                  (|if|
 WDT
-                                      |then|
 (|printout| T (GDATE WDT)
-                                                        " "))
-                                  (|printout| T (\\GENERATEFILEINFO GEN 'AUTHOR)
-                                         T)))))))
-
-(SETUP-FOR-RECOMPILE

-  (LAMBDA NIL
                                            (* \; "Edited  8-Dec-86 21:23 by jop:")

-                                                             (* \; 
-
                                                           "So we don't get alot of warnings")

-    (SETQ *REMOVE-INTERLISP-COMMENTS* NIL)                   (* \; 
-
                                                           "So we don't get asked stupid questions")

-    (SETQ CROSSCOMPILING T)                                  (* \; 
-
                                                           "setup up new compiled file version")

-    (PUTPROP ':D4 'CODEREADER (COPYALL (GETPROP 'D1 'CODEREADER)))
-    (RPAQQ CODEINDICATOR
 :D4)
-    (RPAQQ COMPILE.EXT
 LCOM)                             (* \; 
-
                                                           "Smash garbage collectable opcodes")

-    (SMASH-OPCODES
 GARBAGE-OPCODES)                      (* \; "Setup for unwind recompile")

-    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>UNWINDMACROS 'SYSLOAD)
-                                                             (* \; "may not be necessary")

-    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>PROC 'PROP)     (* \; "Setup for new string recompile")

-    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>LLCHAR 'PROP)
-    (REMPROP 'STRINGP 'DOPVAL)                               (* \; "to get correct record def's")

-    (LOAD '{ERIS}<LISPCORE>SOURCES>CMLARRAY 'PROP)           (* \; "Setup for new stream record")

-    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>FILEIO 'PROP)   (* \; 
-
                                                     "To setup packagified global type number vars")

-    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>DTDECLARE.DCOM 'SYSLOAD)
-                                                             (* \; 
-
                                              "hack for typep - not needed if makesysdate > Nov 23")

-    (CL:DEFTYPE :DATATYPE (OBJECT)
-       `(DATATYPE ,OBJECT))                                  (* \; "dribble hack")

-    (WBREAK NIL)                                             (* \; "So the debuuger will compile")

-    (LOAD '{ERIS}<LISPCORE>SOURCES>XCL-PACKAGE.DCOM)         (* \; "To fix the broken FP printer")

-    (LOADFNS '\\CONVERT.FLOATING.NUMBER '{ERIS}<LISPCORE>SOURCES>LLFLOAT.DCOM)))
-
-(SMASH-OPCODES

-  (LAMBDA (OPCODE-ALIST)
                                 (* \; "Edited 24-Nov-86 17:56 by jop:")

-    (LET (OPNUMBER)
-         (CL:DOLIST (OPCODE OPCODE-ALIST)
-             (SETQ OPNUMBER (CADR OPCODE))
-             (CL:NSUBSTITUTE-IF (LIST OPNUMBER ':UNUSED)
-                    (FUNCTION (CL:LAMBDA (OP)
-                                     (EQL (CAR OP)
-                                          OPNUMBER)))
-                    \\OPCODES :COUNT 1)
-             (SETQ \\OPCODEARRAY NIL)))))
-
-(GET-DIRECTORY-LISTING

-  (LAMBDA (DIRECTORY EXTENSION)
                          (* \; "Edited 24-Nov-86 18:14 by jop:")

-    (|for|
 X |infiles|
 (DIRECTORY.FILL.PATTERN DIRECTORY (OR EXTENSION "")
-                                      "") |collect|
 (FILENAMEFIELD X 'NAME))))
-
-(GET-OPEN-FILES

-  (LAMBDA (DEVICE-NAME)
                                  (* \; "Edited 25-Nov-86 18:16 by jop:")

-    (FETCH
 (FDEV OPENFILELST) OF
 (CDR (ASSOC DEVICE-NAME \\DEVICENAMETODEVICE)))))
-)
-
-
-
-(* |;;| "Control variables")

-
-
-(RPAQQ FILES-IN-FULL.SYSOUT

-       (PACKAGE-STARTUP LLPACKAGE LLSYMBOL CMLARRAY CMLLIST CMLMACROS DMISC COMPATIBILITY APUTDQ 
-              LLDISPLAY FONT PASSWORDS LEAF PUP LLETHER PROC ERROR-RUNTIME DEFSTRUCT-RUN-TIME 
-              BOOTSTRAP MISC AINTERRUPT AERROR ABASIC APRINT ATERM MOD44IO VANILLADISK PMAP ADIR AOFD
-              COREIO IOCHAR LLCODE ATBL DTDECLARE ASTACK LLTIMER LLKEY LLDATATYPE LLSTK LLCHAR LLREAD
-              LLBIGNUM LLFLOAT LLARITH LLARRAYELT LLMVS LLINTERP LLGC LLBASIC IMAGEIO FILEIO LLNEW 
-              LLBFS LLSUBRS LLFAULT PACKAGE-CONVERSION-TABLE ACODE MACHINEINDEPENDENT POSTLOADUP 
-              DEFPACKAGE-IMPORT XCL-PACKAGE LISP-PACKAGE FASL-PACKAGE COMPILER-PACKAGE BSP DPUPFTP 
-              CMLCHARACTER CMLREADTABLE STACKFNS CMLMVS MACROS MACROAUX CMLSYMBOL CMLHASH CMLDEFFER 
-              CMLPROGV CMLEVAL COMMON CMLSPECIALFORMS CONDITION-HIERARCHY XCLC-RUNTIME CMLTYPES 
-              CL-ERROR AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN 
-              ADVISE LOADFNS DIRECTORY FILEPKG RESOURCE DLAP BYTECOMPILER COMPILE HIST UNDO SPELL 
-              DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST ASKUSER CMLUNDO CMLEXEC DEBUGGER TRACE
-              CMLDOC CMLPARSE CMLSETF CMLPRED CMLARRAY-OPTIMIZERS CMLREAD CMLWALK CMLSEQCOMMON 
-              CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT CMLSEQ CMLARITH DEFSTRUCT
-              CMLMISCIO CMLCOMPILE CMLSTRING CLSTREAMS CMLDESTRUCT CMLFORMAT CMLENVIRONMENT CMLPRINT
-              CMLLOAD CMLFILESYS CMLFLOAT CMLTIME CMLRAND CMLMODULES ADDARITH READ-PRINT-PROFILE 
-              CMLPATHNAME HPRINT MSANALYZE MSPARSE MASTERSCOPE AARITH ADISPLAY HLDISPLAY MENU 
-              WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT 
-              TWODINSPECTOR FREEMENU CMLARRAYINSPECTOR EDITINTERFACE TTYIN DISKDLION DOVEINPUTOUTPUT
-              DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER LLNS
-              TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER 
-              ICONW SEDIT-ATOMIC SEDIT-COMMANDS SEDIT-COMMENTS SEDIT-LINEAR SEDIT-LISTS 
-              SEDIT-TERMINAL SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT D-ASSEM-PACKAGE D-ASSEM FASL 
-              XCLC-READER XCLC-ENV-CTXT XCLC-TREES XCLC-TOP-LEVEL XCLC-ALPHA XCLC-ANALYZE 
-              XCLC-META-EVAL XCLC-ANNOTATE XCLC-GENCODE XCLC-PEEPHOLE XCLC-DATABASE XCL-COMPILER 
-              CMLPACKAGE GIVE-AND-TAKE CHATTERMINAL DMCHAT CHAT PUPCHAT NSCHAT PRESS PUPPRINT 
-              TEDITDECLS TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS TEDITFIND 
-              TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION READNUMBER EDITBITMAP IMAGEOBJ 
-              TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS TEDIT HRULE TEDITCHAT GRAPEVINE 
-              MAILCLIENT NSMAIL LAFITEBROWSE LAFITESEND LAFITEMAIL LAFITE TABLEBROWSER FILEBROWSER 
-              REMOTEVMEM VMEM READSYS RDSYS TELERAID GRAPHER SPY AREDIT HASH WHEREIS COPYFILES))
-
-(RPAQQ FILES-IN-LIBRARY

-       (4045XLPDEFAULTPRINTER 4045XLPSTREAM ARCLEANUP AREDIT BROWSER BSEARCH CENTRONICS 
-              CHARCODETABLES CHAT CHATDECLS CHATTERMINAL CLMAIL CML CMLARRAYINSPECTOR CMLDEBUGGER 
-              CMLFLOATARRAY CMLHELP COLOR COLORDEMO CONDITIONGRAPH COPYFILES DANDELIONKEYBOARDS 
-              DATABASEFNS DAYBREAKKEYBOARDS DEDIT DES DICOLOR DINFO DLRS232C DLTTY DMCHAT DO-TEST 
-              DORADOCOLOR DORADOKEYBOARDS DOVEKEYBOARDS DOVERS232C DSKTEST EDITBITMAP ETHERRECORDS 
-              FASTFX80STREAM FILEBROWSER FILECACHE FILECACHE-BROWSER FILECACHE-DECLS FILECACHE-HOSTUP
-              FILECACHE-SCAVENGE FILENAMES FONTSAMPLE FTPSERVER FX80STREAM FXPRINTER GCHAX 
-              GIVE-AND-TAKE GRAPEVINE GRAPHER GRAPHZOOM HASH HELPSYS HRULE IMAGEOBJ KERMIT KERMITMENU
-              KEYBOARDEDITOR LAFITE LAFITEBROWSE LAFITEDECLS LAFITEFIND LAFITEMAIL LAFITESEND 

internal/library/NATIVE-TRANSLATOR-PACKAGE

@@ -1 +1,48 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "NATIVE-TRANSLATOR" (USE "IL")))
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "NATIVE-TRANSLATOR" (USE "IL")))
+
(FILECREATED "15-Jun-90 18:46:45" 
+{DSK}<usr>local>lde>lispcore>internal>library>NATIVE-TRANSLATOR-PACKAGE.;2
 1706   
+
+      changes to%:  (VARS NATIVE-TRANSLATOR-PACKAGECOMS)
+
+      previous date%: "10-Jun-88 11:23:35" 
+{DSK}<usr>local>lde>lispcore>internal>library>NATIVE-TRANSLATOR-PACKAGE.;1)
+
+
+(* ; "
+Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT NATIVE-TRANSLATOR-PACKAGECOMS)
+
+(RPAQQ NATIVE-TRANSLATOR-PACKAGECOMS
 (
+
+(* ;;; "Setting up the TRANSLATOR package.")

+
+                                          (P (DEFPACKAGE "NATIVE-TRANSLATOR" (:NICKNAMES "NT")
+                                                    (:USE "IL")))
+                                          
+                                          (* ;; "Arrange for the correct makefile environment")

+
+                                          (PROP MAKEFILE-ENVIRONMENT NATIVE-TRANSLATOR-PACKAGE)))
+
+
+
+(* ;;; "Setting up the TRANSLATOR package.")

+
+
+(DEFPACKAGE "NATIVE-TRANSLATOR" (:NICKNAMES "NT")
+       (:USE "IL"))
+
+
+
+(* ;; "Arrange for the correct makefile environment")

+
+
+(PUTPROPS NATIVE-TRANSLATOR-PACKAGE
 MAKEFILE-ENVIRONMENT
 (:READTABLE "INTERLISP" :PACKAGE
+                                                                        (DEFPACKAGE 
+                                                                               "NATIVE-TRANSLATOR"
+                                                                               (:USE "IL"))))
+(PUTPROPS NATIVE-TRANSLATOR-PACKAGE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

internal/library/PEANO

@@ -1 +1,114 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED "26-Jun-90 18:51:31" {DSK}<usr>local>lde>lispcore>internal>library>PEANO.;2
 3337   
+
+      changes to%:  (VARS PEANOCOMS)
+
+      previous date%: " 8-Nov-88 14:27:45" {DSK}<usr>local>lde>lispcore>internal>library>PEANO.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT PEANOCOMS)
+
+(RPAQQ PEANOCOMS
 ((FNS PEANODEMO PEANOROTATE PEANO1 PEANOSTEP)
+                      (MACROS PLOT)
+                      
+                      (* ;; "")

+
+                      (GLOBALVARS XNOW YNOW ORIENT PEANOSCALE PEANOWINDOW)
+                      (VARS PEANOSCALE (PEANOWINDOW NIL))))
+(DEFINEQ
+
+(PEANODEMO

+  [LAMBDA (LEVEL SCALE)
                                  (* rrb "31-MAY-82 12:16")

+    (OR LEVEL (SETQ LEVEL 7))
+    (COND
+       (SCALE (SETQ PEANOSCALE (FIX SCALE)))
+       ((FIXP PEANOSCALE))
+       (T (SETQ PEANOSCALE 3)))
+    (PROGN [COND
+              ((TYPENAMEP PEANOWINDOW 'WINDOW))
+              (T (SETQ PEANOWINDOW
+                  (CREATEW (create
 REGION
+                                  LEFT _ 624
+                                  BOTTOM _ 402
+                                  WIDTH _ 396
+                                  HEIGHT _ 406)
+                         "Peano curves"]
+           (CLEARW PEANOWINDOW)
+           (MOVETO PEANOSCALE PEANOSCALE PEANOWINDOW))
+    (SETQ XNOW 1)
+    (SETQ YNOW 1)
+    (SETQ ORIENT 0)
+    (PEANO1
 LEVEL 1])
+
+(PEANOROTATE

+  [LAMBDA (DIRECTION)
                                    (* bas%: "30-APR-82 19:29")

+    (add
 ORIENT DIRECTION)
+    (COND
+       ((IGREATERP ORIENT 3)
+        (SETQ ORIENT (IDIFFERENCE ORIENT 4)))
+       ((ILESSP ORIENT 0)
+        (SETQ ORIENT (IPLUS ORIENT 4])
+
+(PEANO1

+  [LAMBDA (LEVEL HAND)
                                   (* rrb "31-MAY-82 13:17")

+    (COND
+       ((EQ LEVEL 1)
+        (PLOT))
+       (T (SETQ LEVEL (SUB1 LEVEL))
+          (PEANOROTATE
 HAND)
+          (PEANO1
 LEVEL (IMINUS HAND))
+          (PEANOSTEP
)
+          (PLOT)
+          (PEANOSTEP
)
+          (PEANOROTATE
 (IMINUS HAND))
+          (PEANO1
 LEVEL HAND)
+          (PEANOSTEP
)
+          (PLOT)
+          (PEANOSTEP
)
+          (PEANO1
 LEVEL HAND)
+          (PEANOROTATE
 (IMINUS HAND))
+          (PEANOSTEP
)
+          (PLOT)
+          (PEANOSTEP
)
+          (PEANO1
 LEVEL (IMINUS HAND))
+          (PEANOROTATE
 HAND)
+          (BLOCK])
+
+(PEANOSTEP

+  [LAMBDA NIL
                                            (* rrb "31-MAY-82 11:31")

+    (SELECTQ ORIENT
+        (0 (SETQ XNOW (ADD1 XNOW)))
+        (1 (SETQ YNOW (ADD1 YNOW)))
+        (2 (SETQ XNOW (SUB1 XNOW)))
+        (3 (SETQ YNOW (SUB1 YNOW)))
+        (ERROR "Step: strange direction" ORIENT))
+    (MOVETO (ITIMES XNOW PEANOSCALE)
+           (ITIMES YNOW PEANOSCALE)
+           PEANOWINDOW])
+)
+(DECLARE%: EVAL@COMPILE 
+
+(PUTPROPS PLOT
 MACRO
 (NIL (RELDRAWTO PEANOSCALE 0 PEANOSCALE 'REPLACE PEANOWINDOW)))
+)
+
+
+
+(* ;; "")

+
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS XNOW YNOW ORIENT PEANOSCALE PEANOWINDOW)
+)
+
+(RPAQQ PEANOSCALE
 3)
+
+(RPAQQ PEANOWINDOW
 NIL)
+(PUTPROPS PEANO COPYRIGHT ("Venue & Xerox Corporation" 1982 1988 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (726 2957 (PEANODEMO 736 . 1527) (PEANOROTATE 1529 . 1819) (PEANO1 1821 . 2536) (
+PEANOSTEP 2538 . 2955)))))
+STOP

internal/library/README.TXT

@@ -1 +1,3 @@
-Files in this directory /usr/local/lde/internal/
+Files in this directory /usr/local/lde/internal/
+where copied from {eris}<lispcore>internal>library>
+31-Jan-90

internal/library/SPLICE

@@ -1 +1,95 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED "26-Jun-90 19:24:01" {DSK}<usr>local>lde>lispcore>internal>library>SPLICE.;2
 3583   
+
+      changes to%:  (VARS SPLICECOMS)
+
+      previous date%: "22-Nov-84 16:35:38" {DSK}<usr>local>lde>lispcore>internal>library>SPLICE.;1)
+
+
+(* ; "
+Copyright (c) 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT SPLICECOMS)
+
+(RPAQQ SPLICECOMS
 ((FNS * SPLICEFNS)
+                       (VARS BYTESPERPAGE)))
+
+(RPAQQ SPLICEFNS
 (CLIP JJOIN LSPLICE NCLIP NSPLICE SPLICE SPLICEJ SPLICES))
+(DEFINEQ
+
+(CLIP

+  [LAMBDA (SRCFIL DSTFIL)
                                (* bvm%: "24-Sep-84 15:03")

+    (CLOSEALL)
+    [COPYBYTES (OPENFILE SRCFIL 'INPUT)
+           (OPENFILE DSTFIL 'BOTH 'OLD NIL '(DON'T.CHANGE.DATE]
+    (CLOSEALL])
+
+(JJOIN

+  [LAMBDA (SRCFIL DSTFIL)
                                (* scp " 6-DEC-82 15:43")

+    (CLOSEALL)
+    (COPYBYTES (OPENFILE SRCFIL 'INPUT)
+           (OPENFILE DSTFIL 'APPEND 'OLD))
+    (CLOSEALL])
+
+(LSPLICE

+  [LAMBDA NIL
                                            (* scp "14-DEC-82 22:30")

+    (CLIP
 '{DSK}DLISPDOMINO.DB '{DSK}LISP.DLBOOT])
+
+(NCLIP

+  [LAMBDA (SRCFIL DSTFIL)
                                (* JonL "22-Nov-84 16:34")

+    (RESETLST
+        [RESETSAVE (SETQ SRCFIL (OPENSTREAM SRCFIL 'INPUT))
+               '(PROGN (CLOSEF? OLDVALUE]
+        (if
 (IGREATERP (IABS (IDIFFERENCE 200 (OR (GETFILEINFO SRCFIL 'SIZE)
+                                                      200)))
+                       100)
+            then
 (HELP SRCFIL "File size not appropriate for DLion ucode .db")
+          elseif
 (AND (NEQ (GETFILEINFO SRCFIL 'TYPE)
+                               'BINARY)
+                          (GETFILEINFO SRCFIL 'TYPE))
+            then
 (HELP SRCFIL "File type must be BINARY for DLion ucode .db"))
+        [RESETSAVE [SETQ DSTFIL (OPENSTREAM DSTFIL 'BOTH 'OLD NIL '(DON'T.CHANGE.DATE]
+               '(PROGN (CLOSEF? OLDVALUE]
+        (if
 (ILESSP (OR (GETFILEINFO DSTFIL 'SIZE)
+                            2000)
+                       2000)
+            then
 (HELP DSTFIL "File size not appropriate for .sysout")
+          elseif
 (AND (NEQ (GETFILEINFO DSTFIL 'TYPE)
+                               'BINARY)
+                          (GETFILEINFO DSTFIL 'TYPE))
+            then
 (HELP DSTFIL "File type must be BINARY for .sysout")
+          elseif
 (NOT (RANDACCESSP DSTFIL))
+            then
 (HELP DSTFIL ".sysout File must be RANDACCESSP for CLIP'ing"))
+        (SETFILEPTR SRCFIL 512)
+        (SETFILEPTR DSTFIL 1024)
+        (COPYBYTES SRCFIL DSTFIL)
+        (LIST (FULLNAME SRCFIL)
+              (FULLNAME DSTFIL)))])
+
+(NSPLICE

+  [LAMBDA (DLBOOTNAME)
                                   (* edited%: " 6-APR-83 15:34")

+    (NCLIP
 '{DSK}DLISPDOMINO.DB (OR DLBOOTNAME '{DSK}BIGTEST.DLBOOT])
+
+(SPLICE

+  [LAMBDA (DLBOOTNAME)
                                   (* scp "14-JAN-83 11:42")

+    (CLIP
 '{DSK}DLISPDOMINO.DB (OR DLBOOTNAME '{DSK}BIGTEST.DLBOOT])
+
+(SPLICEJ

+  [LAMBDA NIL
                                            (* scp " 6-DEC-82 15:45")

+    (JOIN
 '{DSK}TEST.SYSOUT '{DSK}TEST.DLBOOT])
+
+(SPLICES

+  [LAMBDA NIL
                                            (* JonL "22-NOV-82 17:29")

+    (PROG NIL
+      LP  (SPLICE
)
+          (LOGOUT)
+          (GO LP])
+)
+
+(RPAQQ BYTESPERPAGE
 512)
+(PUTPROPS SPLICE COPYRIGHT ("Venue & Xerox Corporation" 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (587 3467 (CLIP 597 . 834) (JJOIN 836 . 1051) (LSPLICE 1053 . 1211) (NCLIP 1213 . 2766) 
+(NSPLICE 2768 . 2950) (SPLICE 2952 . 3127) (SPLICEJ 3129 . 3284) (SPLICES 3286 . 3465)))))
+STOP

internal/library/TAR

@@ -1 +1,82 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+
(FILECREATED "26-Jun-90 19:28:14" |{DSK}<usr>local>lde>lispcore>internal>library>TAR.;2|
 3663   
+
+      |changes| |to:|  (VARS TARCOMS)
+
+      |previous| |date:| "31-Dec-00 17:55:22" |{DSK}<usr>local>lde>lispcore>internal>library>TAR.;1|
+)
+
+
+; Copyright (c) 1987, 1900, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT TARCOMS)
+
+(RPAQQ TARCOMS
 ((RECORDS TARHEADER)
+                    (FNS GATHER-NAME READ-TAR-FILE)))
+(DECLARE\: EVAL@COMPILE
+
+(BLOCKRECORD TARHEADER
 ((FILENAME BYTE 100)
+                            (MODE BYTE 8)
+                            (UID BYTE 8)
+                            (GID BYTE 8)
+                            (SIZE BYTE 12)
+                            (MTIME BYTE 12)
+                            (CHKSUM BYTE 8)
+                            (LINKFLAG BYTE)
+                            (LINKNAME BYTE 100)))
+)
+(DEFINEQ
+
+(GATHER-NAME

+  (LAMBDA (BASE OFFSET)
                                      (* \; "Edited 19-Oct-87 00:41 by jds")

+
+    (APPLY 'CONCAT (|bind|
 CH |for|
 I |from|
 OFFSET |to|
 100 |until|
 (ZEROP CH)
+                      |when|
 (NOT (ZEROP (SETQ CH (\\GETBASEBYTE BASE I))))
+                      |collect|
 (COND
+                                   ((IEQP CH (CHARCODE /))
+                                    ">")
+                                   ((IEQP CH (CHARCODE _))
+                                    "-")
+                                   (T (CHARACTER CH)))))))
+
+(READ-TAR-FILE

+  (LAMBDA (FILENAME START LIST-ONLY SKIP-EXISTING-FILES)
     (* \; "Edited 31-Dec-00 17:55 by jds")

+
+    (CL:WITH-OPEN-STREAM
+     (INSTREAM (OPENSTREAM FILENAME 'INPUT 'OLD '((SEQUENTIAL T)
+                                                  (BUFFERS 40))))
+     (LET* ((BUFFER (NCREATE 'VMEMPAGEP))
+            (SIZE-STRING (CL:MAKE-ARRAY 12 :ELEMENT-TYPE 'CL:STRING-CHAR :DISPLACED-TO-BASE
+                                (\\ADDBASE BUFFER 62)))
+            SIZE FILENAME OLDFPTR)
+          
+          (* |;;| "Read the file header:")

+
+           (SETFILEPTR INSTREAM (OR START 0))
+           (|while|
 (NOT (EOFP INSTREAM))
+              |do|
 (\\BINS INSTREAM BUFFER 0 512)
+                   (SETQ FILENAME (GATHER-NAME
 BUFFER 2))
+                   (SETQ SIZE (CL:WITH-INPUT-FROM-STRING (IN
 SIZE-STRING)
+                                     (LET ((*READTABLE* (FIND-READTABLE "XCL"))
+                                           (*READ-BASE* 8))
+                                          (CL:READ IN))))
+                   (PRINTOUT T "FILE:  " FILENAME ",  SIZE = " SIZE T)
+                   (COND
+                      ((AND (NOT LIST-ONLY)
+                            (> SIZE 0))
+                       (SETQ OLDFPTR (GETFILEPTR INSTREAM))
+                       (COND
+                          ((OR (NOT SKIP-EXISTING-FILES)
+                               (NOT (CL:PROBE-FILE FILENAME)))
+                           (CL:WITH-OPEN-STREAM (OUT (OPENSTREAM FILENAME 'OUTPUT 'NEW
+                                                            `((SEQUENTIAL T)
+                                                              (BUFFERS 40)
+                                                              (LENGTH ,SIZE))))
+                                  (COPYBYTES INSTREAM OUT SIZE))))
+                       (SETFILEPTR INSTREAM (+ OLDFPTR (ITIMES 512 (IQUOTIENT (+ SIZE 511)
+                                                                          512)))))))))))
+)
+(PUTPROPS TAR COPYRIGHT ("Venue & Xerox Corporation" 1987 1900 1990))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (944 3570 (GATHER-NAME 954 . 1560) (READ-TAR-FILE 1562 . 3568)))))
+STOP

internal/library/TYPEHAX

@@ -1 +1,70 @@
-
(FILECREATED "30-Sep-86 18:49:53" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;4
 3701   
+
(FILECREATED "30-Sep-86 18:49:53" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;4
 3701   
+
+      changes to:  (VARS TYPEHAXCOMS)
+                   (FUNCTIONS COLLECT-SUPER-CHAIN TEST-TYPEP ALLOCATE-WITH-NAME ALLOCATE-SUPER-CHAIN 
+                          ALLOCATE-11-BIT-TYPES ALLOCATE-TO-TYPE-NUMBER)
+
+      previous date: "30-Sep-86 15:05:33" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;1)
+
+
+(PRETTYCOMPRINT TYPEHAXCOMS)
+
+(RPAQQ TYPEHAXCOMS
 ((FUNCTIONS ALLOCATE-11-BIT-TYPES ALLOCATE-SUPER-CHAIN ALLOCATE-TO-TYPE-NUMBER 
+                           ALLOCATE-WITH-NAME COLLECT-SUPER-CHAIN TEST-TYPEP)))
+(DEFUN ALLOCATE-11-BIT-TYPES
 NIL (ALLOCATE-TO-TYPENUMBER 1023)

+                                                  (* ;;; 
+
      "allocates typenumber 1023, then allocates a type named %"realbig%", and checks it's instances")

+                                 (ALLOCATE-WITH-NAME (QUOTE REALBIG))
+                                 (CL:SETQ AREALBIG (NCREATE (QUOTE REALBIG)))
+                                 (TYPENAMEP AREALBIG (QUOTE REALBIG))
+                                 (EQ (NTYPX AREALBIG)
+                                     1024))
+
+(DEFUN ALLOCATE-SUPER-CHAIN
 (DEPTH &OPTIONAL (SUPER* (QUOTE SUPER*-TYPE))
+                                   (ROOT (QUOTE ROOT-TYPE))) 

+                                                  (* ;;; 
+
                                                  "Allocates datatypes up to datatype x inclusive.")

+   (LET ((SUPER (CAAR (DECLAREDATATYPE SUPER* (QUOTE (POINTER))
+                             NIL NIL NIL))))
+        (DOTIMES (I (- DEPTH 1))
+               (SETQ SUPER (CAAR (DECLAREDATATYPE (GENSYM (QUOTE TEST))
+                                        (QUOTE (POINTER))
+                                        NIL NIL SUPER))))
+        (DECLAREDATATYPE ROOT (QUOTE (POINTER))
+               NIL NIL SUPER)))
+
+(DEFUN ALLOCATE-TO-TYPE-NUMBER
 (X) 
               (* ;;; 
+
                                                  "Allocates datatypes up to datatype x inclusive.")

+   (LET ((REMAINING (- X \MaxTypeNumber)))
+        (CL:IF (< REMAINING 1)
+               (CL:ERROR "There are already ~D datatypes." \MaxTypeNumber)
+               (PROGN (DECLAREDATATYPE (QUOTE TEST-SUPER)
+                             (QUOTE (POINTER))
+                             NIL NIL)
             (* ;; "declare a super for the rest of the types.")

+                      (DOTIMES (I REMAINING)
+                             (DECLAREDATATYPE (GENSYM (QUOTE TEST))
+                                    (QUOTE (POINTER))
+                                    NIL NIL (QUOTE TEST-SUPER)))))))
+
+(DEFUN ALLOCATE-WITH-NAME
 (TYPENAME &OPTIONAL (SUPER (QUOTE TEST-SUPER)))
+   (ETYPECASE TYPENAME (SYMBOL (DECLAREDATATYPE TYPENAME (QUOTE (POINTER))
+                                      NIL NIL SUPER))))
+
+(DEFUN COLLECT-SUPER-CHAIN
 (ROOT) (CL:DO* ((TYPE ROOT SUPER)
+                                           (SUPER (GETSUPERTYPE TYPE)
+                                                  (GETSUPERTYPE TYPE))
+                                           (SUPER-CHAIN NIL))
+                                         ((NULL SUPER)
+                                          SUPER-CHAIN)
+                                         (CL:PUSH SUPER SUPER-CHAIN)))
+
+(DEFUN TEST-TYPEP
 (TYPE) 
                         (* ;;; 
+
                                "ensures that instances of TYPE are instances of all its supertypes.")

+   (LET ((INSTANCE (NCREATE TYPE)))
+        (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPE)
+                                       (TYPEP INSTANCE TYPE)))
+               (COLLECT-SUPER-CHAIN TYPE))))
+
+(DECLARE: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

internal/test/GC/Hand/MAIKO-GC-TESTS.~1~

@@ -1,920 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
(FILECREATED "23-Jun-88 16:06:34" {ERIS}<TEST>GC>HAND>MAIKO-GC-TESTS.\;6
 46489  
-
-      |changes| |to:|  (VARS MAIKO-GC-TESTSCOMS)
-                       (FNS MAIN-GC-TEST ARRAY-STRING-TEST VARIOUS-TYPES-TEST LIST-MANIPULATION-TEST
-                            CODE-RECLAIM-TEST)
-
-      |previous| |date:| "27-May-88 14:59:01" {ERIS}<TEST>GC>HAND>MAIKO-GC-TESTS.\;5)
-
-
-; Copyright (c) 1988 by John Sybalsky & Xerox Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT MAIKO-GC-TESTSCOMS)
-
-(RPAQQ MAIKO-GC-TESTSCOMS
 
-       ((FILES DANCEROBJ GCHAX)
-        (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}<TEST>GC>HAND-AUX>" 
-                        "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>")
-               (INTERPRESSFONTDIRECTORIES "{ERIS}<TEST>GC>HAND-AUX>" 
-                      "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>"))
-        (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)))
-        (FNS MAIN-GC-TEST)
-        (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS 
-             ARRAY-STRING-TEST VARIOUS-TYPES-TEST)
-        (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST)
-        (FNS ATOM-FULL-TEST STORAGE-FULL-TEST)
-        (COMS (FNS DATATYPE-TEST)
-              (RECORDS GC-TEST-TYPE)
-              
-              (* |;;| "DATATYPE TESTS")

-)
-        (COMS
-         
-         (* |;;| "CODE RECLAIMATION TESTS")

-
-         (FNS CODE-RECLAIM-TEST)
-         
-         (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.")

-
-         (VARS (CODE-RECLAIM-TEST-TEMP-FN
-                '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN
-                           (ASDF)
-                           (LET (I)
-                                (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5))
-                                (ERSETQ (DATE))
-                                (NLSETQ (DATE))
-                                (ERSETQ (DATE))
-                                (NLSETQ (DATE))
-                                (ERSETQ (DATE))
-                                (CL:FLET ((TEMP (ARG)
-                                                (SETQ ARG (FLOAT ARG))
-                                                (EXPT (SQRT I)
-                                                      (SQRT (COS (/ I 180))))))
-                                       (CL:UNWIND-PROTECT
-                                           (FOR I FROM 1 TO 1000 COLLECT (TEMP I))
-                                           (SETQ I NIL)))))))))))
-
-(FILESLOAD DANCEROBJ GCHAX)
-
-(ADDTOVAR DISPLAYFONTDIRECTORIES
 "{ERIS}<TEST>GC>HAND-AUX>" "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>")
-
-(ADDTOVAR INTERPRESSFONTDIRECTORIES
 "{ERIS}<TEST>GC>HAND-AUX>" 
-                                              "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>")
-
-(SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))
-(DEFINEQ
-
-(MAIN-GC-TEST

-  (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT
-                 CODE-COUNT)
                             (* \; "Edited 23-Jun-88 13:30 by jds")

-    (DRIBBLE (OR DRIBBLE-FILE "{LPT}"))
-    (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE)
-           T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}")
-           T T)
-    (|for|
 I |from|
 1 |to|
 (OR LIMIT 10) |do|
 (PRINTOUT T 
-                                                                     "Starting Maiko GC tests, pass "
-                                                                     I T)
-                                                           (ITEMS-ON-STACK-TEST
 (OR STACK-COUNT 
-                                                                                        100))
-                                                           (MANY-BIGNUM-MAKER
 (OR BIGNUM-COUNT 
-                                                                                      1000))
-                                                           (MANY-FIXP-MAKER
 (OR FIXP-COUNT 1000))
-                                                           (MANY-FLOAT-MAKER
 (OR FLOAT-COUNT 1000
-                                                                                     ))
-                                                           (TEDIT-CRUNCH-TEST
 (OR TEDIT-COUNT 5))
-                                                           (ARRAY-STRING-TEST
 3)
-                                                           (LIST-MANIPULATION-TEST
 (OR LIST-COUNT
-                                                                                           5))
-                                                           (BOUNDARY-TESTS
)
-                                                           (CODE-RECLAIM-TEST
 (OR CODE-COUNT 20))
-                                                           (VARIOUS-TYPES-TEST
 (OR TYPE-COUNT 10)
-                                                                  )
-                                                           (FRPTQ 100 (RECLAIM))
-                                                           (STORAGE))
-    (ATOM-FULL-TEST
)
-    (STORAGE-FULL-TEST
)
-    (DRIBBLE NIL)))
-)
-(DEFINEQ
-
-(ITEMS-ON-STACK-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:56 by jds")

-    (PRINTOUT T "   Starting ITEMS-ON-STACK test for " LIMIT " iterations." T)
-    (FOR
 I FROM
 1 TO
 LIMIT DO
 (LET ((X (CREATE
 CHARLOOKS))
-                                                    (Y (EXPT 1234.5 (RAND 3 7))))
-                                                   (ERSETQ (FRPTQ 5 (RECLAIM))
-                                                          (COND
-                                                             ((\\ISONFREELIST X)
-                                                              (HELP 
-                                                                "X is free, but pointer is on stack."
-                                                                    ))
-                                                             ((\\ISONFREELIST Y)
-                                                              (HELP 
-                                                                "Y is free, but pointer is on stack."
-                                                                    ))))))))
-
-(MANY-BIGNUM-MAKER

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:54 by jds")

-    (PRINTOUT T "   Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T)
-    (LET (X Y Z W)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (SETQ X (CL:* 12345678901234567890
-                                                                 (RAND 1 I)))
-                                                  (SETQ Y (IQUOTIENT X 3))
-                                                  (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7)
-                                                                 (IREMAINDER Y 3)
-                                                                 (CL:FLOOR Y 2)
-                                                                 (CL:CEILING X 8)))
-                                                  (SETQ W (/ Z Y))))))
-
-(MANY-FIXP-MAKER

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:54 by jds")

-    (PRINTOUT T "   Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T)
-    (LET (X Y Z W)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (SETQ X (CL:* 543 (RAND 1 I)))
-                                                  (SETQ Y (IQUOTIENT X 3))
-                                                  (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7)
-                                                                 (IREMAINDER Y 3)
-                                                                 (CL:FLOOR Y 2)
-                                                                 (CL:CEILING X 8)))
-                                                  (SETQ W (/ Z Y))))))
-
-(MANY-FLOAT-MAKER

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:55 by jds")

-    (PRINTOUT T "   Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T)
-    (LET (X Y Z W)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (SETQ X (FTIMES 1.0 (RAND 0 1)))
-                                                  (SETQ Y (+ (SQRT I)
-                                                             (EXPT (SQRT (SQRT I))
-                                                                   3.4)))
-                                                  (SETQ Z (LOG Y))))))
-
-(BOUNDARY-TESTS

-  (LAMBDA NIL
                                            (* \; "Edited 26-May-88 11:54 by jds")

-
-    (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.")

-
-    (PRINTOUT T "  Starting Refcnt-63 crossing test" T)
-    (LET* ((ITEM (|create|
 FMTSPEC))
-           (LIST (|for|
 I |from|
 1 |to|
 62 |collect|
 ITEM)))
-          (|for|
 I |from|
 1 |to|
 1000 |do|
 (|for|
 J |from|
 (LENGTH LIST)
-                                                              |to|
 (+ 63 (RAND 1 10))
-                                                              |do|
 (SETQ LIST (CONS ITEM LIST)))
-                                                        (|for|
 J |from|
 (LENGTH LIST)
-                                                           |to|
 (- 63 (RAND 3 12))
-                                                           |do|
 (|pop|
 LIST))
-                                                        (COND
-                                                           ((ZEROP (IMOD I 31))
-                                                            (RECLAIM))))
-          (PRINTOUT T "  Starting Refcount-500K <-> NIL test." T)
-          (|for|
 LOOP |from|
 1 |to|
 10 |do|
 (|for|
 I |from|
 1 |to|
 500000
-                                                               |do|
 (SETQ LIST (CONS ITEM LIST)))
-                                                         (SETQ LIST NIL))
-          (PRINTOUT T "  Starting Refcount 1-2 boundary test." T)
-          (LET ((ITEM (LIST (|create|
 FMTSPEC))))
-               (|for|
 I |from|
 1 |to|
 5000 |do|
 (SETQ ITEM2 (CAR ITEM))
-                                                             (SETQ ITEM2 NIL)))
-          (PRINTOUT T "  Starting Refcount 1 + stack boundary test." T)
-          (LET ((ITEM (|create|
 FMTSPEC))
-                ITEM2)
-               (|for|
 I |from|
 1 |to|
 5000 |do|
 (SETQ ITEM2 (LIST ITEM))
-                                                             (RPLACA ITEM2 NIL)))
-          (PRINTOUT T "  Starting Refcount 0-1 boundary test." T)
-          (LET (ITEM)
-               (|for|
 I |from|
 1 |to|
 5000 |do|
 (SETQ ITEM (LIST (|create|
 
-                                                                                        FMTSPEC)))
-                                                             (RPLACA ITEM NIL))))))
-
-(ARRAY-STRING-TEST

-  (LAMBDA (LIMIT REAL-STRESS)
                            (* \; "Edited 23-Jun-88 12:23 by jds")

-
-    (* |;;| "Try out array & string creation, and substringing on the GC.")

-
-    (PRINTOUT T "  Starting Array & String test." T)
-    (FOR
 I FROM
 1 TO
 (OR LIMIT 10)
-       DO
 (LET (STRINGS ARRAYS)
-                   (FOR
 ARRAY-COUNT FROM
 1 TO
 5000
-                      COLLECT
 (CL:MAKE-ARRAY (RAND 10 (COND
-                                                             (REAL-STRESS 65000)
-                                                             (T (IMAX 100 (IQUOTIENT 65000 
-                                                                                 ARRAY-COUNT)))))))
-                   (FOR
 I FROM
 1 TO
 5000 COLLECT
 (BITMAPCREATE (RAND 1 512)
-                                                                        (RAND 1 512)))
-                   (SETQ STRINGS (FOR
 STRING-COUNT FROM
 1 TO
 5000
-                                    COLLECT
 (ALLOCSTRING (RAND 10
-                                                                   (COND
-                                                                      (REAL-STRESS 65000)
-                                                                      (T (IMAX 100 (IQUOTIENT 65000 
-                                                                                         STRING-COUNT
-                                                                                          ))))))))
-                   (FOR
 STRING IN
 STRINGS
-                      COLLECT
 (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING)
-                                                                  1))
-                                         (RAND (ADD1 (LRSH (NCHARS STRING)
-                                                           1))
-                                               (NCHARS STRING))))))))
-
-(VARIOUS-TYPES-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 23-Jun-88 12:04 by jds")

-
-    (* |;;| 
-
  "Run thru creation and collection of various types that have caused trouble in the past. ")

-
-    (PRINTOUT T "  Starting various type cases." T)
-    (FOR
 REPEAT-COUNT FROM
 1 TO
 (OR LIMIT 10)
-       DO
 (|for|
 TYPE IN
 '(VMEMPAGEP) AS
 CREATION-LIMIT IN
 '(100)
-                 |do|
 (FOR
 I FROM
 1 TO
 CREATION-LIMIT COLLECT
 (NCREATE TYPE))
-                       (DORECLAIM)))))
-)
-(DEFINEQ
-
-(TEDIT-CRUNCH-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 27-May-88 13:06 by jds")

-
-    (* |;;| "GC Testing -- stressing the world.")

-
-    (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.")

-
-    (PRINTOUT T "   Starting TEDIT-CRUNCH test for " LIMIT " iterations." T)
-    (FOR
 PASS FROM
 1 TO
 LIMIT DO
 (PRINTOUT T "    Round " PASS " started " (DATE)
-                                                        "." T)
-                                                (LET ((TS (OPENTEXTSTREAM 
-                                                                 '
-                                                          |{ERIS}<Test>GC>Hand-Aux>ADVDICT-N-Z.TEDIT|
-                                                                 ))
-                                                      TLIST)
-                                                     (TEDIT.HARDCOPY TS '{CORE}FOO.IP T)
-                                                     (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP)
-                                                     (DELFILE '{DSK}FOO.IP)
-                                                     (DELFILE '{CORE}FOO.IP)
-                                                     (CLOSEF (FETCH
 (TEXTOBJ TXTFILE)
-                                                                OF
 (TEXTOBJ TS)))))))
-
-(LIST-MANIPULATION-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 23-Jun-88 14:03 by jds")

-
-    (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.")

-
-    (PRINTOUT T "   Starting LIST-MANIPULATION test for " LIMIT " iterations." T)
-    (|for|
 PASS |from|
 1 |to|
 LIMIT
-       |do|
 (PRINTOUT T "    Round " PASS " started " (DATE)
-                       "." T)
-             (LET ((TS (OPENTEXTSTREAM '|{ERIS}<sybalsky>Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|))
-                   (LEN (RAND 0 100000))
-                   TLIST)
-                  (SETQ TLIST (|for|
 I |from|
 1 |to|
 LEN |collect|
 TS))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH LEN 1)))
-                     |do|
 (|pop|
 TLIST))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 100) |do|
 (SETQ TLIST
-                                                                            (CONS TS TLIST)))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST)
-                                                                           1)))
-                     |do|
 (|pop|
 TLIST))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 2000) |do|
 (SETQ TLIST
-                                                                             (CONS TS TLIST)))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST)
-                                                                           1)))
-                     |do|
 (|pop|
 TLIST))
-                  (|for|
 \i |from|
 1 |to|
 (RAND 1 1500)
-                     |do|
 (SETQ TLIST (NCONC TLIST
-                                                 (|for|
 J |from|
 1
-                                                    |to|
 (RAND 1 10)
-                                                    |join|
 (|for|
 K |from|
 1 |to|

-                                                                                         3
-                                                                  |collect|
 (CONS TS K))))))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST)
-                                                                           1)))
-                     |do|
 (|pop|
 TLIST))
-                  (CLOSEF (|fetch|
 (TEXTOBJ TXTFILE) |of|
 (TEXTOBJ TS))))
-             (LET ((GC-ITEM (NCREATE 'VMEMPAGEP))
-                   (LEN (RAND 10 500))
-                   TLIST ELT)
-                  (SETQ TLIST (|for|
 I |from|
 1 |to|
 LEN |collect|
 NIL))
-                  (|for|
 I |from|
 1 |to|
 LEN |do|
 (SETQ ELT (CL:RANDOM LEN))
-                                                               (RPLACA (CL:NTHCDR ELT TLIST)
-                                                                      GC-ITEM)
-                                                               (RPLACA (CL:NTHCDR (SUB1 I)
-                                                                              TLIST)
-                                                                      GC-ITEM))
-                  (|for|
 I |from|
 (SUB1 LEN) |to|
 0 |by|
 -1
-                     |do|
 (RPLACD (CL:NTHCDR I TLIST)
-                                     GC-ITEM))))))
-)
-(DEFINEQ
-
-(ATOM-FULL-TEST

-  (LAMBDA NIL
                                            (* \; "Edited 26-May-88 11:39 by jds")

-    (PRINTOUT T "  Starting ATOM-space full test.")
-    (LET ((CUR-ATOM-COUNT |\\AtomFrLst|))
-         (CL:UNWIND-PROTECT
-             (PROGN (SETQ |\\AtomFrLst| 64000)
-                    (FOR
 I FROM
 64000 TO
 70000 DO
 (GENSYM 'GC-TEST)))
-             (SETQ |\\AtomFrLst| CUR-ATOM-COUNT)))))
-
-(STORAGE-FULL-TEST

-  (LAMBDA NIL
                                            (* \; "Edited 26-May-88 11:47 by jds")

-    (PRINTOUT T "  Starting Storage-full test." T)
-    (ERSETQ (FOR
 I FROM
 1 COLLECT
 (ARRAY 100)))))
-)
-(DEFINEQ
-
-(DATATYPE-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 26-May-88 11:26 by jds")

-    (FOR
 I FROM
 1 TO
 (OR LIMIT 10)
-       DO
 (FOR
 L FROM
 1 TO
 100 DO
 (FOR
 Y FROM
 1 TO
 20
-                                                         COLLECT
 (CREATE
 GC-TEST-TYPE
-                                                                            FIELD-1 _ T))
-                                                     (RECLAIM)))))
-)
-(DECLARE\: EVAL@COMPILE
-
-(DATATYPE GC-TEST-TYPE
 (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE)
-                                  (FIELD-5 FIXP)
-                                  FIELD-6
-                                  (FIELD-7 WORD)
-                                  FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14
-                                                                                       FIXP)
-                                  FIELD-15
-                                  (FIELD-16 XPOINTER)
-                                  FIELD-17
-                                  (FIELD-18 BYTE)
-                                  (FIELD-19 FIXP)
-                                  FIELD-20
-                                  (FIELD-21 BYTE)
-                                  FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE)
-                                  FIELD-26
-                                  (FIELD-27 BYTE)
-                                  FIELD-28
-                                  (FIELD-29 BYTE)
-                                  FIELD-30
-                                  (FIELD-31 WORD)
-                                  FIELD-32
-                                  (FIELD-33 XPOINTER)
-                                  FIELD-34
-                                  (FIELD-35 FIXP)
-                                  FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG)
-                                  FIELD-40
-                                  (FIELD-41 FLAG)
-                                  FIELD-42
-                                  (FIELD-43 FIXP)
-                                  (FIELD-44 FIXP)
-                                  FIELD-45
-                                  (FIELD-46 XPOINTER)
-                                  FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG)
-                                  (FIELD-51 BYTE)
-                                  FIELD-52 FIELD-53 (FIELD-54 BYTE)
-                                  FIELD-55 FIELD-56 (FIELD-57 BYTE)
-                                  (FIELD-58 WORD)
-                                  FIELD-59 FIELD-60 (FIELD-61 XPOINTER)
-                                  FIELD-62 FIELD-63 (FIELD-64 XPOINTER)
-                                  (FIELD-65 XPOINTER)
-                                  FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG)
-                                  FIELD-71 FIELD-72 (FIELD-73 WORD)
-                                  FIELD-74
-                                  (FIELD-75 FLAG)
-                                  FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP)
-                                  (FIELD-81 FIXP)
-                                  FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER)
-                                  (FIELD-87 BYTE)
-                                  (FIELD-88 XPOINTER)
-                                  FIELD-89
-                                  (FIELD-90 BYTE)
-                                  (FIELD-91 FLAG)
-                                  (FIELD-92 FIXP)
-                                  (FIELD-93 FIXP)
-                                  (FIELD-94 FLAG)
-                                  FIELD-95
-                                  (FIELD-96 FLAG)
-                                  FIELD-97
-                                  (FIELD-98 FLAG)
-                                  FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 
-                                                                                          XPOINTER)
-                                  FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE)
-                                  FIELD-110
-                                  (FIELD-111 WORD)
-                                  FIELD-112
-                                  (FIELD-113 XPOINTER)
-                                  (FIELD-114 FLAG)
-                                  (FIELD-115 FIXP)
-                                  FIELD-116 FIELD-117 (FIELD-118 BYTE)
-                                  FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 
-                                                                                           XPOINTER)
-                                  (FIELD-125 BYTE)
-                                  (FIELD-126 XPOINTER)
-                                  FIELD-127 FIELD-128 (FIELD-129 FIXP)
-                                  (FIELD-130 FLAG)
-                                  FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD)
-                                  (FIELD-136 FLAG)
-                                  FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD)
-                                  (FIELD-141 FLAG)
-                                  FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP)
-                                  FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG)
-                                  FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP)
-                                  FIELD-156
-                                  (FIELD-157 BYTE)
-                                  FIELD-158
-                                  (FIELD-159 FIXP)
-                                  (FIELD-160 WORD)
-                                  FIELD-161
-                                  (FIELD-162 WORD)
-                                  (FIELD-163 FIXP)
-                                  FIELD-164
-                                  (FIELD-165 FIXP)
-                                  FIELD-166
-                                  (FIELD-167 FLAG)
-                                  (FIELD-168 BYTE)
-                                  FIELD-169 FIELD-170 (FIELD-171 XPOINTER)
-                                  (FIELD-172 BYTE)
-                                  FIELD-173 FIELD-174 (FIELD-175 FLAG)
-                                  (FIELD-176 BYTE)
-                                  (FIELD-177 WORD)
-                                  FIELD-178
-                                  (FIELD-179 FIXP)
-                                  FIELD-180 FIELD-181 (FIELD-182 BYTE)
-                                  FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE)
-                                  (FIELD-189 FIXP)
-                                  FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE)
-                                  FIELD-194
-                                  (FIELD-195 WORD)
-                                  FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD)
-                                  FIELD-201
-                                  (FIELD-202 FLAG)
-                                  FIELD-203
-                                  (FIELD-204 XPOINTER)
-                                  FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG)
-                                  FIELD-209
-                                  (FIELD-210 WORD)
-                                  (FIELD-211 BYTE)
-                                  FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP)
-                                  FIELD-216 FIELD-217 (FIELD-218 XPOINTER)
-                                  FIELD-219
-                                  (FIELD-220 FLAG)
-                                  FIELD-221
-                                  (FIELD-222 FLAG)
-                                  (FIELD-223 WORD)
-                                  (FIELD-224 FLAG)
-                                  (FIELD-225 WORD)
-                                  FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 
-                                                                                           XPOINTER)
-                                  FIELD-232
-                                  (FIELD-233 WORD)
-                                  (FIELD-234 WORD)
-                                  FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 
-                                  FIELD-241 (FIELD-242 XPOINTER)
-                                  FIELD-243
-                                  (FIELD-244 WORD)
-                                  FIELD-245 FIELD-246 (FIELD-247 XPOINTER)
-                                  FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 
-                                  FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER)
-                                  FIELD-259
-                                  (FIELD-260 FIXP)
-                                  FIELD-261 FIELD-262 (FIELD-263 XPOINTER)
-                                  FIELD-264
-                                  (FIELD-265 WORD)
-                                  (FIELD-266 FLAG)
-                                  FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE)
-                                  FIELD-273 FIELD-274 (FIELD-275 FLAG)
-                                  (FIELD-276 BYTE)
-                                  FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER)
-                                  (FIELD-281 WORD)
-                                  (FIELD-282 WORD)
-                                  FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD)
-                                  FIELD-287
-                                  (FIELD-288 XPOINTER)
-                                  (FIELD-289 BYTE)
-                                  FIELD-290
-                                  (FIELD-291 XPOINTER)
-                                  (FIELD-292 FLAG)
-                                  FIELD-293 FIELD-294 (FIELD-295 FLAG)
-                                  FIELD-296 FIELD-297 (FIELD-298 XPOINTER)
-                                  (FIELD-299 FIXP)
-                                  (FIELD-300 FIXP)
-                                  (FIELD-301 BYTE)
-                                  FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP)
-                                  FIELD-307
-                                  (FIELD-308 FLAG)
-                                  (FIELD-309 FIXP)
-                                  FIELD-310
-                                  (FIELD-311 XPOINTER)
-                                  FIELD-312 FIELD-313 (FIELD-314 BYTE)
-                                  FIELD-315
-                                  (FIELD-316 WORD)
-                                  (FIELD-317 FIXP)
-                                  FIELD-318
-                                  (FIELD-319 FLAG)
-                                  FIELD-320
-                                  (FIELD-321 WORD)))
-)
-
-(/DECLAREDATATYPE 'GC-TEST-TYPE
-       '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER 
-               POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER 
-               BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER 
-               POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER 
-               POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER 
-               XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG 
-               POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER 
-               POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG 
-               POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER 
-               POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER 
-               BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER 
-               FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG
-               POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER 
-               POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP 
-               POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER
-               FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER 
-               POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG 
-               POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER 
-               POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER
-               POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER
-               POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER 
-               POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER 
-               POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD 
-               WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER
-               POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER 
-               FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER
-               FLAG POINTER WORD)
-       '((GC-TEST-TYPE 0 POINTER)
-         (GC-TEST-TYPE 2 POINTER)
-         (GC-TEST-TYPE 4 POINTER)
-         (GC-TEST-TYPE 4 (BITS . 7))
-         (GC-TEST-TYPE 6 FIXP)
-         (GC-TEST-TYPE 8 POINTER)
-         (GC-TEST-TYPE 10 (BITS . 15))
-         (GC-TEST-TYPE 12 POINTER)
-         (GC-TEST-TYPE 14 POINTER)
-         (GC-TEST-TYPE 16 POINTER)
-         (GC-TEST-TYPE 18 POINTER)
-         (GC-TEST-TYPE 20 POINTER)
-         (GC-TEST-TYPE 22 POINTER)
-         (GC-TEST-TYPE 24 FIXP)
-         (GC-TEST-TYPE 26 POINTER)
-         (GC-TEST-TYPE 28 XPOINTER)
-         (GC-TEST-TYPE 30 POINTER)
-         (GC-TEST-TYPE 30 (BITS . 7))
-         (GC-TEST-TYPE 32 FIXP)
-         (GC-TEST-TYPE 34 POINTER)
-         (GC-TEST-TYPE 34 (BITS . 7))
-         (GC-TEST-TYPE 36 POINTER)
-         (GC-TEST-TYPE 38 POINTER)
-         (GC-TEST-TYPE 40 POINTER)
-         (GC-TEST-TYPE 40 (BITS . 7))
-         (GC-TEST-TYPE 42 POINTER)
-         (GC-TEST-TYPE 42 (BITS . 7))
-         (GC-TEST-TYPE 44 POINTER)
-         (GC-TEST-TYPE 44 (BITS . 7))
-         (GC-TEST-TYPE 46 POINTER)
-         (GC-TEST-TYPE 11 (BITS . 15))
-         (GC-TEST-TYPE 48 POINTER)
-         (GC-TEST-TYPE 50 XPOINTER)
-         (GC-TEST-TYPE 52 POINTER)
-         (GC-TEST-TYPE 54 FIXP)
-         (GC-TEST-TYPE 56 POINTER)
-         (GC-TEST-TYPE 58 POINTER)
-         (GC-TEST-TYPE 60 POINTER)
-         (GC-TEST-TYPE 60 (FLAGBITS . 0))
-         (GC-TEST-TYPE 62 POINTER)
-         (GC-TEST-TYPE 62 (FLAGBITS . 0))
-         (GC-TEST-TYPE 64 POINTER)
-         (GC-TEST-TYPE 66 FIXP)
-         (GC-TEST-TYPE 68 FIXP)
-         (GC-TEST-TYPE 70 POINTER)
-         (GC-TEST-TYPE 72 XPOINTER)
-         (GC-TEST-TYPE 74 POINTER)
-         (GC-TEST-TYPE 76 POINTER)
-         (GC-TEST-TYPE 78 POINTER)
-         (GC-TEST-TYPE 78 (FLAGBITS . 0))
-         (GC-TEST-TYPE 76 (BITS . 7))
-         (GC-TEST-TYPE 80 POINTER)
-         (GC-TEST-TYPE 82 POINTER)
-         (GC-TEST-TYPE 82 (BITS . 7))
-         (GC-TEST-TYPE 84 POINTER)
-         (GC-TEST-TYPE 86 POINTER)
-         (GC-TEST-TYPE 86 (BITS . 7))
-         (GC-TEST-TYPE 88 (BITS . 15))
-         (GC-TEST-TYPE 90 POINTER)
-         (GC-TEST-TYPE 92 POINTER)
-         (GC-TEST-TYPE 94 XPOINTER)
-         (GC-TEST-TYPE 96 POINTER)
-         (GC-TEST-TYPE 98 POINTER)
-         (GC-TEST-TYPE 100 XPOINTER)
-         (GC-TEST-TYPE 102 XPOINTER)
-         (GC-TEST-TYPE 104 POINTER)
-         (GC-TEST-TYPE 106 POINTER)
-         (GC-TEST-TYPE 108 POINTER)
-         (GC-TEST-TYPE 110 POINTER)
-         (GC-TEST-TYPE 110 (FLAGBITS . 0))
-         (GC-TEST-TYPE 112 POINTER)
-         (GC-TEST-TYPE 114 POINTER)
-         (GC-TEST-TYPE 89 (BITS . 15))
-         (GC-TEST-TYPE 116 POINTER)
-         (GC-TEST-TYPE 116 (FLAGBITS . 0))
-         (GC-TEST-TYPE 118 POINTER)
-         (GC-TEST-TYPE 120 POINTER)
-         (GC-TEST-TYPE 122 POINTER)
-         (GC-TEST-TYPE 124 POINTER)
-         (GC-TEST-TYPE 126 FIXP)
-         (GC-TEST-TYPE 128 FIXP)
-         (GC-TEST-TYPE 130 POINTER)
-         (GC-TEST-TYPE 132 POINTER)
-         (GC-TEST-TYPE 134 POINTER)
-         (GC-TEST-TYPE 136 POINTER)
-         (GC-TEST-TYPE 138 XPOINTER)
-         (GC-TEST-TYPE 138 (BITS . 7))
-         (GC-TEST-TYPE 140 XPOINTER)
-         (GC-TEST-TYPE 142 POINTER)
-         (GC-TEST-TYPE 142 (BITS . 7))
-         (GC-TEST-TYPE 140 (FLAGBITS . 0))
-         (GC-TEST-TYPE 144 FIXP)
-         (GC-TEST-TYPE 146 FIXP)
-         (GC-TEST-TYPE 140 (FLAGBITS . 16))
-         (GC-TEST-TYPE 148 POINTER)
-         (GC-TEST-TYPE 148 (FLAGBITS . 0))
-         (GC-TEST-TYPE 150 POINTER)
-         (GC-TEST-TYPE 150 (FLAGBITS . 0))
-         (GC-TEST-TYPE 152 POINTER)
-         (GC-TEST-TYPE 154 POINTER)
-         (GC-TEST-TYPE 156 POINTER)
-         (GC-TEST-TYPE 158 POINTER)
-         (GC-TEST-TYPE 160 POINTER)
-         (GC-TEST-TYPE 162 XPOINTER)
-         (GC-TEST-TYPE 164 POINTER)
-         (GC-TEST-TYPE 166 POINTER)
-         (GC-TEST-TYPE 168 POINTER)
-         (GC-TEST-TYPE 170 POINTER)
-         (GC-TEST-TYPE 170 (BITS . 7))
-         (GC-TEST-TYPE 172 POINTER)
-         (GC-TEST-TYPE 174 (BITS . 15))
-         (GC-TEST-TYPE 176 POINTER)
-         (GC-TEST-TYPE 178 XPOINTER)
-         (GC-TEST-TYPE 178 (FLAGBITS . 0))
-         (GC-TEST-TYPE 180 FIXP)
-         (GC-TEST-TYPE 182 POINTER)
-         (GC-TEST-TYPE 184 POINTER)
-         (GC-TEST-TYPE 184 (BITS . 7))
-         (GC-TEST-TYPE 186 POINTER)
-         (GC-TEST-TYPE 188 POINTER)
-         (GC-TEST-TYPE 190 POINTER)
-         (GC-TEST-TYPE 192 POINTER)
-         (GC-TEST-TYPE 194 POINTER)
-         (GC-TEST-TYPE 196 XPOINTER)
-         (GC-TEST-TYPE 196 (BITS . 7))
-         (GC-TEST-TYPE 198 XPOINTER)
-         (GC-TEST-TYPE 200 POINTER)
-         (GC-TEST-TYPE 202 POINTER)
-         (GC-TEST-TYPE 204 FIXP)
-         (GC-TEST-TYPE 202 (FLAGBITS . 0))
-         (GC-TEST-TYPE 206 POINTER)
-         (GC-TEST-TYPE 208 POINTER)
-         (GC-TEST-TYPE 210 POINTER)
-         (GC-TEST-TYPE 212 POINTER)
-         (GC-TEST-TYPE 175 (BITS . 15))
-         (GC-TEST-TYPE 212 (FLAGBITS . 0))
-         (GC-TEST-TYPE 214 POINTER)
-         (GC-TEST-TYPE 216 POINTER)
-         (GC-TEST-TYPE 218 POINTER)
-         (GC-TEST-TYPE 220 (BITS . 15))
-         (GC-TEST-TYPE 218 (FLAGBITS . 0))
-         (GC-TEST-TYPE 222 POINTER)
-         (GC-TEST-TYPE 224 POINTER)
-         (GC-TEST-TYPE 226 POINTER)
-         (GC-TEST-TYPE 228 FIXP)
-         (GC-TEST-TYPE 230 POINTER)
-         (GC-TEST-TYPE 232 POINTER)
-         (GC-TEST-TYPE 234 POINTER)
-         (GC-TEST-TYPE 236 POINTER)
-         (GC-TEST-TYPE 236 (FLAGBITS . 0))
-         (GC-TEST-TYPE 238 POINTER)
-         (GC-TEST-TYPE 240 POINTER)
-         (GC-TEST-TYPE 242 POINTER)
-         (GC-TEST-TYPE 244 POINTER)
-         (GC-TEST-TYPE 246 FIXP)
-         (GC-TEST-TYPE 248 POINTER)
-         (GC-TEST-TYPE 248 (BITS . 7))
-         (GC-TEST-TYPE 250 POINTER)
-         (GC-TEST-TYPE 252 FIXP)
-         (GC-TEST-TYPE 221 (BITS . 15))
-         (GC-TEST-TYPE 254 POINTER)
-         (GC-TEST-TYPE 256 (BITS . 15))
-         (GC-TEST-TYPE 257 FIXP)
-         (GC-TEST-TYPE 260 POINTER)
-         (GC-TEST-TYPE 262 FIXP)
-         (GC-TEST-TYPE 264 POINTER)
-         (GC-TEST-TYPE 264 (FLAGBITS . 0))
-         (GC-TEST-TYPE 260 (BITS . 7))
-         (GC-TEST-TYPE 266 POINTER)
-         (GC-TEST-TYPE 268 POINTER)
-         (GC-TEST-TYPE 270 XPOINTER)
-         (GC-TEST-TYPE 270 (BITS . 7))
-         (GC-TEST-TYPE 272 POINTER)
-         (GC-TEST-TYPE 274 POINTER)
-         (GC-TEST-TYPE 274 (FLAGBITS . 0))
-         (GC-TEST-TYPE 272 (BITS . 7))
-         (GC-TEST-TYPE 259 (BITS . 15))
-         (GC-TEST-TYPE 276 POINTER)
-         (GC-TEST-TYPE 278 FIXP)
-         (GC-TEST-TYPE 280 POINTER)
-         (GC-TEST-TYPE 282 POINTER)
-         (GC-TEST-TYPE 282 (BITS . 7))
-         (GC-TEST-TYPE 284 POINTER)
-         (GC-TEST-TYPE 286 POINTER)
-         (GC-TEST-TYPE 288 POINTER)
-         (GC-TEST-TYPE 290 POINTER)
-         (GC-TEST-TYPE 292 POINTER)
-         (GC-TEST-TYPE 292 (BITS . 7))
-         (GC-TEST-TYPE 294 FIXP)
-         (GC-TEST-TYPE 296 POINTER)
-         (GC-TEST-TYPE 298 POINTER)
-         (GC-TEST-TYPE 300 POINTER)
-         (GC-TEST-TYPE 300 (BITS . 7))
-         (GC-TEST-TYPE 302 POINTER)
-         (GC-TEST-TYPE 304 (BITS . 15))
-         (GC-TEST-TYPE 306 POINTER)
-         (GC-TEST-TYPE 308 POINTER)
-         (GC-TEST-TYPE 310 POINTER)
-         (GC-TEST-TYPE 312 POINTER)
-         (GC-TEST-TYPE 305 (BITS . 15))
-         (GC-TEST-TYPE 314 POINTER)
-         (GC-TEST-TYPE 314 (FLAGBITS . 0))
-         (GC-TEST-TYPE 316 POINTER)
-         (GC-TEST-TYPE 318 XPOINTER)
-         (GC-TEST-TYPE 320 POINTER)
-         (GC-TEST-TYPE 322 POINTER)
-         (GC-TEST-TYPE 324 POINTER)
-         (GC-TEST-TYPE 324 (FLAGBITS . 0))
-         (GC-TEST-TYPE 326 POINTER)
-         (GC-TEST-TYPE 328 (BITS . 15))
-         (GC-TEST-TYPE 326 (BITS . 7))
-         (GC-TEST-TYPE 330 POINTER)
-         (GC-TEST-TYPE 332 POINTER)
-         (GC-TEST-TYPE 334 POINTER)
-         (GC-TEST-TYPE 336 FIXP)
-         (GC-TEST-TYPE 338 POINTER)
-         (GC-TEST-TYPE 340 POINTER)
-         (GC-TEST-TYPE 342 XPOINTER)
-         (GC-TEST-TYPE 344 POINTER)
-         (GC-TEST-TYPE 344 (FLAGBITS . 0))
-         (GC-TEST-TYPE 346 POINTER)
-         (GC-TEST-TYPE 346 (FLAGBITS . 0))
-         (GC-TEST-TYPE 329 (BITS . 15))
-         (GC-TEST-TYPE 346 (FLAGBITS . 16))
-         (GC-TEST-TYPE 348 (BITS . 15))
-         (GC-TEST-TYPE 350 POINTER)
-         (GC-TEST-TYPE 352 POINTER)
-         (GC-TEST-TYPE 354 POINTER)
-         (GC-TEST-TYPE 356 POINTER)
-         (GC-TEST-TYPE 358 POINTER)
-         (GC-TEST-TYPE 360 XPOINTER)
-         (GC-TEST-TYPE 362 POINTER)
-         (GC-TEST-TYPE 349 (BITS . 15))
-         (GC-TEST-TYPE 364 (BITS . 15))
-         (GC-TEST-TYPE 366 POINTER)
-         (GC-TEST-TYPE 368 POINTER)
-         (GC-TEST-TYPE 370 POINTER)
-         (GC-TEST-TYPE 372 POINTER)
-         (GC-TEST-TYPE 374 POINTER)
-         (GC-TEST-TYPE 376 POINTER)
-         (GC-TEST-TYPE 378 POINTER)
-         (GC-TEST-TYPE 380 XPOINTER)
-         (GC-TEST-TYPE 382 POINTER)
-         (GC-TEST-TYPE 365 (BITS . 15))
-         (GC-TEST-TYPE 384 POINTER)
-         (GC-TEST-TYPE 386 POINTER)
-         (GC-TEST-TYPE 388 XPOINTER)
-         (GC-TEST-TYPE 390 POINTER)
-         (GC-TEST-TYPE 392 POINTER)
-         (GC-TEST-TYPE 394 POINTER)
-         (GC-TEST-TYPE 396 POINTER)
-         (GC-TEST-TYPE 398 POINTER)
-         (GC-TEST-TYPE 400 POINTER)
-         (GC-TEST-TYPE 402 POINTER)
-         (GC-TEST-TYPE 404 POINTER)
-         (GC-TEST-TYPE 406 POINTER)
-         (GC-TEST-TYPE 408 POINTER)
-         (GC-TEST-TYPE 410 XPOINTER)
-         (GC-TEST-TYPE 412 POINTER)
-         (GC-TEST-TYPE 414 FIXP)
-         (GC-TEST-TYPE 416 POINTER)
-         (GC-TEST-TYPE 418 POINTER)
-         (GC-TEST-TYPE 420 XPOINTER)
-         (GC-TEST-TYPE 422 POINTER)
-         (GC-TEST-TYPE 424 (BITS . 15))
-         (GC-TEST-TYPE 422 (FLAGBITS . 0))
-         (GC-TEST-TYPE 426 POINTER)
-         (GC-TEST-TYPE 428 POINTER)
-         (GC-TEST-TYPE 430 POINTER)
-         (GC-TEST-TYPE 432 POINTER)
-         (GC-TEST-TYPE 434 POINTER)
-         (GC-TEST-TYPE 434 (BITS . 7))
-         (GC-TEST-TYPE 436 POINTER)
-         (GC-TEST-TYPE 438 POINTER)
-         (GC-TEST-TYPE 438 (FLAGBITS . 0))
-         (GC-TEST-TYPE 436 (BITS . 7))
-         (GC-TEST-TYPE 440 POINTER)
-         (GC-TEST-TYPE 442 POINTER)
-         (GC-TEST-TYPE 444 POINTER)
-         (GC-TEST-TYPE 446 XPOINTER)
-         (GC-TEST-TYPE 425 (BITS . 15))
-         (GC-TEST-TYPE 448 (BITS . 15))
-         (GC-TEST-TYPE 450 POINTER)
-         (GC-TEST-TYPE 452 POINTER)
-         (GC-TEST-TYPE 454 POINTER)
-         (GC-TEST-TYPE 449 (BITS . 15))
-         (GC-TEST-TYPE 456 POINTER)
-         (GC-TEST-TYPE 458 XPOINTER)
-         (GC-TEST-TYPE 458 (BITS . 7))
-         (GC-TEST-TYPE 460 POINTER)
-         (GC-TEST-TYPE 462 XPOINTER)
-         (GC-TEST-TYPE 462 (FLAGBITS . 0))
-         (GC-TEST-TYPE 464 POINTER)
-         (GC-TEST-TYPE 466 POINTER)
-         (GC-TEST-TYPE 466 (FLAGBITS . 0))
-         (GC-TEST-TYPE 468 POINTER)
-         (GC-TEST-TYPE 470 POINTER)
-         (GC-TEST-TYPE 472 XPOINTER)
-         (GC-TEST-TYPE 474 FIXP)
-         (GC-TEST-TYPE 476 FIXP)
-         (GC-TEST-TYPE 472 (BITS . 7))
-         (GC-TEST-TYPE 478 POINTER)
-         (GC-TEST-TYPE 480 POINTER)
-         (GC-TEST-TYPE 482 POINTER)
-         (GC-TEST-TYPE 484 POINTER)
-         (GC-TEST-TYPE 486 FIXP)
-         (GC-TEST-TYPE 488 POINTER)
-         (GC-TEST-TYPE 488 (FLAGBITS . 0))
-         (GC-TEST-TYPE 490 FIXP)
-         (GC-TEST-TYPE 492 POINTER)
-         (GC-TEST-TYPE 494 XPOINTER)
-         (GC-TEST-TYPE 496 POINTER)
-         (GC-TEST-TYPE 498 POINTER)
-         (GC-TEST-TYPE 498 (BITS . 7))
-         (GC-TEST-TYPE 500 POINTER)
-         (GC-TEST-TYPE 502 (BITS . 15))
-         (GC-TEST-TYPE 503 FIXP)
-         (GC-TEST-TYPE 506 POINTER)
-         (GC-TEST-TYPE 506 (FLAGBITS . 0))
-         (GC-TEST-TYPE 508 POINTER)
-         (GC-TEST-TYPE 505 (BITS . 15)))
-       '510)
-
-
-
-(* |;;| "DATATYPE TESTS")

-
-
-
-
-(* |;;| "CODE RECLAIMATION TESTS")

-
-(DEFINEQ
-
-(CODE-RECLAIM-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 23-Jun-88 11:54 by jds")

-    (LET NIL 
-
-         (* |;;| "Make sure there's a definition to compile.")

-
-         (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN)
-             (EVAL CODE-RECLAIM-TEST-TEMP-FN))
-         (PRINTOUT T "  Starting code-block reclaim test" T)
-         (|for|
 I |from|
 1 |to|
 LIMIT |do|
 (BKSYSBUF "ST
-N
-")
-                                                        (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN))
-         (PRINTOUT T "  Starting MAPATOMS(GETD)" T)
-         (|for|
 I |from|
 1 |to|
 LIMIT |do|
 (MAPATOMS (FUNCTION GETD))))))
-)
-
-
-
-(* |;;| 
-"The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed."
-)

-
-
-(RPAQQ CODE-RECLAIM-TEST-TEMP-FN
 
-       (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF)
-                       (LET (I)
-                            (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5))
-                            (ERSETQ (DATE))
-                            (NLSETQ (DATE))
-                            (ERSETQ (DATE))
-                            (NLSETQ (DATE))
-                            (ERSETQ (DATE))
-                            (CL:FLET ((TEMP (ARG)
-                                            (SETQ ARG (FLOAT ARG))
-                                            (EXPT (SQRT I)
-                                                  (SQRT (COS (/ I 180))))))
-                                   (CL:UNWIND-PROTECT
-                                       (FOR I FROM 1 TO 1000 COLLECT (TEMP I))
-                                       (SETQ I NIL)))))))
-(PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (2908 5241 (MAIN-GC-TEST 2918 . 5239)) (5242 13684 (ITEMS-ON-STACK-TEST 5252 . 6415) (
-MANY-BIGNUM-MAKER 6417 . 7289) (MANY-FIXP-MAKER 7291 . 8077) (MANY-FLOAT-MAKER 8079 . 8686) (
-BOUNDARY-TESTS 8688 . 11155) (ARRAY-STRING-TEST 11157 . 13103) (VARIOUS-TYPES-TEST 13105 . 13682)) (
-13685 18528 (TEDIT-CRUNCH-TEST 13695 . 15107) (LIST-MANIPULATION-TEST 15109 . 18526)) (18529 19213 (
-ATOM-FULL-TEST 18539 . 18970) (STORAGE-FULL-TEST 18972 . 19211)) (19214 19732 (DATATYPE-TEST 19224 . 
-19730)) (44715 45405 (CODE-RECLAIM-TEST 44725 . 45403)))))
-STOP

internal/test/GC/Hand/MAIKO-GC-TESTS.~2~

@@ -1,925 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
(FILECREATED " 2-Aug-88 21:52:05" {ERIS}<TEST>GC>HAND>MAIKO-GC-TESTS.\;7
 46959  
-
-      |changes| |to:|  (FNS MAIN-GC-TEST LIST-MANIPULATION-TEST CODE-RECLAIM-TEST)
-
-      |previous| |date:| "23-Jun-88 16:06:34" {ERIS}<TEST>GC>HAND>MAIKO-GC-TESTS.\;6)
-
-
-; Copyright (c) 1988 by John Sybalsky & Xerox Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT MAIKO-GC-TESTSCOMS)
-
-(RPAQQ MAIKO-GC-TESTSCOMS
 
-       ((FILES DANCEROBJ GCHAX)
-        (ADDVARS (DISPLAYFONTDIRECTORIES "{ERIS}<TEST>GC>HAND-AUX>" 
-                        "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>")
-               (INTERPRESSFONTDIRECTORIES "{ERIS}<TEST>GC>HAND-AUX>" 
-                      "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>"))
-        (P (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE)))
-        (FNS MAIN-GC-TEST)
-        (FNS ITEMS-ON-STACK-TEST MANY-BIGNUM-MAKER MANY-FIXP-MAKER MANY-FLOAT-MAKER BOUNDARY-TESTS 
-             ARRAY-STRING-TEST VARIOUS-TYPES-TEST)
-        (FNS TEDIT-CRUNCH-TEST LIST-MANIPULATION-TEST)
-        (FNS ATOM-FULL-TEST STORAGE-FULL-TEST)
-        (COMS (FNS DATATYPE-TEST)
-              (RECORDS GC-TEST-TYPE)
-              
-              (* |;;| "DATATYPE TESTS")

-)
-        (COMS
-         
-         (* |;;| "CODE RECLAIMATION TESTS")

-
-         (FNS CODE-RECLAIM-TEST)
-         
-         (* |;;| "The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed.")

-
-         (VARS (CODE-RECLAIM-TEST-TEMP-FN
-                '(DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN
-                           (ASDF)
-                           (LET (I)
-                                (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5))
-                                (ERSETQ (DATE))
-                                (NLSETQ (DATE))
-                                (ERSETQ (DATE))
-                                (NLSETQ (DATE))
-                                (ERSETQ (DATE))
-                                (CL:FLET ((TEMP (ARG)
-                                                (SETQ ARG (FLOAT ARG))
-                                                (EXPT (SQRT I)
-                                                      (SQRT (COS (/ I 180))))))
-                                       (CL:UNWIND-PROTECT
-                                           (FOR I FROM 1 TO 1000 COLLECT (TEMP I))
-                                           (SETQ I NIL)))))))))))
-
-(FILESLOAD DANCEROBJ GCHAX)
-
-(ADDTOVAR DISPLAYFONTDIRECTORIES
 "{ERIS}<TEST>GC>HAND-AUX>" "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>")
-
-(ADDTOVAR INTERPRESSFONTDIRECTORIES
 "{ERIS}<TEST>GC>HAND-AUX>" 
-                                              "{ERIS}<LISPCORE>XEROXPRIVATE>FONTS>")
-
-(SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT AC STRIKE))
-(DEFINEQ
-
-(MAIN-GC-TEST

-  (LAMBDA (LIMIT DRIBBLE-FILE STACK-COUNT BIGNUM-COUNT FIXP-COUNT FLOAT-COUNT TEDIT-COUNT LIST-COUNT
-                 CODE-COUNT TYPE-COUNT LIST-LEN-LIMIT)
   (* \; "Edited 23-Jun-88 13:30 by jds")

-    (DRIBBLE (OR DRIBBLE-FILE "{LPT}"))
-    (PRINTOUT T ";;; ***********" T ";;; MAIKO GARBAGE COLLECTOR TESTS" T ";;; Run on " (DATE)
-           T ";;; Dribble to " (OR DRIBBLE-FILE "{LPT}")
-           T T)
-    (|for|
 I |from|
 1 |to|
 (OR LIMIT 10) |do|
 (PRINTOUT T 
-                                                                     "Starting Maiko GC tests, pass "
-                                                                     I T)
-                                                           (ITEMS-ON-STACK-TEST
 (OR STACK-COUNT 
-                                                                                        100))
-                                                           (MANY-BIGNUM-MAKER
 (OR BIGNUM-COUNT 
-                                                                                      1000))
-                                                           (MANY-FIXP-MAKER
 (OR FIXP-COUNT 1000))
-                                                           (MANY-FLOAT-MAKER
 (OR FLOAT-COUNT 1000
-                                                                                     ))
-                                                           (TEDIT-CRUNCH-TEST
 (OR TEDIT-COUNT 5))
-                                                           (ARRAY-STRING-TEST
 3)
-                                                           (LIST-MANIPULATION-TEST
 (OR LIST-COUNT
-                                                                                           5)
-                                                                  LIST-LEN-LIMIT)
-                                                           (BOUNDARY-TESTS
)
-                                                           (CODE-RECLAIM-TEST
 (OR CODE-COUNT 20))
-                                                           (VARIOUS-TYPES-TEST
 (OR TYPE-COUNT 10)
-                                                                  )
-                                                           (FRPTQ 100 (RECLAIM))
-                                                           (STORAGE))
-    (ATOM-FULL-TEST
)
-    (STORAGE-FULL-TEST
)
-    (DRIBBLE NIL)))
-)
-(DEFINEQ
-
-(ITEMS-ON-STACK-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:56 by jds")

-    (PRINTOUT T "   Starting ITEMS-ON-STACK test for " LIMIT " iterations." T)
-    (FOR
 I FROM
 1 TO
 LIMIT DO
 (LET ((X (CREATE
 CHARLOOKS))
-                                                    (Y (EXPT 1234.5 (RAND 3 7))))
-                                                   (ERSETQ (FRPTQ 5 (RECLAIM))
-                                                          (COND
-                                                             ((\\ISONFREELIST X)
-                                                              (HELP 
-                                                                "X is free, but pointer is on stack."
-                                                                    ))
-                                                             ((\\ISONFREELIST Y)
-                                                              (HELP 
-                                                                "Y is free, but pointer is on stack."
-                                                                    ))))))))
-
-(MANY-BIGNUM-MAKER

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:54 by jds")

-    (PRINTOUT T "   Starting MANY-BIGNUM-MAKER test for " LIMIT " iterations." T)
-    (LET (X Y Z W)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (SETQ X (CL:* 12345678901234567890
-                                                                 (RAND 1 I)))
-                                                  (SETQ Y (IQUOTIENT X 3))
-                                                  (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7)
-                                                                 (IREMAINDER Y 3)
-                                                                 (CL:FLOOR Y 2)
-                                                                 (CL:CEILING X 8)))
-                                                  (SETQ W (/ Z Y))))))
-
-(MANY-FIXP-MAKER

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:54 by jds")

-    (PRINTOUT T "   Starting MANY-FIXP-MAKER test for " LIMIT " iterations." T)
-    (LET (X Y Z W)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (SETQ X (CL:* 543 (RAND 1 I)))
-                                                  (SETQ Y (IQUOTIENT X 3))
-                                                  (SETQ Z (IPLUS Y X X 34 2 9 (IMOD X 7)
-                                                                 (IREMAINDER Y 3)
-                                                                 (CL:FLOOR Y 2)
-                                                                 (CL:CEILING X 8)))
-                                                  (SETQ W (/ Z Y))))))
-
-(MANY-FLOAT-MAKER

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 25-May-88 11:55 by jds")

-    (PRINTOUT T "   Starting MANY-FLOAT-MAKER test for " LIMIT " iterations." T)
-    (LET (X Y Z W)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (SETQ X (FTIMES 1.0 (RAND 0 1)))
-                                                  (SETQ Y (+ (SQRT I)
-                                                             (EXPT (SQRT (SQRT I))
-                                                                   3.4)))
-                                                  (SETQ Z (LOG Y))))))
-
-(BOUNDARY-TESTS

-  (LAMBDA NIL
                                            (* \; "Edited 26-May-88 11:54 by jds")

-
-    (* |;;| "Tests the transition into and out of big refcnts, and BIG refcnt's.")

-
-    (PRINTOUT T "  Starting Refcnt-63 crossing test" T)
-    (LET* ((ITEM (|create|
 FMTSPEC))
-           (LIST (|for|
 I |from|
 1 |to|
 62 |collect|
 ITEM)))
-          (|for|
 I |from|
 1 |to|
 1000 |do|
 (|for|
 J |from|
 (LENGTH LIST)
-                                                              |to|
 (+ 63 (RAND 1 10))
-                                                              |do|
 (SETQ LIST (CONS ITEM LIST)))
-                                                        (|for|
 J |from|
 (LENGTH LIST)
-                                                           |to|
 (- 63 (RAND 3 12))
-                                                           |do|
 (|pop|
 LIST))
-                                                        (COND
-                                                           ((ZEROP (IMOD I 31))
-                                                            (RECLAIM))))
-          (PRINTOUT T "  Starting Refcount-500K <-> NIL test." T)
-          (|for|
 LOOP |from|
 1 |to|
 10 |do|
 (|for|
 I |from|
 1 |to|
 500000
-                                                               |do|
 (SETQ LIST (CONS ITEM LIST)))
-                                                         (SETQ LIST NIL))
-          (PRINTOUT T "  Starting Refcount 1-2 boundary test." T)
-          (LET ((ITEM (LIST (|create|
 FMTSPEC))))
-               (|for|
 I |from|
 1 |to|
 5000 |do|
 (SETQ ITEM2 (CAR ITEM))
-                                                             (SETQ ITEM2 NIL)))
-          (PRINTOUT T "  Starting Refcount 1 + stack boundary test." T)
-          (LET ((ITEM (|create|
 FMTSPEC))
-                ITEM2)
-               (|for|
 I |from|
 1 |to|
 5000 |do|
 (SETQ ITEM2 (LIST ITEM))
-                                                             (RPLACA ITEM2 NIL)))
-          (PRINTOUT T "  Starting Refcount 0-1 boundary test." T)
-          (LET (ITEM)
-               (|for|
 I |from|
 1 |to|
 5000 |do|
 (SETQ ITEM (LIST (|create|
 
-                                                                                        FMTSPEC)))
-                                                             (RPLACA ITEM NIL))))))
-
-(ARRAY-STRING-TEST

-  (LAMBDA (LIMIT REAL-STRESS)
                            (* \; "Edited 23-Jun-88 12:23 by jds")

-
-    (* |;;| "Try out array & string creation, and substringing on the GC.")

-
-    (PRINTOUT T "  Starting Array & String test." T)
-    (FOR
 I FROM
 1 TO
 (OR LIMIT 10)
-       DO
 (LET (STRINGS ARRAYS)
-                   (FOR
 ARRAY-COUNT FROM
 1 TO
 5000
-                      COLLECT
 (CL:MAKE-ARRAY (RAND 10 (COND
-                                                             (REAL-STRESS 65000)
-                                                             (T (IMAX 100 (IQUOTIENT 65000 
-                                                                                 ARRAY-COUNT)))))))
-                   (FOR
 I FROM
 1 TO
 5000 COLLECT
 (BITMAPCREATE (RAND 1 512)
-                                                                        (RAND 1 512)))
-                   (SETQ STRINGS (FOR
 STRING-COUNT FROM
 1 TO
 5000
-                                    COLLECT
 (ALLOCSTRING (RAND 10
-                                                                   (COND
-                                                                      (REAL-STRESS 65000)
-                                                                      (T (IMAX 100 (IQUOTIENT 65000 
-                                                                                         STRING-COUNT
-                                                                                          ))))))))
-                   (FOR
 STRING IN
 STRINGS
-                      COLLECT
 (SUBSTRING STRING (RAND 1 (LRSH (NCHARS STRING)
-                                                                  1))
-                                         (RAND (ADD1 (LRSH (NCHARS STRING)
-                                                           1))
-                                               (NCHARS STRING))))))))
-
-(VARIOUS-TYPES-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 23-Jun-88 12:04 by jds")

-
-    (* |;;| 
-
  "Run thru creation and collection of various types that have caused trouble in the past. ")

-
-    (PRINTOUT T "  Starting various type cases." T)
-    (FOR
 REPEAT-COUNT FROM
 1 TO
 (OR LIMIT 10)
-       DO
 (|for|
 TYPE IN
 '(VMEMPAGEP) AS
 CREATION-LIMIT IN
 '(100)
-                 |do|
 (FOR
 I FROM
 1 TO
 CREATION-LIMIT COLLECT
 (NCREATE TYPE))
-                       (DORECLAIM)))))
-)
-(DEFINEQ
-
-(TEDIT-CRUNCH-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 27-May-88 13:06 by jds")

-
-    (* |;;| "GC Testing -- stressing the world.")

-
-    (* |;;| "Hardcopy a big TEdit file to a {CORE} file, copy that to disk, and delete everything.")

-
-    (PRINTOUT T "   Starting TEDIT-CRUNCH test for " LIMIT " iterations." T)
-    (FOR
 PASS FROM
 1 TO
 LIMIT DO
 (PRINTOUT T "    Round " PASS " started " (DATE)
-                                                        "." T)
-                                                (LET ((TS (OPENTEXTSTREAM 
-                                                                 '
-                                                          |{ERIS}<Test>GC>Hand-Aux>ADVDICT-N-Z.TEDIT|
-                                                                 ))
-                                                      TLIST)
-                                                     (TEDIT.HARDCOPY TS '{CORE}FOO.IP T)
-                                                     (COPYFILE '{CORE}FOO.IP '{DSK}FOO.IP)
-                                                     (DELFILE '{DSK}FOO.IP)
-                                                     (DELFILE '{CORE}FOO.IP)
-                                                     (CLOSEF (FETCH
 (TEXTOBJ TXTFILE)
-                                                                OF
 (TEXTOBJ TS)))))))
-
-(LIST-MANIPULATION-TEST

-  (LAMBDA (LIMIT LENGTH-LIMIT)
                           (* \; "Edited 23-Jun-88 14:03 by jds")

-
-    (* |;;| "Do lots of list creation, popping, and consing, to make sure the GC works.")

-
-    (PRINTOUT T "   Starting LIST-MANIPULATION test for " LIMIT " iterations." T)
-    (|for|
 PASS |from|
 1 |to|
 LIMIT
-       |do|
 (PRINTOUT T "    Round " PASS " started " (DATE)
-                       "." T)
-             (LET ((TS (OPENTEXTSTREAM '|{ERIS}<sybalsky>Top10-87>Dictionaries>ADVDICT-A-M.TEDIT|))
-                   (LEN (RAND 0 (OR LENGTH-LIMIT 100000)))
-                   TLIST)
-                  (SETQ TLIST (|for|
 I |from|
 1 |to|
 LEN |collect|
 TS))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH LEN 1)))
-                     |do|
 (|pop|
 TLIST))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 100) |do|
 (SETQ TLIST
-                                                                            (CONS TS TLIST)))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST)
-                                                                           1)))
-                     |do|
 (|pop|
 TLIST))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 2000) |do|
 (SETQ TLIST
-                                                                             (CONS TS TLIST)))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST)
-                                                                           1)))
-                     |do|
 (|pop|
 TLIST))
-                  (|for|
 \i |from|
 1 |to|
 (RAND 1 1500)
-                     |do|
 (SETQ TLIST (NCONC TLIST
-                                                 (|for|
 J |from|
 1
-                                                    |to|
 (RAND 1 10)
-                                                    |join|
 (|for|
 K |from|
 1 |to|

-                                                                                         3
-                                                                  |collect|
 (CONS TS K))))))
-                  (|for|
 I |from|
 1 |to|
 (RAND 1 (IMAX 1 (LRSH (FLENGTH TLIST)
-                                                                           1)))
-                     |do|
 (|pop|
 TLIST))
-                  (CLOSEF (|fetch|
 (TEXTOBJ TXTFILE) |of|
 (TEXTOBJ TS))))
-             (LET ((GC-ITEM (NCREATE 'VMEMPAGEP))
-                   (LEN (RAND 10 500))
-                   TLIST ELT)
-                  (SETQ TLIST (|for|
 I |from|
 1 |to|
 LEN |collect|
 NIL))
-                  (|for|
 I |from|
 1 |to|
 LEN |do|
 (SETQ ELT (CL:RANDOM LEN))
-                                                               (RPLACA (CL:NTHCDR ELT TLIST)
-                                                                      GC-ITEM)
-                                                               (RPLACA (CL:NTHCDR (SUB1 I)
-                                                                              TLIST)
-                                                                      GC-ITEM))
-                  (|for|
 I |from|
 (SUB1 LEN) |to|
 0 |by|
 -1
-                     |do|
 (RPLACD (CL:NTHCDR I TLIST)
-                                     GC-ITEM))))))
-)
-(DEFINEQ
-
-(ATOM-FULL-TEST

-  (LAMBDA NIL
                                            (* \; "Edited 26-May-88 11:39 by jds")

-    (PRINTOUT T "  Starting ATOM-space full test.")
-    (LET ((CUR-ATOM-COUNT |\\AtomFrLst|))
-         (CL:UNWIND-PROTECT
-             (PROGN (SETQ |\\AtomFrLst| 64000)
-                    (FOR
 I FROM
 64000 TO
 70000 DO
 (GENSYM 'GC-TEST)))
-             (SETQ |\\AtomFrLst| CUR-ATOM-COUNT)))))
-
-(STORAGE-FULL-TEST

-  (LAMBDA NIL
                                            (* \; "Edited 26-May-88 11:47 by jds")

-    (PRINTOUT T "  Starting Storage-full test." T)
-    (ERSETQ (FOR
 I FROM
 1 COLLECT
 (ARRAY 100)))))
-)
-(DEFINEQ
-
-(DATATYPE-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 26-May-88 11:26 by jds")

-    (FOR
 I FROM
 1 TO
 (OR LIMIT 10)
-       DO
 (FOR
 L FROM
 1 TO
 100 DO
 (FOR
 Y FROM
 1 TO
 20
-                                                         COLLECT
 (CREATE
 GC-TEST-TYPE
-                                                                            FIELD-1 _ T))
-                                                     (RECLAIM)))))
-)
-(DECLARE\: EVAL@COMPILE
-
-(DATATYPE GC-TEST-TYPE
 (FIELD-1 FIELD-2 FIELD-3 (FIELD-4 BYTE)
-                                  (FIELD-5 FIXP)
-                                  FIELD-6
-                                  (FIELD-7 WORD)
-                                  FIELD-8 FIELD-9 FIELD-10 FIELD-11 FIELD-12 FIELD-13 (FIELD-14
-                                                                                       FIXP)
-                                  FIELD-15
-                                  (FIELD-16 XPOINTER)
-                                  FIELD-17
-                                  (FIELD-18 BYTE)
-                                  (FIELD-19 FIXP)
-                                  FIELD-20
-                                  (FIELD-21 BYTE)
-                                  FIELD-22 FIELD-23 FIELD-24 (FIELD-25 BYTE)
-                                  FIELD-26
-                                  (FIELD-27 BYTE)
-                                  FIELD-28
-                                  (FIELD-29 BYTE)
-                                  FIELD-30
-                                  (FIELD-31 WORD)
-                                  FIELD-32
-                                  (FIELD-33 XPOINTER)
-                                  FIELD-34
-                                  (FIELD-35 FIXP)
-                                  FIELD-36 FIELD-37 FIELD-38 (FIELD-39 FLAG)
-                                  FIELD-40
-                                  (FIELD-41 FLAG)
-                                  FIELD-42
-                                  (FIELD-43 FIXP)
-                                  (FIELD-44 FIXP)
-                                  FIELD-45
-                                  (FIELD-46 XPOINTER)
-                                  FIELD-47 FIELD-48 FIELD-49 (FIELD-50 FLAG)
-                                  (FIELD-51 BYTE)
-                                  FIELD-52 FIELD-53 (FIELD-54 BYTE)
-                                  FIELD-55 FIELD-56 (FIELD-57 BYTE)
-                                  (FIELD-58 WORD)
-                                  FIELD-59 FIELD-60 (FIELD-61 XPOINTER)
-                                  FIELD-62 FIELD-63 (FIELD-64 XPOINTER)
-                                  (FIELD-65 XPOINTER)
-                                  FIELD-66 FIELD-67 FIELD-68 FIELD-69 (FIELD-70 FLAG)
-                                  FIELD-71 FIELD-72 (FIELD-73 WORD)
-                                  FIELD-74
-                                  (FIELD-75 FLAG)
-                                  FIELD-76 FIELD-77 FIELD-78 FIELD-79 (FIELD-80 FIXP)
-                                  (FIELD-81 FIXP)
-                                  FIELD-82 FIELD-83 FIELD-84 FIELD-85 (FIELD-86 XPOINTER)
-                                  (FIELD-87 BYTE)
-                                  (FIELD-88 XPOINTER)
-                                  FIELD-89
-                                  (FIELD-90 BYTE)
-                                  (FIELD-91 FLAG)
-                                  (FIELD-92 FIXP)
-                                  (FIELD-93 FIXP)
-                                  (FIELD-94 FLAG)
-                                  FIELD-95
-                                  (FIELD-96 FLAG)
-                                  FIELD-97
-                                  (FIELD-98 FLAG)
-                                  FIELD-99 FIELD-100 FIELD-101 FIELD-102 FIELD-103 (FIELD-104 
-                                                                                          XPOINTER)
-                                  FIELD-105 FIELD-106 FIELD-107 FIELD-108 (FIELD-109 BYTE)
-                                  FIELD-110
-                                  (FIELD-111 WORD)
-                                  FIELD-112
-                                  (FIELD-113 XPOINTER)
-                                  (FIELD-114 FLAG)
-                                  (FIELD-115 FIXP)
-                                  FIELD-116 FIELD-117 (FIELD-118 BYTE)
-                                  FIELD-119 FIELD-120 FIELD-121 FIELD-122 FIELD-123 (FIELD-124 
-                                                                                           XPOINTER)
-                                  (FIELD-125 BYTE)
-                                  (FIELD-126 XPOINTER)
-                                  FIELD-127 FIELD-128 (FIELD-129 FIXP)
-                                  (FIELD-130 FLAG)
-                                  FIELD-131 FIELD-132 FIELD-133 FIELD-134 (FIELD-135 WORD)
-                                  (FIELD-136 FLAG)
-                                  FIELD-137 FIELD-138 FIELD-139 (FIELD-140 WORD)
-                                  (FIELD-141 FLAG)
-                                  FIELD-142 FIELD-143 FIELD-144 (FIELD-145 FIXP)
-                                  FIELD-146 FIELD-147 FIELD-148 FIELD-149 (FIELD-150 FLAG)
-                                  FIELD-151 FIELD-152 FIELD-153 FIELD-154 (FIELD-155 FIXP)
-                                  FIELD-156
-                                  (FIELD-157 BYTE)
-                                  FIELD-158
-                                  (FIELD-159 FIXP)
-                                  (FIELD-160 WORD)
-                                  FIELD-161
-                                  (FIELD-162 WORD)
-                                  (FIELD-163 FIXP)
-                                  FIELD-164
-                                  (FIELD-165 FIXP)
-                                  FIELD-166
-                                  (FIELD-167 FLAG)
-                                  (FIELD-168 BYTE)
-                                  FIELD-169 FIELD-170 (FIELD-171 XPOINTER)
-                                  (FIELD-172 BYTE)
-                                  FIELD-173 FIELD-174 (FIELD-175 FLAG)
-                                  (FIELD-176 BYTE)
-                                  (FIELD-177 WORD)
-                                  FIELD-178
-                                  (FIELD-179 FIXP)
-                                  FIELD-180 FIELD-181 (FIELD-182 BYTE)
-                                  FIELD-183 FIELD-184 FIELD-185 FIELD-186 FIELD-187 (FIELD-188 BYTE)
-                                  (FIELD-189 FIXP)
-                                  FIELD-190 FIELD-191 FIELD-192 (FIELD-193 BYTE)
-                                  FIELD-194
-                                  (FIELD-195 WORD)
-                                  FIELD-196 FIELD-197 FIELD-198 FIELD-199 (FIELD-200 WORD)
-                                  FIELD-201
-                                  (FIELD-202 FLAG)
-                                  FIELD-203
-                                  (FIELD-204 XPOINTER)
-                                  FIELD-205 FIELD-206 FIELD-207 (FIELD-208 FLAG)
-                                  FIELD-209
-                                  (FIELD-210 WORD)
-                                  (FIELD-211 BYTE)
-                                  FIELD-212 FIELD-213 FIELD-214 (FIELD-215 FIXP)
-                                  FIELD-216 FIELD-217 (FIELD-218 XPOINTER)
-                                  FIELD-219
-                                  (FIELD-220 FLAG)
-                                  FIELD-221
-                                  (FIELD-222 FLAG)
-                                  (FIELD-223 WORD)
-                                  (FIELD-224 FLAG)
-                                  (FIELD-225 WORD)
-                                  FIELD-226 FIELD-227 FIELD-228 FIELD-229 FIELD-230 (FIELD-231 
-                                                                                           XPOINTER)
-                                  FIELD-232
-                                  (FIELD-233 WORD)
-                                  (FIELD-234 WORD)
-                                  FIELD-235 FIELD-236 FIELD-237 FIELD-238 FIELD-239 FIELD-240 
-                                  FIELD-241 (FIELD-242 XPOINTER)
-                                  FIELD-243
-                                  (FIELD-244 WORD)
-                                  FIELD-245 FIELD-246 (FIELD-247 XPOINTER)
-                                  FIELD-248 FIELD-249 FIELD-250 FIELD-251 FIELD-252 FIELD-253 
-                                  FIELD-254 FIELD-255 FIELD-256 FIELD-257 (FIELD-258 XPOINTER)
-                                  FIELD-259
-                                  (FIELD-260 FIXP)
-                                  FIELD-261 FIELD-262 (FIELD-263 XPOINTER)
-                                  FIELD-264
-                                  (FIELD-265 WORD)
-                                  (FIELD-266 FLAG)
-                                  FIELD-267 FIELD-268 FIELD-269 FIELD-270 FIELD-271 (FIELD-272 BYTE)
-                                  FIELD-273 FIELD-274 (FIELD-275 FLAG)
-                                  (FIELD-276 BYTE)
-                                  FIELD-277 FIELD-278 FIELD-279 (FIELD-280 XPOINTER)
-                                  (FIELD-281 WORD)
-                                  (FIELD-282 WORD)
-                                  FIELD-283 FIELD-284 FIELD-285 (FIELD-286 WORD)
-                                  FIELD-287
-                                  (FIELD-288 XPOINTER)
-                                  (FIELD-289 BYTE)
-                                  FIELD-290
-                                  (FIELD-291 XPOINTER)
-                                  (FIELD-292 FLAG)
-                                  FIELD-293 FIELD-294 (FIELD-295 FLAG)
-                                  FIELD-296 FIELD-297 (FIELD-298 XPOINTER)
-                                  (FIELD-299 FIXP)
-                                  (FIELD-300 FIXP)
-                                  (FIELD-301 BYTE)
-                                  FIELD-302 FIELD-303 FIELD-304 FIELD-305 (FIELD-306 FIXP)
-                                  FIELD-307
-                                  (FIELD-308 FLAG)
-                                  (FIELD-309 FIXP)
-                                  FIELD-310
-                                  (FIELD-311 XPOINTER)
-                                  FIELD-312 FIELD-313 (FIELD-314 BYTE)
-                                  FIELD-315
-                                  (FIELD-316 WORD)
-                                  (FIELD-317 FIXP)
-                                  FIELD-318
-                                  (FIELD-319 FLAG)
-                                  FIELD-320
-                                  (FIELD-321 WORD)))
-)
-
-(/DECLAREDATATYPE 'GC-TEST-TYPE
-       '(POINTER POINTER POINTER BYTE FIXP POINTER WORD POINTER POINTER POINTER POINTER POINTER 
-               POINTER FIXP POINTER XPOINTER POINTER BYTE FIXP POINTER BYTE POINTER POINTER POINTER 
-               BYTE POINTER BYTE POINTER BYTE POINTER WORD POINTER XPOINTER POINTER FIXP POINTER 
-               POINTER POINTER FLAG POINTER FLAG POINTER FIXP FIXP POINTER XPOINTER POINTER POINTER 
-               POINTER FLAG BYTE POINTER POINTER BYTE POINTER POINTER BYTE WORD POINTER POINTER 
-               XPOINTER POINTER POINTER XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG 
-               POINTER POINTER WORD POINTER FLAG POINTER POINTER POINTER POINTER FIXP FIXP POINTER 
-               POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER BYTE FLAG FIXP FIXP FLAG 
-               POINTER FLAG POINTER FLAG POINTER POINTER POINTER POINTER POINTER XPOINTER POINTER 
-               POINTER POINTER POINTER BYTE POINTER WORD POINTER XPOINTER FLAG FIXP POINTER POINTER 
-               BYTE POINTER POINTER POINTER POINTER POINTER XPOINTER BYTE XPOINTER POINTER POINTER 
-               FIXP FLAG POINTER POINTER POINTER POINTER WORD FLAG POINTER POINTER POINTER WORD FLAG
-               POINTER POINTER POINTER FIXP POINTER POINTER POINTER POINTER FLAG POINTER POINTER 
-               POINTER POINTER FIXP POINTER BYTE POINTER FIXP WORD POINTER WORD FIXP POINTER FIXP 
-               POINTER FLAG BYTE POINTER POINTER XPOINTER BYTE POINTER POINTER FLAG BYTE WORD POINTER
-               FIXP POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER BYTE FIXP POINTER 
-               POINTER POINTER BYTE POINTER WORD POINTER POINTER POINTER POINTER WORD POINTER FLAG 
-               POINTER XPOINTER POINTER POINTER POINTER FLAG POINTER WORD BYTE POINTER POINTER 
-               POINTER FIXP POINTER POINTER XPOINTER POINTER FLAG POINTER FLAG WORD FLAG WORD POINTER
-               POINTER POINTER POINTER POINTER XPOINTER POINTER WORD WORD POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER XPOINTER POINTER WORD POINTER POINTER XPOINTER POINTER
-               POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER XPOINTER 
-               POINTER FIXP POINTER POINTER XPOINTER POINTER WORD FLAG POINTER POINTER POINTER 
-               POINTER POINTER BYTE POINTER POINTER FLAG BYTE POINTER POINTER POINTER XPOINTER WORD 
-               WORD POINTER POINTER POINTER WORD POINTER XPOINTER BYTE POINTER XPOINTER FLAG POINTER
-               POINTER FLAG POINTER POINTER XPOINTER FIXP FIXP BYTE POINTER POINTER POINTER POINTER 
-               FIXP POINTER FLAG FIXP POINTER XPOINTER POINTER POINTER BYTE POINTER WORD FIXP POINTER
-               FLAG POINTER WORD)
-       '((GC-TEST-TYPE 0 POINTER)
-         (GC-TEST-TYPE 2 POINTER)
-         (GC-TEST-TYPE 4 POINTER)
-         (GC-TEST-TYPE 4 (BITS . 7))
-         (GC-TEST-TYPE 6 FIXP)
-         (GC-TEST-TYPE 8 POINTER)
-         (GC-TEST-TYPE 10 (BITS . 15))
-         (GC-TEST-TYPE 12 POINTER)
-         (GC-TEST-TYPE 14 POINTER)
-         (GC-TEST-TYPE 16 POINTER)
-         (GC-TEST-TYPE 18 POINTER)
-         (GC-TEST-TYPE 20 POINTER)
-         (GC-TEST-TYPE 22 POINTER)
-         (GC-TEST-TYPE 24 FIXP)
-         (GC-TEST-TYPE 26 POINTER)
-         (GC-TEST-TYPE 28 XPOINTER)
-         (GC-TEST-TYPE 30 POINTER)
-         (GC-TEST-TYPE 30 (BITS . 7))
-         (GC-TEST-TYPE 32 FIXP)
-         (GC-TEST-TYPE 34 POINTER)
-         (GC-TEST-TYPE 34 (BITS . 7))
-         (GC-TEST-TYPE 36 POINTER)
-         (GC-TEST-TYPE 38 POINTER)
-         (GC-TEST-TYPE 40 POINTER)
-         (GC-TEST-TYPE 40 (BITS . 7))
-         (GC-TEST-TYPE 42 POINTER)
-         (GC-TEST-TYPE 42 (BITS . 7))
-         (GC-TEST-TYPE 44 POINTER)
-         (GC-TEST-TYPE 44 (BITS . 7))
-         (GC-TEST-TYPE 46 POINTER)
-         (GC-TEST-TYPE 11 (BITS . 15))
-         (GC-TEST-TYPE 48 POINTER)
-         (GC-TEST-TYPE 50 XPOINTER)
-         (GC-TEST-TYPE 52 POINTER)
-         (GC-TEST-TYPE 54 FIXP)
-         (GC-TEST-TYPE 56 POINTER)
-         (GC-TEST-TYPE 58 POINTER)
-         (GC-TEST-TYPE 60 POINTER)
-         (GC-TEST-TYPE 60 (FLAGBITS . 0))
-         (GC-TEST-TYPE 62 POINTER)
-         (GC-TEST-TYPE 62 (FLAGBITS . 0))
-         (GC-TEST-TYPE 64 POINTER)
-         (GC-TEST-TYPE 66 FIXP)
-         (GC-TEST-TYPE 68 FIXP)
-         (GC-TEST-TYPE 70 POINTER)
-         (GC-TEST-TYPE 72 XPOINTER)
-         (GC-TEST-TYPE 74 POINTER)
-         (GC-TEST-TYPE 76 POINTER)
-         (GC-TEST-TYPE 78 POINTER)
-         (GC-TEST-TYPE 78 (FLAGBITS . 0))
-         (GC-TEST-TYPE 76 (BITS . 7))
-         (GC-TEST-TYPE 80 POINTER)
-         (GC-TEST-TYPE 82 POINTER)
-         (GC-TEST-TYPE 82 (BITS . 7))
-         (GC-TEST-TYPE 84 POINTER)
-         (GC-TEST-TYPE 86 POINTER)
-         (GC-TEST-TYPE 86 (BITS . 7))
-         (GC-TEST-TYPE 88 (BITS . 15))
-         (GC-TEST-TYPE 90 POINTER)
-         (GC-TEST-TYPE 92 POINTER)
-         (GC-TEST-TYPE 94 XPOINTER)
-         (GC-TEST-TYPE 96 POINTER)
-         (GC-TEST-TYPE 98 POINTER)
-         (GC-TEST-TYPE 100 XPOINTER)
-         (GC-TEST-TYPE 102 XPOINTER)
-         (GC-TEST-TYPE 104 POINTER)
-         (GC-TEST-TYPE 106 POINTER)
-         (GC-TEST-TYPE 108 POINTER)
-         (GC-TEST-TYPE 110 POINTER)
-         (GC-TEST-TYPE 110 (FLAGBITS . 0))
-         (GC-TEST-TYPE 112 POINTER)
-         (GC-TEST-TYPE 114 POINTER)
-         (GC-TEST-TYPE 89 (BITS . 15))
-         (GC-TEST-TYPE 116 POINTER)
-         (GC-TEST-TYPE 116 (FLAGBITS . 0))
-         (GC-TEST-TYPE 118 POINTER)
-         (GC-TEST-TYPE 120 POINTER)
-         (GC-TEST-TYPE 122 POINTER)
-         (GC-TEST-TYPE 124 POINTER)
-         (GC-TEST-TYPE 126 FIXP)
-         (GC-TEST-TYPE 128 FIXP)
-         (GC-TEST-TYPE 130 POINTER)
-         (GC-TEST-TYPE 132 POINTER)
-         (GC-TEST-TYPE 134 POINTER)
-         (GC-TEST-TYPE 136 POINTER)
-         (GC-TEST-TYPE 138 XPOINTER)
-         (GC-TEST-TYPE 138 (BITS . 7))
-         (GC-TEST-TYPE 140 XPOINTER)
-         (GC-TEST-TYPE 142 POINTER)
-         (GC-TEST-TYPE 142 (BITS . 7))
-         (GC-TEST-TYPE 140 (FLAGBITS . 0))
-         (GC-TEST-TYPE 144 FIXP)
-         (GC-TEST-TYPE 146 FIXP)
-         (GC-TEST-TYPE 140 (FLAGBITS . 16))
-         (GC-TEST-TYPE 148 POINTER)
-         (GC-TEST-TYPE 148 (FLAGBITS . 0))
-         (GC-TEST-TYPE 150 POINTER)
-         (GC-TEST-TYPE 150 (FLAGBITS . 0))
-         (GC-TEST-TYPE 152 POINTER)
-         (GC-TEST-TYPE 154 POINTER)
-         (GC-TEST-TYPE 156 POINTER)
-         (GC-TEST-TYPE 158 POINTER)
-         (GC-TEST-TYPE 160 POINTER)
-         (GC-TEST-TYPE 162 XPOINTER)
-         (GC-TEST-TYPE 164 POINTER)
-         (GC-TEST-TYPE 166 POINTER)
-         (GC-TEST-TYPE 168 POINTER)
-         (GC-TEST-TYPE 170 POINTER)
-         (GC-TEST-TYPE 170 (BITS . 7))
-         (GC-TEST-TYPE 172 POINTER)
-         (GC-TEST-TYPE 174 (BITS . 15))
-         (GC-TEST-TYPE 176 POINTER)
-         (GC-TEST-TYPE 178 XPOINTER)
-         (GC-TEST-TYPE 178 (FLAGBITS . 0))
-         (GC-TEST-TYPE 180 FIXP)
-         (GC-TEST-TYPE 182 POINTER)
-         (GC-TEST-TYPE 184 POINTER)
-         (GC-TEST-TYPE 184 (BITS . 7))
-         (GC-TEST-TYPE 186 POINTER)
-         (GC-TEST-TYPE 188 POINTER)
-         (GC-TEST-TYPE 190 POINTER)
-         (GC-TEST-TYPE 192 POINTER)
-         (GC-TEST-TYPE 194 POINTER)
-         (GC-TEST-TYPE 196 XPOINTER)
-         (GC-TEST-TYPE 196 (BITS . 7))
-         (GC-TEST-TYPE 198 XPOINTER)
-         (GC-TEST-TYPE 200 POINTER)
-         (GC-TEST-TYPE 202 POINTER)
-         (GC-TEST-TYPE 204 FIXP)
-         (GC-TEST-TYPE 202 (FLAGBITS . 0))
-         (GC-TEST-TYPE 206 POINTER)
-         (GC-TEST-TYPE 208 POINTER)
-         (GC-TEST-TYPE 210 POINTER)
-         (GC-TEST-TYPE 212 POINTER)
-         (GC-TEST-TYPE 175 (BITS . 15))
-         (GC-TEST-TYPE 212 (FLAGBITS . 0))
-         (GC-TEST-TYPE 214 POINTER)
-         (GC-TEST-TYPE 216 POINTER)
-         (GC-TEST-TYPE 218 POINTER)
-         (GC-TEST-TYPE 220 (BITS . 15))
-         (GC-TEST-TYPE 218 (FLAGBITS . 0))
-         (GC-TEST-TYPE 222 POINTER)
-         (GC-TEST-TYPE 224 POINTER)
-         (GC-TEST-TYPE 226 POINTER)
-         (GC-TEST-TYPE 228 FIXP)
-         (GC-TEST-TYPE 230 POINTER)
-         (GC-TEST-TYPE 232 POINTER)
-         (GC-TEST-TYPE 234 POINTER)
-         (GC-TEST-TYPE 236 POINTER)
-         (GC-TEST-TYPE 236 (FLAGBITS . 0))
-         (GC-TEST-TYPE 238 POINTER)
-         (GC-TEST-TYPE 240 POINTER)
-         (GC-TEST-TYPE 242 POINTER)
-         (GC-TEST-TYPE 244 POINTER)
-         (GC-TEST-TYPE 246 FIXP)
-         (GC-TEST-TYPE 248 POINTER)
-         (GC-TEST-TYPE 248 (BITS . 7))
-         (GC-TEST-TYPE 250 POINTER)
-         (GC-TEST-TYPE 252 FIXP)
-         (GC-TEST-TYPE 221 (BITS . 15))
-         (GC-TEST-TYPE 254 POINTER)
-         (GC-TEST-TYPE 256 (BITS . 15))
-         (GC-TEST-TYPE 257 FIXP)
-         (GC-TEST-TYPE 260 POINTER)
-         (GC-TEST-TYPE 262 FIXP)
-         (GC-TEST-TYPE 264 POINTER)
-         (GC-TEST-TYPE 264 (FLAGBITS . 0))
-         (GC-TEST-TYPE 260 (BITS . 7))
-         (GC-TEST-TYPE 266 POINTER)
-         (GC-TEST-TYPE 268 POINTER)
-         (GC-TEST-TYPE 270 XPOINTER)
-         (GC-TEST-TYPE 270 (BITS . 7))
-         (GC-TEST-TYPE 272 POINTER)
-         (GC-TEST-TYPE 274 POINTER)
-         (GC-TEST-TYPE 274 (FLAGBITS . 0))
-         (GC-TEST-TYPE 272 (BITS . 7))
-         (GC-TEST-TYPE 259 (BITS . 15))
-         (GC-TEST-TYPE 276 POINTER)
-         (GC-TEST-TYPE 278 FIXP)
-         (GC-TEST-TYPE 280 POINTER)
-         (GC-TEST-TYPE 282 POINTER)
-         (GC-TEST-TYPE 282 (BITS . 7))
-         (GC-TEST-TYPE 284 POINTER)
-         (GC-TEST-TYPE 286 POINTER)
-         (GC-TEST-TYPE 288 POINTER)
-         (GC-TEST-TYPE 290 POINTER)
-         (GC-TEST-TYPE 292 POINTER)
-         (GC-TEST-TYPE 292 (BITS . 7))
-         (GC-TEST-TYPE 294 FIXP)
-         (GC-TEST-TYPE 296 POINTER)
-         (GC-TEST-TYPE 298 POINTER)
-         (GC-TEST-TYPE 300 POINTER)
-         (GC-TEST-TYPE 300 (BITS . 7))
-         (GC-TEST-TYPE 302 POINTER)
-         (GC-TEST-TYPE 304 (BITS . 15))
-         (GC-TEST-TYPE 306 POINTER)
-         (GC-TEST-TYPE 308 POINTER)
-         (GC-TEST-TYPE 310 POINTER)
-         (GC-TEST-TYPE 312 POINTER)
-         (GC-TEST-TYPE 305 (BITS . 15))
-         (GC-TEST-TYPE 314 POINTER)
-         (GC-TEST-TYPE 314 (FLAGBITS . 0))
-         (GC-TEST-TYPE 316 POINTER)
-         (GC-TEST-TYPE 318 XPOINTER)
-         (GC-TEST-TYPE 320 POINTER)
-         (GC-TEST-TYPE 322 POINTER)
-         (GC-TEST-TYPE 324 POINTER)
-         (GC-TEST-TYPE 324 (FLAGBITS . 0))
-         (GC-TEST-TYPE 326 POINTER)
-         (GC-TEST-TYPE 328 (BITS . 15))
-         (GC-TEST-TYPE 326 (BITS . 7))
-         (GC-TEST-TYPE 330 POINTER)
-         (GC-TEST-TYPE 332 POINTER)
-         (GC-TEST-TYPE 334 POINTER)
-         (GC-TEST-TYPE 336 FIXP)
-         (GC-TEST-TYPE 338 POINTER)
-         (GC-TEST-TYPE 340 POINTER)
-         (GC-TEST-TYPE 342 XPOINTER)
-         (GC-TEST-TYPE 344 POINTER)
-         (GC-TEST-TYPE 344 (FLAGBITS . 0))
-         (GC-TEST-TYPE 346 POINTER)
-         (GC-TEST-TYPE 346 (FLAGBITS . 0))
-         (GC-TEST-TYPE 329 (BITS . 15))
-         (GC-TEST-TYPE 346 (FLAGBITS . 16))
-         (GC-TEST-TYPE 348 (BITS . 15))
-         (GC-TEST-TYPE 350 POINTER)
-         (GC-TEST-TYPE 352 POINTER)
-         (GC-TEST-TYPE 354 POINTER)
-         (GC-TEST-TYPE 356 POINTER)
-         (GC-TEST-TYPE 358 POINTER)
-         (GC-TEST-TYPE 360 XPOINTER)
-         (GC-TEST-TYPE 362 POINTER)
-         (GC-TEST-TYPE 349 (BITS . 15))
-         (GC-TEST-TYPE 364 (BITS . 15))
-         (GC-TEST-TYPE 366 POINTER)
-         (GC-TEST-TYPE 368 POINTER)
-         (GC-TEST-TYPE 370 POINTER)
-         (GC-TEST-TYPE 372 POINTER)
-         (GC-TEST-TYPE 374 POINTER)
-         (GC-TEST-TYPE 376 POINTER)
-         (GC-TEST-TYPE 378 POINTER)
-         (GC-TEST-TYPE 380 XPOINTER)
-         (GC-TEST-TYPE 382 POINTER)
-         (GC-TEST-TYPE 365 (BITS . 15))
-         (GC-TEST-TYPE 384 POINTER)
-         (GC-TEST-TYPE 386 POINTER)
-         (GC-TEST-TYPE 388 XPOINTER)
-         (GC-TEST-TYPE 390 POINTER)
-         (GC-TEST-TYPE 392 POINTER)
-         (GC-TEST-TYPE 394 POINTER)
-         (GC-TEST-TYPE 396 POINTER)
-         (GC-TEST-TYPE 398 POINTER)
-         (GC-TEST-TYPE 400 POINTER)
-         (GC-TEST-TYPE 402 POINTER)
-         (GC-TEST-TYPE 404 POINTER)
-         (GC-TEST-TYPE 406 POINTER)
-         (GC-TEST-TYPE 408 POINTER)
-         (GC-TEST-TYPE 410 XPOINTER)
-         (GC-TEST-TYPE 412 POINTER)
-         (GC-TEST-TYPE 414 FIXP)
-         (GC-TEST-TYPE 416 POINTER)
-         (GC-TEST-TYPE 418 POINTER)
-         (GC-TEST-TYPE 420 XPOINTER)
-         (GC-TEST-TYPE 422 POINTER)
-         (GC-TEST-TYPE 424 (BITS . 15))
-         (GC-TEST-TYPE 422 (FLAGBITS . 0))
-         (GC-TEST-TYPE 426 POINTER)
-         (GC-TEST-TYPE 428 POINTER)
-         (GC-TEST-TYPE 430 POINTER)
-         (GC-TEST-TYPE 432 POINTER)
-         (GC-TEST-TYPE 434 POINTER)
-         (GC-TEST-TYPE 434 (BITS . 7))
-         (GC-TEST-TYPE 436 POINTER)
-         (GC-TEST-TYPE 438 POINTER)
-         (GC-TEST-TYPE 438 (FLAGBITS . 0))
-         (GC-TEST-TYPE 436 (BITS . 7))
-         (GC-TEST-TYPE 440 POINTER)
-         (GC-TEST-TYPE 442 POINTER)
-         (GC-TEST-TYPE 444 POINTER)
-         (GC-TEST-TYPE 446 XPOINTER)
-         (GC-TEST-TYPE 425 (BITS . 15))
-         (GC-TEST-TYPE 448 (BITS . 15))
-         (GC-TEST-TYPE 450 POINTER)
-         (GC-TEST-TYPE 452 POINTER)
-         (GC-TEST-TYPE 454 POINTER)
-         (GC-TEST-TYPE 449 (BITS . 15))
-         (GC-TEST-TYPE 456 POINTER)
-         (GC-TEST-TYPE 458 XPOINTER)
-         (GC-TEST-TYPE 458 (BITS . 7))
-         (GC-TEST-TYPE 460 POINTER)
-         (GC-TEST-TYPE 462 XPOINTER)
-         (GC-TEST-TYPE 462 (FLAGBITS . 0))
-         (GC-TEST-TYPE 464 POINTER)
-         (GC-TEST-TYPE 466 POINTER)
-         (GC-TEST-TYPE 466 (FLAGBITS . 0))
-         (GC-TEST-TYPE 468 POINTER)
-         (GC-TEST-TYPE 470 POINTER)
-         (GC-TEST-TYPE 472 XPOINTER)
-         (GC-TEST-TYPE 474 FIXP)
-         (GC-TEST-TYPE 476 FIXP)
-         (GC-TEST-TYPE 472 (BITS . 7))
-         (GC-TEST-TYPE 478 POINTER)
-         (GC-TEST-TYPE 480 POINTER)
-         (GC-TEST-TYPE 482 POINTER)
-         (GC-TEST-TYPE 484 POINTER)
-         (GC-TEST-TYPE 486 FIXP)
-         (GC-TEST-TYPE 488 POINTER)
-         (GC-TEST-TYPE 488 (FLAGBITS . 0))
-         (GC-TEST-TYPE 490 FIXP)
-         (GC-TEST-TYPE 492 POINTER)
-         (GC-TEST-TYPE 494 XPOINTER)
-         (GC-TEST-TYPE 496 POINTER)
-         (GC-TEST-TYPE 498 POINTER)
-         (GC-TEST-TYPE 498 (BITS . 7))
-         (GC-TEST-TYPE 500 POINTER)
-         (GC-TEST-TYPE 502 (BITS . 15))
-         (GC-TEST-TYPE 503 FIXP)
-         (GC-TEST-TYPE 506 POINTER)
-         (GC-TEST-TYPE 506 (FLAGBITS . 0))
-         (GC-TEST-TYPE 508 POINTER)
-         (GC-TEST-TYPE 505 (BITS . 15)))
-       '510)
-
-
-
-(* |;;| "DATATYPE TESTS")

-
-
-
-
-(* |;;| "CODE RECLAIMATION TESTS")

-
-(DEFINEQ
-
-(CODE-RECLAIM-TEST

-  (LAMBDA (LIMIT)
                                        (* \; "Edited 23-Jun-88 11:54 by jds")

-    (LET NIL 
-
-         (* |;;| "Make sure there's a definition to compile.")

-
-         (OR (GETD 'CODE-RECLAIM-TEST-TEMP-FN)
-             (EVAL CODE-RECLAIM-TEST-TEMP-FN))
-         (PRINTOUT T "  Starting code-block reclaim test" T)
-         (|for|
 I |from|
 1 |to|
 LIMIT |do|
 (BKSYSBUF "ST
-N
-")
-                                                        (COMPILE 'CODE-RECLAIM-TEST-TEMP-FN))
-         (PRINTOUT T "  Starting MAPATOMS(GETD)" T)
-         (|for|
 I |from|
 1 |to|
 LIMIT |do|
 (MAPATOMS (FUNCTION GETD)))
-         (PRINTOUT T "  Starting MAPATOMS(MOVD to DUMMYFN)" T)
-         (FOR
 I FROM
 1 TO
 LIMIT DO
 (MAPATOMS #'(LAMBDA (FN-NAME)
-                                                                 (AND (GETD FN-NAME)
-                                                                      (MOVD FN-NAME 
-                                                                            'MAIKO-GC-TEST-DUMMY-FN))
-                                                                 ))))))
-)
-
-
-
-(* |;;| 
-"The function that is repeatedly compiled to test that code-block constants inside code blocks are reclaimed."
-)

-
-
-(RPAQQ CODE-RECLAIM-TEST-TEMP-FN
 
-       (DEFINEQ (CODE-RECLAIM-TEST-TEMP-FN (ASDF)
-                       (LET (I)
-                            (FOR I FROM 1 TO 10 COLLECT (SQRT 4.5))
-                            (ERSETQ (DATE))
-                            (NLSETQ (DATE))
-                            (ERSETQ (DATE))
-                            (NLSETQ (DATE))
-                            (ERSETQ (DATE))
-                            (CL:FLET ((TEMP (ARG)
-                                            (SETQ ARG (FLOAT ARG))
-                                            (EXPT (SQRT I)
-                                                  (SQRT (COS (/ I 180))))))
-                                   (CL:UNWIND-PROTECT
-                                       (FOR I FROM 1 TO 1000 COLLECT (TEMP I))
-                                       (SETQ I NIL)))))))
-(PUTPROPS MAIKO-GC-TESTS COPYRIGHT ("John Sybalsky & Xerox Corporation" 1988))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (2794 5208 (MAIN-GC-TEST 2804 . 5206)) (5209 13651 (ITEMS-ON-STACK-TEST 5219 . 6382) (
-MANY-BIGNUM-MAKER 6384 . 7256) (MANY-FIXP-MAKER 7258 . 8044) (MANY-FLOAT-MAKER 8046 . 8653) (
-BOUNDARY-TESTS 8655 . 11122) (ARRAY-STRING-TEST 11124 . 13070) (VARIOUS-TYPES-TEST 13072 . 13649)) (
-13652 18513 (TEDIT-CRUNCH-TEST 13662 . 15074) (LIST-MANIPULATION-TEST 15076 . 18511)) (18514 19198 (
-ATOM-FULL-TEST 18524 . 18955) (STORAGE-FULL-TEST 18957 . 19196)) (19199 19717 (DATATYPE-TEST 19209 . 
-19715)) (44700 45875 (CODE-RECLAIM-TEST 44710 . 45873)))))
-STOP

internal/test/IO/Keyboard/logs/keyboard.log.~1~

@@ -1,13 +0,0 @@
-;;; Test results for sysout of 12-Feb-88 18:51:29
-;;; Tests run on 17-Feb-88 14:16:42
-;;; Running tests from ({eris}<test>i/o>keyboard>hand>*.u;)
-
-Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>ASKUSER.U;1"
-:BEFORE forms for test "Testing AskUser" in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>ASKUSER.U;1" failed.
-Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1"
-:BEFORE forms for test "Testing PromptForWord" in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>PROMPTFORWORD.U;1" failed.
-Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>READNUMBER.U;1"
-:BEFORE forms for test "Testing ReadNumber" in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>READNUMBER.U;1" failed.
-Test "load the functions for the prompter for interactive tests" failed in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>TTYIN.U;1"
-:BEFORE forms for test "Testing TTYIN" in file "{ERIS}<TEST>I/O>KEYBOARD>HAND>TTYIN.U;1" failed.
-(END-OF-TESTS)